Index: /branches/experimentation/later/source/.cvsignore =================================================================== --- /branches/experimentation/later/source/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/.cvsignore (revision 8058) @@ -0,0 +1,10 @@ +*\.?fsl +*CL* +*cl* +*boot* +*fsl +.gdb* +*.image +README* +*~.* +*.app Index: /branches/experimentation/later/source/LGPL =================================================================== --- /branches/experimentation/later/source/LGPL (revision 8058) +++ /branches/experimentation/later/source/LGPL (revision 8058) @@ -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/experimentation/later/source/LICENSE =================================================================== --- /branches/experimentation/later/source/LICENSE (revision 8058) +++ /branches/experimentation/later/source/LICENSE (revision 8058) @@ -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/experimentation/later/source/bin/.cvsignore =================================================================== --- /branches/experimentation/later/source/bin/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/bin/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*fsl + + Index: /branches/experimentation/later/source/cocoa-ide/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*~.* +*fsl + Index: /branches/experimentation/later/source/cocoa-ide/Info.plist-proto =================================================================== --- /branches/experimentation/later/source/cocoa-ide/Info.plist-proto (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/Info.plist-proto (revision 8058) @@ -0,0 +1,109 @@ + + + + + CFBundleDevelopmentRegion + English + CFBundleDocumentTypes + + + CFBundleTypeExtensions + + lisp + + CFBundleTypeIconFile + openmcl-icon.icns + CFBundleTypeName + Lisp source code + CFBundleTypeRole + Editor + LSIsAppleDefaultForType + + NSDocumentClass + HemlockEditorDocument + + + CFBundleTypeIconFile + openmcl-icon.icns + CFBundleTypeName + Listener + CFBundleTypeRole + Editor + NSDocumentClass + HemlockListenerDocument + + + CFBundleTypeExtensions + + txt + text + * + + CFBundleTypeName + NSStringPboardType + CFBundleTypeOSTypes + + **** + + CFBundleTypeRole + Editor + NSDocumentClass + HemlockEditorDocument + + + CFBundleTypeName + html + CFBundleTypeRole + Editor + NSDocumentClass + DisplayDocument + + + CFBundleExecutable + OPENMCL-KERNEL + CFBundleHelpBookFolder + Help + CFBundleHelpBookName + OpenMCL Help + CFBundleIconFile + openmcl-icon.icns + CFBundleIdentifier + OPENMCL-IDENTIFIER + CFBundleInfoDictionaryVersion + 6.0 + CFBundleName + OPENMCL-NAME + CFBundlePackageType + APPL + CFBundleSignature + OMCL + CFBundleVersion + OPENMCL-VERSION + NSMainNibFile + MainMenu + NSPrincipalClass + LispApplication + UTExportedTypeDeclarations + + + UTTypeConformsTo + public.source-code + UTTypeDescription + Lisp source file + UTTypeIdentifier + org.lisp.lisp-source + UTTypeReferenceURL + + UTTypeTagSpecification + + public.filename-extension + + lisp + lsp + cl + + + + + + Index: /branches/experimentation/later/source/cocoa-ide/README =================================================================== --- /branches/experimentation/later/source/cocoa-ide/README (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/README (revision 8058) @@ -0,0 +1,80 @@ +November 20, 2007 + +This directory contains sources and other resources needed to build +a Cocoa-based IDE for Clozure CL on OSX. + +The IDE uses the ObjC bridge (in ccl/objc-bridge/) to communicate +with the ObjC runtime. + +The "./ide-contents" directory contains nib files, icons and other +resources used by the IDE. These are copied to the application bundle +by the build process. + +The "./hemlock" directory contains a hacked up version of Portable +Hemlock (forked from the main Portable Hemlock tree some years ago.) +Hemlock is public domain Emacs-like editor that comes with CMUCL; +Portable Hemlock is an attempt to "free Hemlock from its CMUCL prison" +(e.g., remove dependencies on CMUCL). Hemlock (and Portable Hemlock) +were designed to use CLX for display and event processing; the version +distributed here uses the Cocoa text system for that functionality. +Much of the initial work on Portable Hemlock was done by Gilbert Baumann. + +To run the IDE from within a ccl command-line session (a shell, Emacs shell +buffer, under SLIME or ILisp or ...), do: + +? (require "COCOA") + +The first time this is run, it'll compile the sources, generating lots +of compiler warnings. You'll also see messages noting that various +new ObjC-callable methods are being defined. When the loading process +completes, it creates a temporary application bundle in "ccl:temp +bundle.app" and activates it. You should see a new menubar, a +listener window, and a Clozure CL icon in the Dock. The non-GUI +listener process from which the REQUIRE was issued will remain active; +you may see warning/diagnostic/error messages from the IDE directed to +the standard output/error streams associated with that listener. +(Under SLIME, these messages might appear in the *inferior lisp* +buffer.) + +It's also possible to save the loaded IDE in a populated bundle, +effectively making it a double-clickable application. To do this, you +can do: + +? (require "COCOA-APPLICATION") + +which will create an application bundle in "ccl:Clozure CL.app" +and save an executable lisp image inside it. Double-clicking on +that bundle in the Finder will launch the IDE; any diagnostic +messages/warnings/etc. will be written to the system log, which +can be examined with the Console application. + +The IDE depends on functionality introduced in OSX 10.4 (Tiger). + + + +*Note: CCL directory and IDE Preferences + +Normally, the IDE assumes it is located at the top level of the "CCL" +directory. It uses the CCL directory to enable Meta-. to find the +system source files and require'd modules, among other things. If you +want to move the IDE somewhere else, e.g. to put it in the +Applications folder, but still want to be able to Meta-. and require +stuff from the CCL directory, you can set the "CCL Directory" entry in +the "Paths" pane of the Preferences dialog to the absolute path of the +directory containing the system sources. + +The values of changed application preferences are stored in +"~/Library/Preferences/com.clozure.Clozure CL.plist"; if you have +an old version of this file, it might be desirable to delete it +before invoking the IDE for the first time. + + +*Note: Interface files + +The standalone IDE bundle contains a copy of the FFI/ObjC interface +definition databases (i.e. the .cdb files) for its target platform in +Clozure CL.app/Contents/Resources/xxx-headers. If you create +additional databases that you want the IDE to access, you can just +copy them into the bundle. Conversely, if you'd rather use the +interface definitions in the CCL directory, just delete the ones in +the bundle. Index: /branches/experimentation/later/source/cocoa-ide/app-delegate.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/app-delegate.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/app-delegate.lisp (revision 8058) @@ -0,0 +1,127 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(defclass lisp-application-delegate (ns:ns-object) + () + (:metaclass ns:+ns-object)) + +;;; This method is a good place to: +;;; * register value transformer names +;;; * register default user defaults +(objc:defmethod (#/initialize :void) ((self +lisp-application-delegate)) + (#/setValueTransformer:forName: ns:ns-value-transformer + (make-instance 'font-to-name-transformer) + #@"FontToName") + + (let* ((domain (#/standardUserDefaults ns:ns-user-defaults)) + (initial-values (cocoa-defaults-initial-values)) + (dict (#/mutableCopy initial-values))) + (#/registerDefaults: domain dict) + (#/release dict) + (update-cocoa-defaults))) + +(objc:defmethod (#/applicationWillFinishLaunching: :void) + ((self lisp-application-delegate) notification) + (declare (ignore notification)) + + (initialize-user-interface)) + +(objc:defmethod (#/applicationWillTerminate: :void) + ((self lisp-application-delegate) notification) + (declare (ignore notification)) + ;; UI has decided to quit; terminate other lisp threads. + (ccl::prepare-to-quit)) + +(defloadvar *preferences-window-controller* nil) + +(objc:defmethod (#/showPreferences: :void) ((self lisp-application-delegate) + sender) + (declare (ignore sender)) + (when (null *preferences-window-controller*) + (setf *preferences-window-controller* + (make-instance 'preferences-window-controller))) + (#/showWindow: *preferences-window-controller* self)) + +(defloadvar *processes-window-controller* nil) + +(objc:defmethod (#/showProcessesWindow: :void) ((self lisp-application-delegate) + sender) + (declare (ignore sender)) + (when (null *processes-window-controller*) + (setf *processes-window-controller* + (make-instance 'processes-window-controller))) + (#/showWindow: *processes-window-controller* self)) + +(defloadvar *apropos-window-controller* nil) + +(objc:defmethod (#/showAproposWindow: :void) ((self lisp-application-delegate) + sender) + (declare (ignore sender)) + (when (null *apropos-window-controller*) + (setf *apropos-window-controller* + (make-instance 'apropos-window-controller))) + (#/showWindow: *apropos-window-controller* self)) + +(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate) + sender) + (declare (ignore sender)) + (#/openUntitledDocumentOfType:display: + (#/sharedDocumentController ns:ns-document-controller) #@"Listener" t)) + +(objc:defmethod (#/showListener: :void) ((self lisp-application-delegate) + sender) + (declare (ignore sender)) + (let* ((all-windows (#/orderedWindows *NSApp*)) + (key-window (#/keyWindow *NSApp*)) + (listener-windows ()) + (top-listener nil)) + (dotimes (i (#/count all-windows)) + (let* ((w (#/objectAtIndex: all-windows i)) + (wc (#/windowController w))) + (when (eql (#/class wc) hemlock-listener-window-controller) + (push w listener-windows)))) + (setq listener-windows (nreverse listener-windows)) + (setq top-listener (car listener-windows)) + (cond + ((null listener-windows) + (#/newListener: self +null-ptr+)) + ((eql key-window top-listener) + ;; The current window is a listener. If there is more than + ;; one listener, bring the rear-most forward. + (let* ((w (car (last listener-windows)))) + (if (eql top-listener w) + (#_NSBeep) + (#/makeKeyAndOrderFront: w +null-ptr+)))) + (t + (#/makeKeyAndOrderFront: top-listener +null-ptr+))))) + +(objc:defmethod (#/ensureListener: :void) ((self lisp-application-delegate) + sender) + (declare (ignore sender)) + (let ((top-listener-document (#/topListener hemlock-listener-document))) + (when (eql top-listener-document +null-ptr+) + (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) + (wc nil)) + (setq top-listener-document + (#/makeUntitledDocumentOfType:error: dc #@"Listener" +null-ptr+)) + (#/addDocument: dc top-listener-document) + (#/makeWindowControllers top-listener-document) + (setq wc (#/lastObject (#/windowControllers top-listener-document))) + (#/orderFront: (#/window wc) +null-ptr+))))) + +(defvar *cocoa-application-finished-launching* (make-semaphore) + "Semaphore that's signaled when the application's finished launching ...") + +(objc:defmethod (#/applicationDidFinishLaunching: :void) + ((self lisp-application-delegate) notification) + (declare (ignore notification)) + (signal-semaphore *cocoa-application-finished-launching*)) + +(objc:defmethod (#/applicationOpenUntitledFile: :) + ((self lisp-application-delegate) app) + (when (zerop *cocoa-listener-count*) + (#/newListener: self app) + t)) Index: /branches/experimentation/later/source/cocoa-ide/apropos-window.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/apropos-window.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/apropos-window.lisp (revision 8058) @@ -0,0 +1,220 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(defclass package-combo-box (ns:ns-combo-box) + ((packages :initform nil)) + (:metaclass ns:+ns-object)) + +;;; This is a premature optimization. Instead of calling LIST-ALL-PACKAGES +;;; so frequently, just get a fresh copy when the user clicks in the +;;; combo box. +(objc:defmethod (#/becomeFirstResponder :) ((self package-combo-box)) + (with-slots (packages) self + (setf packages (coerce (list-all-packages) 'vector)) + (setf packages (sort packages #'string-lessp :key #'package-name))) + (call-next-method)) + +(defclass apropos-window-controller (ns:ns-window-controller) + ((apropos-array :foreign-type :id :initform +null-ptr+ + :reader apropos-array + :documentation "Bound to NSArrayController in nib file") + (array-controller :foreign-type :id :accessor array-controller) + (combo-box :foreign-type :id :accessor combo-box) + (table-view :foreign-type :id :accessor table-view) + (text-view :foreign-type :id :accessor text-view) + (external-symbols-checkbox :foreign-type :id + :accessor external-symbols-checkbox) + (shows-external-symbols :initform nil) + (symbol-list :initform nil) + (package :initform nil) + (input :initform nil) + (previous-input :initform nil :accessor previous-input + :documentation "Last string entered")) + (:metaclass ns:+ns-object)) + +(defmethod (setf apropos-array) (value (self apropos-window-controller)) + (with-slots (apropos-array) self + (unless (eql value apropos-array) + (#/release apropos-array) + (setf apropos-array (#/retain value))))) + +;;; Diasable automatic KVO notifications, since having our class swizzled +;;; out from underneath us confuses CLOS. (Leopard doesn't hose us, +;;; and we can use automatic KVO notifications there.) +(objc:defmethod (#/automaticallyNotifiesObserversForKey: :) ((self +apropos-window-controller) + key) + (declare (ignore key)) + nil) + +(objc:defmethod (#/awakeFromNib :void) ((self apropos-window-controller)) + (with-slots (table-view text-view) self + (#/setString: text-view #@"") + (#/setDelegate: table-view self) + (#/setDoubleAction: table-view (@selector #/inspectSelectedSymbol:)))) + +(objc:defmethod #/init ((self apropos-window-controller)) + (prog1 + (#/initWithWindowNibName: self #@"apropos") + (#/setShouldCascadeWindows: self nil) + (#/setWindowFrameAutosaveName: self #@"apropos panel") + (setf (apropos-array self) (#/array ns:ns-mutable-array)))) + +(objc:defmethod (#/dealloc :void) ((self apropos-window-controller)) + (#/release (slot-value self 'apropos-array)) + (call-next-method)) + +(objc:defmethod (#/toggleShowsExternalSymbols: :void) + ((self apropos-window-controller) sender) + (declare (ignore sender)) + (with-slots (shows-external-symbols) self + (setf shows-external-symbols (not shows-external-symbols)) + (update-symbol-list self) + (update-apropos-array self))) + +(objc:defmethod (#/setPackage: :void) ((self apropos-window-controller) + sender) + (with-slots (combo-box package) self + (assert (eql sender combo-box)) + (with-slots (packages) sender + (let ((index (#/indexOfSelectedItem sender))) + (if (minusp index) + (setf package nil) ;search all packages + (setf package (svref packages index)))))) + (update-symbol-list self) + (update-apropos-array self)) + +(defmethod update-symbol-list ((self apropos-window-controller)) + (with-slots (input package shows-external-symbols symbol-list) self + (when (plusp (length input)) + (setf symbol-list nil) + (if package + (if shows-external-symbols + (do-external-symbols (sym package) + (when (ccl::%apropos-substring-p input (symbol-name sym)) + (push sym symbol-list))) + (do-symbols (sym package) + (when (ccl::%apropos-substring-p input (symbol-name sym)) + (push sym symbol-list)))) + (if shows-external-symbols + (dolist (p (list-all-packages)) + (do-external-symbols (sym p) + (when (ccl::%apropos-substring-p input (symbol-name sym)) + (push sym symbol-list)))) + (do-all-symbols (sym) + (when (ccl::%apropos-substring-p input (symbol-name sym)) + (push sym symbol-list))))) + (setf symbol-list (sort symbol-list #'string-lessp))))) + +(defmethod update-apropos-array ((self apropos-window-controller)) + (with-slots (input apropos-array symbol-list package) self + (when (plusp (length input)) + (let ((new-array (#/array ns:ns-mutable-array)) + (*package* (or package (find-package "COMMON-LISP-USER"))) + (n 0)) + (dolist (s symbol-list) + (#/addObject: new-array (#/dictionaryWithObjectsAndKeys: + ns:ns-dictionary + (#/autorelease + (%make-nsstring + (prin1-to-string s))) + #@"symbol" + (#/numberWithInt: ns:ns-number n) + #@"index" + (#/autorelease + (%make-nsstring + (inspector::symbol-type-line s))) + #@"kind" + +null-ptr+)) + (incf n)) + (#/willChangeValueForKey: self #@"aproposArray") + (setf apropos-array new-array) + (#/didChangeValueForKey: self #@"aproposArray"))))) + +(objc:defmethod (#/apropos: :void) ((self apropos-window-controller) sender) + (let* ((input (lisp-string-from-nsstring (#/stringValue sender)))) + (when (and (plusp (length input)) + (not (string-equal input (previous-input self)))) + (setf (slot-value self 'input) input) + (setf (previous-input self) input) + (update-symbol-list self) + (update-apropos-array self)))) + +(objc:defmethod (#/inspectSelectedSymbol: :void) ((self apropos-window-controller) sender) + (let* ((row (#/clickedRow sender))) + (unless (minusp row) + (with-slots (array-controller symbol-list) self + (let* ((number (#/valueForKeyPath: array-controller #@"selection.index")) + (i (#/intValue number)) + (sym (elt symbol-list i))) + (cinspect sym)))))) + +;;; Data source methods for package combo box + +(objc:defmethod (#/numberOfItemsInComboBox: :nteger) ((self apropos-window-controller) + combo-box) + (declare (ignore combo-box)) + (length (list-all-packages))) + +(objc:defmethod #/comboBox:objectValueForItemAtIndex: ((self apropos-window-controller) + combo-box + (index :nteger)) + (with-slots (packages) combo-box + (let* ((pkg-name (package-name (svref packages index)))) + (if pkg-name + (#/autorelease (%make-nsstring pkg-name)) + +null-ptr+)))) + +(objc:defmethod #/comboBox:completedString: ((self apropos-window-controller) + combo-box + partial-string) + (flet ((string-prefix-p (s1 s2) + "Is s1 a prefix of s2?" + (string-equal s1 s2 :end2 (min (length s1) (length s2))))) + (with-slots (packages) combo-box + (let* ((s (lisp-string-from-nsstring partial-string))) + (dotimes (i (length packages) +null-ptr+) + (let ((name (package-name (svref packages i)))) + (when (string-prefix-p s name) + (return (#/autorelease (%make-nsstring name)))))))))) + +(objc:defmethod (#/comboBox:indexOfItemWithStringValue: :nteger) + ((self apropos-window-controller) + combo-box + string) + (with-slots (packages) combo-box + (let* ((s (lisp-string-from-nsstring string))) + (or (position s packages :test #'(lambda (str pkg) + (string-equal str (package-name pkg)))) + #$NSNotFound)))) + + +;;; Table view delegate methods + +(objc:defmethod (#/tableViewSelectionDidChange: :void) ((self apropos-window-controller) + notification) + (with-slots (array-controller symbol-list text-view) self + (let* ((tv (#/object notification)) + (row (#/selectedRow tv))) + (unless (minusp row) + (let* ((number (#/valueForKeyPath: + array-controller #@"selection.index")) + (i (#/intValue number)) + (sym (elt symbol-list i)) + (info (make-array '(0) :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (with-output-to-string (s info) + (dolist (doctype '(compiler-macro function method-combination + setf structure t type variable)) + (let ((docstring (documentation sym doctype))) + (when docstring + (format s "~&~a" docstring)) + (when (eq doctype 'function) + (format s "~&arglist: ~s" (arglist sym)))))) + (if (plusp (length info)) + (#/setString: text-view (#/autorelease (%make-nsstring info))) + (#/setString: text-view #@""))))))) + + Index: /branches/experimentation/later/source/cocoa-ide/build-application.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/build-application.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/build-application.lisp (revision 8058) @@ -0,0 +1,79 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- +;;;; *********************************************************************** +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: build-application.lisp +;;;; Version: 0.9 +;;;; Project: Cocoa application builder +;;;; Purpose: the in-process application builder +;;;; +;;;; *********************************************************************** + +(require "builder-utilities") + +(in-package :ccl) + +;;; about copying nibfiles + +;;; when building an app bundle, we copy nibfiles from the development +;;; environment appplication bundle into the newly-created application +;;; bundle. If user-supplied nibfiles are given the same names as +;;; nibfiles from the development environment, we signal an error and +;;; refuse to copy the user nibfiles. This treatment ensures that users +;;; will not accidentally clobber dev-environment nibfiles, but also +;;; means that they must give unique names to their own nibs in order +;;; to use them with their saved applications. + +;;; in future, we may add options to suppress the copying of +;;; dev-environment nibfiles. + +#| +temporarily removed for debugging +(save-application image-path + :application-class application-class + :toplevel-function toplevel-function + :prepend-kernel t) +|# + +(defun build-application (&key + (name "MyApplication") + (type-string "APPL") + (creator-string "OMCL") + (directory (current-directory)) + (nibfiles nil) ; a list of user-specified nibfiles + ; to be copied into the app bundle + (main-nib-name) ; the name of the nib that is to be loaded + ; as the app's main. this name gets written + ; into the Info.plist on the "NSMainNibFile" key + (application-class 'gui::cocoa-application) + (toplevel-function nil)) + + (let* ((ide-bundle (#/mainBundle ns:ns-bundle)) + (ide-bundle-path-nsstring (#/bundlePath ide-bundle)) + (ide-bundle-path (pathname + (ensure-directory-pathname + (lisp-string-from-nsstring ide-bundle-path-nsstring)))) + ;; create the bundle directory + (app-bundle (make-application-bundle name type-string creator-string directory + :main-nib-name main-nib-name)) + (image-path (namestring (path app-bundle "Contents" "MacOS" name)))) + ;; copy IDE resources to the bundle + (recursive-copy-directory (path ide-bundle-path "Contents" "Resources/") + (path app-bundle "Contents" "Resources/") + :if-exists :overwrite) + ;; copy user nibfiles into the bundle + (when nibfiles + (let ((nib-paths (mapcar #'pathname nibfiles))) + (assert (and (every #'probe-file nib-paths)) + (nibfiles) + "The nibfiles parameter must be a list of valid pathnames to existing files or directories") + (dolist (n nib-paths) + (let ((dest (path app-bundle "Contents" "Resources" "English.lproj/"))) + (copy-nibfile n dest :if-exists :overwrite))))) + ;; save the application image into the bundle + (save-application image-path + :application-class application-class + :toplevel-function toplevel-function + :prepend-kernel t))) + + Index: /branches/experimentation/later/source/cocoa-ide/builder-utilities.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/builder-utilities.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/builder-utilities.lisp (revision 8058) @@ -0,0 +1,156 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- +;;;; *********************************************************************** +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: builder-utilities.lisp +;;;; Version: 0.9 +;;;; Project: bosco - Cocoa application builder +;;;; Purpose: utilities used by both batch and interactive builders +;;;; +;;;; *********************************************************************** + +(in-package :ccl) + +;;; ABOUT +;;; ------------------------------------------------------------------------ +;;; Builder-utilities contains several functions used by OpenMCL +;;; application-building tools for building and copying bundles, +;;; resource directories, and magic files used by OSX applications. + +(defun load-nibfile (nib-path) + (let* ((appclass (#_NSClassFromString (%make-nsstring "NSApplication"))) + (app (#/sharedApplication appclass)) + (main-nib-name (%make-nsstring (namestring nib-path)))) + ;; ---------------------------------------- + ;; load the application nib + (#/loadNibNamed:owner: (@class ns-bundle) + main-nib-name + app) + app)) + +(defun copy-nibfile (srcnib dest-directory &key (if-exists :overwrite)) + (setq if-exists (require-type if-exists '(member :overwrite :error))) + (let* ((basename (basename srcnib)) + (dest (path dest-directory basename))) + (if (probe-file dest) + (case if-exists + (:overwrite (progn + (if (directoryp dest) + (recursive-delete-directory dest) + (delete-file dest)))) + (:error (error "The nibfile '~A' already exists" dest)))) + (if (directoryp srcnib) + (recursive-copy-directory srcnib dest) + (copy-file srcnib dest)))) + +;;; BASENAME path +;;; returns the final component of a pathname--that is, the +;;; filename (with type extension) if it names a file, or the +;;; last directory name if it names a directory +;;; TODO: perhaps BASENAME should check the file or directory +;;; named by PATH and ensure that, if the named file +;;; or directory exists, then the choice of returning +;;; a file or directory is based on what the actual target +;;; is, rather than on what the text of PATH suggests? + +(defun basename (path) + (let* ((dir (pathname-directory path)) + (name (pathname-name path)) + (type (pathname-type path))) + (if name + (if type + (make-pathname :name name :type type) + (make-pathname :name name)) + (make-pathname :directory (first (last dir)))))) + +;;; PATH (&rest components) +;;; returns a pathname. The input COMPONENTS are treated as +;;; directory names, each contained in the one to the left, except +;;; for the last. The last is treated as a directory if it ends +;;; with a path separator, and a file if it doesn't +(defun path (&rest components) + (if (null components) + (pathname "") + (if (null (cdr components)) + (pathname (car components)) + (merge-pathnames (apply #'path (cdr components)) + (ensure-directory-pathname (car components)))))) + + +;;; WRITE-PKGINFO path package-type bundle-signature +;;; Writes a PkgInfo file of the sort used by Cocoa applications +;;; to identify their package types and signatures. Writes +;;; PACKAGE-TYPE and BUNDLE-SIGNATURE to the file at PATH, +;;; clobbering it if it already exists. +(defun write-pkginfo (path package-type bundle-signature) + (with-open-file (out path + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (format out "~A~A" package-type bundle-signature))) + +;;; WRITE-INFO-PLIST path name package-type bundle-signature +;;; Reads the Info.plist file of the running IDE application +;;; into an NSMutableDictionary; sets the name, package-type, +;;; and bundle-signature from the inputs; writes the changed +;;; dictionary to a new Info.plist file at PATH. +;;; +;;; TODO: this function is extremely specialized to the case +;;; of writing an Info.plist for an app bundle that is +;;; copied from the IDE. Should separate the IDE-specific +;;; behavior from more general behavior that can be used +;;; by the batch builder, which does not depend on the IDE. +(defun write-info-plist (path name package-type bundle-signature + &key main-nib-name) + ;; read the Info.plist of the IDE app, change + ;; the fields needed, write the results to PATH + (assert (or (null main-nib-name) + (stringp main-nib-name)) + (main-nib-name) + "The main-nib-name must be a string or NIL, not ~S" main-nib-name) + (with-autorelease-pool + (let* ((bundle-name-key (%make-nsstring "CFBundleName")) + (bundle-name-str (%make-nsstring name)) + (type-key (%make-nsstring "CFBundlePackageType")) + (type-str (%make-nsstring package-type)) + (sig-key (%make-nsstring "CFBundleSignature")) + (sig-str (%make-nsstring bundle-signature)) + (ide-bundle (#/mainBundle ns:ns-bundle)) + (ide-bundle-path-nsstring (#/bundlePath ide-bundle)) + (ide-bundle-path (ensure-directory-pathname + (lisp-string-from-nsstring ide-bundle-path-nsstring))) + (ide-plist-path-str (namestring (path ide-bundle-path + "Contents" "Info.plist"))) + (info-dict (#/dictionaryWithContentsOfFile: ns:ns-mutable-dictionary + ide-plist-path-str)) + (app-name-key (%make-nsstring "CFBundleExecutable")) + (app-name-str (%make-nsstring name)) + (app-plist-path-str (%make-nsstring (namestring path)))) + (#/setValue:forKey: info-dict bundle-name-str bundle-name-key) + (#/setValue:forKey: info-dict app-name-str app-name-key) + (#/setValue:forKey: info-dict type-str type-key) + (#/setValue:forKey: info-dict sig-str sig-key) + (when main-nib-name + (#/setValue:forKey: info-dict + (%make-nsstring main-nib-name) + #@"NSMainNibFile")) + (#/writeToFile:atomically: info-dict app-plist-path-str #$YES)))) + +;;; MAKE-APPLICATION-BUNDLE name package-type bundle-signature project-path +;;; Build the directory structure of a Cocoa application bundle and +;;; populate it with the required PkgInfo and Info.plist files. +(defun make-application-bundle (name package-type bundle-signature project-path + &key main-nib-name) + (let* ((app-bundle (path project-path + (ensure-directory-pathname (concatenate 'string name ".app")))) + (contents-dir (path app-bundle (ensure-directory-pathname "Contents"))) + (macos-dir (path contents-dir (ensure-directory-pathname "MacOS"))) + (rsrc-dir (path contents-dir "Resources" + (ensure-directory-pathname "English.lproj")))) + (ensure-directories-exist macos-dir) + (ensure-directories-exist rsrc-dir) + (write-info-plist (path app-bundle "Contents" "Info.plist") + name package-type bundle-signature :main-nib-name main-nib-name) + (write-pkginfo (path app-bundle "Contents" "PkgInfo") + package-type bundle-signature) + app-bundle)) Index: /branches/experimentation/later/source/cocoa-ide/cocoa-application.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-application.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-application.lisp (revision 8058) @@ -0,0 +1,30 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2002-2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") ; for now. + + +(defvar *cocoa-application-path* "ccl:Clozure CL.app;") +(defvar *cocoa-application-copy-headers-p* t) +(load "ccl:cocoa-ide;defsystem.lisp") +(load-ide) + +;;; If things go wrong, you might see some debugging information via +;;; the OSX console (/Applications/Utilities/Console.app.) Standard +;;; and error output for the initial lisp process will be directed +;;; there. +(build-ide *cocoa-application-path*) Index: /branches/experimentation/later/source/cocoa-ide/cocoa-backtrace.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-backtrace.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-backtrace.lisp (revision 8058) @@ -0,0 +1,279 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(defclass ns-lisp-string (ns:ns-string) + ((lisp-string :initarg :string :reader ns-lisp-string-string)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/length :nteger) ((self ns-lisp-string)) + (length (ns-lisp-string-string self))) + +(objc:defmethod (#/characterAtIndex: :unichar) ((self ns-lisp-string) (index :nteger)) + (char-code (schar (ns-lisp-string-string self) index))) + +(defclass frame-label (ns-lisp-string) + ((frame-number :foreign-type :int :accessor frame-label-number) + (controller :foreign-type :id :reader frame-label-controller) + (frame-inspector :initform nil :accessor frame-label-frame-inspector)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (frame-number :int) controller) + (let* ((obj (#/init self))) + (unless (%null-ptr-p obj) + (setf (slot-value obj 'frame-number) frame-number + (slot-value obj 'controller) controller)) + obj)) + + +(defclass item-label (ns-lisp-string) + ((frame-label :foreign-type :id :accessor item-label-label) + (index :foreign-type :int :accessor item-label-index)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-label (index :int)) + (let* ((obj (#/init self))) + (unless (%null-ptr-p obj) + (setf (slot-value obj 'frame-label) the-frame-label + (slot-value obj 'index) index)) + obj)) + +(defclass backtrace-window-controller (ns:ns-window-controller) + ((context :initarg :context :reader backtrace-controller-context) + (inspector :initform nil :reader backtrace-controller-inspector) + (outline-view :foreign-type :id :reader backtrace-controller-outline-view)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/windowNibName ((self backtrace-window-controller)) + #@"backtrace") + +(objc:defmethod (#/close :void) ((self backtrace-window-controller)) + (setf (slot-value self 'context) nil) + (call-next-method)) + +(defmethod our-frame-label-p ((self backtrace-window-controller) thing) + (and (typep thing 'frame-label) + (eql self (frame-label-controller thing)))) + +(def-cocoa-default *backtrace-font-name* :string "Monaco" "Name of font used in backtrace views") +(def-cocoa-default *backtrace-font-size* :float 9.0f0 "Size of font used in backtrace views") + + +(defun context-process (context) + (and context (ccl::tcr->process (ccl::bt.tcr context)))) + +(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller)) + (let* ((outline (slot-value self 'outline-view)) + (font (default-font :name *backtrace-font-name* :size *backtrace-font-size*))) + (unless (%null-ptr-p outline) + (#/setTarget: outline self) + (#/setRowHeight: outline (size-of-char-in-font font)) + (#/setDoubleAction: outline (@selector #/backtraceDoubleClick:)) + (#/setShouldCascadeWindows: self nil) + (let* ((columns (#/tableColumns outline))) + (dotimes (i (#/count columns)) + (let* ((column (#/objectAtIndex: columns i)) + (data-cell (#/dataCell column))) + (#/setEditable: data-cell nil) + (#/setFont: data-cell font) + (when (eql i 0) + (let* ((header-cell (#/headerCell column)) + (inspector (backtrace-controller-inspector self)) + (break-condition + (inspector::break-condition + (inspector::inspector-object inspector))) + (break-condition-string + (let* ((*print-level* 5) + (*print-length* 5) + (*print-circle* t)) + (format nil "~a: ~a" + (class-name (class-of break-condition)) + break-condition)))) + (#/setFont: header-cell (default-font :name "Courier" :size 10 :attributes '(:bold))) + (#/setStringValue: header-cell (%make-nsstring break-condition-string)))))))) + (let* ((window (#/window self))) + (unless (%null-ptr-p window) + (let* ((context (backtrace-controller-context self)) + (process (context-process context)) + (listener-window (if (typep process 'cocoa-listener-process) + (cocoa-listener-process-window process)))) + (when listener-window + (let* ((listener-frame (#/frame listener-window)) + (backtrace-width (ns:ns-rect-width (#/frame window))) + (new-x (- (+ (ns:ns-rect-x listener-frame) + (/ (ns:ns-rect-width listener-frame) 2)) + (/ backtrace-width 2)))) + (ns:with-ns-point (p new-x (+ (ns:ns-rect-y listener-frame) (ns:ns-rect-height listener-frame))) + (#/setFrameOrigin: window p)))) + (#/setTitle: window (%make-nsstring + (format nil "Backtrace for ~a(~d), break level ~d" + (process-name process) + (process-serial-number process) + (ccl::bt.break-level context))))))))) + +(objc:defmethod (#/continue: :void) ((self backtrace-window-controller) sender) + (declare (ignore sender)) + (let* ((context (backtrace-controller-context self)) + (process (context-process context))) + (when process (process-interrupt process #'continue)))) + +(objc:defmethod (#/exitBreak: :void) ((self backtrace-window-controller) sender) + (declare (ignore sender)) + (let* ((context (backtrace-controller-context self)) + (process (context-process context))) + (when process (process-interrupt process #'abort-break)))) + +(objc:defmethod (#/restarts: :void) ((self backtrace-window-controller) sender) + (let* ((context (backtrace-controller-context self))) + (when context + (#/showWindow: (restarts-controller-for-context context) sender)))) + + + +(objc:defmethod (#/backtraceDoubleClick: :void) + ((self backtrace-window-controller) sender) + (let* ((row (#/clickedRow sender))) + (if (>= row 0) + (let* ((item (#/itemAtRow: sender row)) + (val-p nil) + (value nil)) + (cond ((typep item 'frame-label) + (let* ((controller (frame-label-controller item)) + (inspector (backtrace-controller-inspector controller)) + (frame-number (frame-label-number item))) + (setq val-p t value (inspector::line-n inspector frame-number)))) + ((typep item 'item-label) + (let* ((the-frame-label (item-label-label item)) + (frame-inspector (frame-label-frame-inspector the-frame-label)) + (index (item-label-index item)) + (rawval (inspector::line-n frame-inspector index))) + (if (and (consp rawval) + (typep (car rawval) 'keyword)) + (setq val-p t value (cddr rawval)))))) + (if val-p + (cinspect value)))))) + + + + +(objc:defmethod (#/outlineView:isItemExpandable: :) + ((self backtrace-window-controller) view item) + (declare (ignore view)) + (or (%null-ptr-p item) + (our-frame-label-p self item))) + +(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :nteger) + ((self backtrace-window-controller) view item) + (declare (ignore view)) + (let* ((inspector (backtrace-controller-inspector self))) + (cond ((%null-ptr-p item) + (inspector::inspector-line-count inspector)) + ((our-frame-label-p self item) + (let* ((frame-inspector + (or (frame-label-frame-inspector item) + (setf (frame-label-frame-inspector item) + (make-instance + 'inspector::stack-frame-inspector + :frame-number (frame-label-number item) + :object (inspector::inspector-object inspector) + :update-line-count t))))) + (inspector::inspector-line-count frame-inspector))) + (t -1)))) + +(objc:defmethod #/outlineView:child:ofItem: + ((self backtrace-window-controller) view (index :nteger) item) + (declare (ignore view)) + (let* ((inspector (backtrace-controller-inspector self))) + (cond ((%null-ptr-p item) + (let* ((label + (make-instance 'frame-label + :with-frame-number index + :controller self + :string + (let* ((value + (inspector::line-n inspector index))) + (if value + (ccl::%lfun-name-string value) + ":kernel"))))) + label)) + ((our-frame-label-p self item) + (let* ((frame-inspector + (or (frame-label-frame-inspector item) + (setf (frame-label-frame-inspector item) + (make-instance + 'inspector::stack-frame-inspector + :frame-number (frame-label-number item) + :object (inspector::inspector-object inspector) + :update-line-count t))))) + (make-instance 'item-label + :with-frame-label item + :index index + :string + (let* ((ccl::*aux-vsp-ranges* (inspector::vsp-range inspector)) + (ccl::*aux-tsp-ranges* (inspector::tsp-range inspector)) + (ccl::*aux-csp-ranges* (inspector::csp-range inspector))) + (with-output-to-string (s) + (let* ((value + (inspector::line-n + frame-inspector + index))) + (inspector::prin1-value + frame-inspector + s + value))))))) + (t (break) (%make-nsstring "Huh?"))))) + +(objc:defmethod #/outlineView:objectValueForTableColumn:byItem: + ((self backtrace-window-controller) view column item) + (declare (ignore view column)) + (if (%null-ptr-p item) + #@"Open this" + (%setf-macptr (%null-ptr) item))) + +(defmethod initialize-instance :after ((self backtrace-window-controller) + &key &allow-other-keys) + (setf (slot-value self 'inspector) + (make-instance 'inspector::stack-inspector :context (backtrace-controller-context self) :update-line-count t))) + +(defun backtrace-controller-for-context (context) + (or (ccl::bt.dialog context) + (setf (ccl::bt.dialog context) + (make-instance 'backtrace-window-controller + :with-window-nib-name #@"backtrace" + :context context)))) + +#+debug +(objc:defmethod (#/willLoad :void) ((self backtrace-window-controller)) + (#_NSLog #@"will load %@" :address (#/windowNibName self))) + +(defmethod ui-object-enter-backtrace-context ((app ns:ns-application) + context) + (let* ((proc *current-process*)) + (when (typep proc 'cocoa-listener-process) + (push context (cocoa-listener-process-backtrace-contexts proc))))) + +(defmethod ui-object-exit-backtrace-context ((app ns:ns-application) + context) + (let* ((proc *current-process*)) + (when (typep proc 'cocoa-listener-process) + (when (eq context (car (cocoa-listener-process-backtrace-contexts proc))) + (setf (cocoa-listener-process-backtrace-contexts proc) + (cdr (cocoa-listener-process-backtrace-contexts proc))) + (let* ((btwindow (prog1 (ccl::bt.dialog context) + (setf (ccl::bt.dialog context) nil))) + (restartswindow + (prog1 (car (ccl::bt.restarts context)) + (setf (ccl::bt.restarts context) nil)))) + (when btwindow + (#/performSelectorOnMainThread:withObject:waitUntilDone: btwindow (@selector #/close) +null-ptr+ t)) + (when restartswindow + (#/performSelectorOnMainThread:withObject:waitUntilDone: restartswindow (@selector #/close) +null-ptr+ t))))))) + + + + + + + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-defaults.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-defaults.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-defaults.lisp (revision 8058) @@ -0,0 +1,131 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2004 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "GUI") + +(defstruct cocoa-default + symbol ; a lisp special variable + string ; an NSConstantString + type ; a keyword + value ; the "standard" initial value + doc ; a doc string + change-hook ; an optional hook function + ) + +(let* ((cocoa-defaults ())) + (defun %get-cocoa-default (name) + (find name cocoa-defaults :key #'cocoa-default-symbol)) + (defun %put-cocoa-default (default) + (push default cocoa-defaults)) + (defun cocoa-defaults () cocoa-defaults) + (defun %remove-cocoa-default (name) + (setq cocoa-defaults + (delete name cocoa-defaults :key #'cocoa-default-symbol))) + (defun %clear-cocoa-defaults () (setq cocoa-defaults nil))) + +(defun set-cocoa-default (name string type value doc &optional change-hook) + (check-type name symbol) + (check-type string ccl::objc-constant-string) + (check-type type keyword) + (check-type doc (or null string)) + (%remove-cocoa-default name) + (%put-cocoa-default (make-cocoa-default :symbol name + :string string + :type type + :value value + :doc doc + :change-hook change-hook)) + (if (eq type :color) + (apply #'color-values-to-nscolor value) + value)) + +;;; Names which contain #\* confuse Cocoa Bindings. +(defun objc-default-key (name) + (ccl::ns-constant-string (ccl::lisp-to-objc-message (list (make-symbol (remove #\* (string name))))))) + + +(defun %define-cocoa-default (name type value doc &optional change-hook) + (proclaim `(special ,name)) + ;; Make the variable "GLOBAL": its value can be changed, but it can't + ;; have a per-thread binding. + (ccl::%symbol-bits name (logior (ash 1 ccl::$sym_vbit_global) + (the fixnum (ccl::%symbol-bits name)))) + (record-source-file name 'variable) + (setf (documentation name 'variable) doc) + (set name (set-cocoa-default name (objc-default-key name) type value doc change-hook)) + name) + + + +(defmacro def-cocoa-default (name type value doc &optional change-hook &environment env) + `(progn + (eval-when (:compile-toplevel) + (ccl::note-variable-info ',name :global ,env)) + (declaim (special ,name)) + (defloadvar ,name nil) + (%define-cocoa-default ',name ',type ,value ',doc ,change-hook))) + + +(defun update-cocoa-defaults () + (update-cocoa-defaults-list + (#/standardUserDefaults ns:ns-user-defaults) + (cocoa-defaults))) + +(defun update-cocoa-defaults-list (domain defaults) + (dolist (d defaults) + (let* ((name (cocoa-default-symbol d)) + (type (cocoa-default-type d)) + (key (ccl::objc-constant-string-nsstringptr (cocoa-default-string d)))) + (let* ((hook (cocoa-default-change-hook d)) + (old-value (symbol-value name))) + (case type + (:int + (set name (#/integerForKey: domain key))) + (:float + (set name (#/floatForKey: domain key))) + (:bool + (set name (#/boolForKey: domain key))) + (:string + (let* ((nsstring (#/stringForKey: domain key))) + (unless (%null-ptr-p nsstring) + (set name (lisp-string-from-nsstring nsstring))))) + ((:color :font) + (let* ((data (#/dataForKey: domain key))) + (unless (%null-ptr-p data) + (set name (#/retain (#/unarchiveObjectWithData: ns:ns-unarchiver data))))))) + (when hook (funcall hook old-value (symbol-value name))))))) + + + +;;; Return an NSDictionary describing the "default" values of the defaults. +(defun cocoa-defaults-initial-values () + (let* ((defaults (cocoa-defaults)) + (dict (make-instance 'ns:ns-mutable-dictionary + :with-capacity (length defaults)))) + (dolist (d defaults dict) + (let* ((value (cocoa-default-value d))) + (#/setObject:forKey: dict + (case (cocoa-default-type d) + (:color (#/archivedDataWithRootObject: + ns:ns-archiver + (apply #'color-values-to-nscolor value))) + (:font (#/archivedDataWithRootObject: + ns:ns-archiver + (funcall value))) + (:bool (if value #@"YES" #@"NO")) + (t + (%make-nsstring (format nil "~a" (cocoa-default-value d))))) + (ccl::objc-constant-string-nsstringptr (cocoa-default-string d))))))) Index: /branches/experimentation/later/source/cocoa-ide/cocoa-doc.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-doc.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-doc.lisp (revision 8058) @@ -0,0 +1,168 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(def-cocoa-default *hyperspec-url-string* :string "http://www.lispworks.com/documentation/HyperSpec/" "HTTP URL for HyperSpec lookup") + +(defloadvar *hyperspec-root-url* nil) +(defloadvar *hyperspec-map-sym-hash* nil) +(defloadvar *hyperspec-map-sym-url* nil) + +(def-cocoa-default *hyperspec-lookup-enabled* :bool nil "enables hyperspec lookup" + (lambda (old new) + (unless (eq new old) + (if new + (setup-hyperspec-root-url) + (progn + (when *hyperspec-root-url* + (#/release *hyperspec-root-url*)) + (setq *hyperspec-root-url* nil) + (when *hyperspec-map-sym-url* + (#/release *hyperspec-map-sym-url*)) + (setq *hyperspec-root-url* nil) + (setq *hyperspec-map-sym-hash* nil)))))) + + +(defclass display-document (ns:ns-document) + ((text-view :foreign-type :id)) + (:metaclass ns:+ns-object)) + +(defclass url-delegate (ns:ns-object) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/textView:clickedOnLink:atIndex: :) + ((self url-delegate) + textview + link + (index :nteger)) + (declare (ignorable link)) + (let* ((attribute (#/attribute:atIndex:effectiveRange: + (#/textStorage textview) + #&NSLinkAttributeName + index + +null-ptr+))) + (if (typep attribute 'ns:ns-url) + (rlet ((dictp :id +null-ptr+)) + (let* ((data (make-instance 'ns:ns-data :with-contents-of-url attribute)) + (string (unless (%null-ptr-p data) + (make-instance 'ns:ns-attributed-string + :with-html data + :base-url attribute + :document-attributes dictp))) + (textstorage (#/textStorage textview)) + (dict (pref dictp :id)) + (title (unless (%null-ptr-p dict) + (#/valueForKey: dict #&NSTitleDocumentAttribute)))) + (when title + (#/setTitle: (#/window textview) title)) + (when string + (#/beginEditing textstorage) + (#/replaceCharactersInRange:withAttributedString: + textstorage + (ns:make-ns-range 0 (#/length textstorage)) + string) + (#/setSelectedRange: textview (ns:make-ns-range 0 0)) + (#/endEditing textstorage) + (#/scrollRangeToVisible: textview (ns:make-ns-range 0 0))))))) + #$YES) + +(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :) + ((self url-delegate) + textview + (range :ange) + string) + (declare (ignorable textview range string)) + nil) + + + + + +(objc:defmethod #/windowNibName ((self display-document)) + #@"displaydoc") + +(objc:defmethod (#/windowControllerDidLoadNib: :void) + ((self display-document) controller) + (with-slots (text-view) self + (unless (%null-ptr-p text-view) + (#/setEditable: text-view t) + (#/setDelegate: text-view (make-instance 'url-delegate)))) + (call-next-method controller)) + + +(defun hyperspec-root-url () + (or *hyperspec-root-url* + (setq *hyperspec-root-url* (setup-hyperspec-root-url)))) + +(defun setup-hyperspec-root-url () + (make-instance 'ns:ns-url + :with-string + (%make-nsstring *hyperspec-url-string*))) + +(defun hyperspec-map-hash (document) + (or *hyperspec-map-sym-hash* + (rlet ((perror :id +null-ptr+)) + (let* ((map-url (make-instance 'ns:ns-url :with-string "Data/Map_Sym.txt" :relative-to-url (hyperspec-root-url))) + (data (make-instance 'ns:ns-data + :with-contents-of-url map-url + :options 0 + :error perror))) + (let* ((err (pref perror :id))) + (unless (%null-ptr-p err) + (#/presentError: document err) + (return-from hyperspec-map-hash nil))) + (with-input-from-string (s (%str-from-ptr (#/bytes data) (#/length data))) + (let* ((hash (make-hash-table :test #'eq)) + (*package* (find-package "CL")) + (eof (cons nil nil))) + (declare (dynamic-extent eof)) + (loop + (let* ((sym (read s nil eof)) + (url (read-line s nil eof))) + (when (eq sym eof) + (return + (setq *hyperspec-map-sym-url* map-url + *hyperspec-map-sym-hash* hash))) + (setf (gethash sym hash) url))))))))) + +(defun lookup-hyperspec-symbol (symbol doc) + (let* ((relative-url (gethash symbol (hyperspec-map-hash doc)))) + (when relative-url + (let* ((url (#/absoluteURL + (make-instance 'ns:ns-url + :with-string (%make-nsstring relative-url) + :relative-to-url *hyperspec-map-sym-url*)))) + (rlet ((pdocattrs :id +null-ptr+) + (perror :id +null-ptr+)) + (let* ((data (make-instance 'ns:ns-data + :with-contents-of-url url + :options 0 + :error perror))) + (if (not (%null-ptr-p (pref perror :id))) + (progn + (#/presentError: doc (pref perror :id))) + (let* ((string (make-instance 'ns:ns-attributed-string + :with-html data + :base-url url + :document-attributes pdocattrs)) + (docattrs (pref pdocattrs :id)) + (title (if (%null-ptr-p docattrs) + +null-ptr+ + (#/objectForKey: docattrs #&NSTitleDocumentAttribute)))) + (if (%null-ptr-p title) + (setq title (%make-nsstring (string symbol)))) + (#/newDisplayDocumentWithTitle:content: + (#/sharedDocumentController ns:ns-document-controller) + title + string))))))))) + + + + + + + + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-editor.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-editor.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-editor.lisp (revision 8058) @@ -0,0 +1,3055 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +;;; In the double-float case, this is probably way too small. +;;; Traditionally, it's (approximately) the point at which +;;; a single-float stops being able to accurately represent +;;; integral values. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant large-number-for-text (cgfloat 1.0f7))) + +(def-cocoa-default *editor-font* :font #'(lambda () + (#/fontWithName:size: + ns:ns-font + #@"Monaco" 10.0)) + "Default font for editor windows") + +(def-cocoa-default *editor-rows* :int 24 "Initial height of editor windows, in characters") +(def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters") + +(def-cocoa-default *editor-background-color* :color '(1.0 1.0 1.0 1.0) "Editor background color") +(def-cocoa-default *wrap-lines-to-window* :bool nil + "Soft wrap lines to window width") + +(def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available") + +(defmacro nsstring-encoding-to-nsinteger (n) + (ccl::target-word-size-case + (32 `(ccl::u32->s32 ,n)) + (64 n))) + +(defmacro nsinteger-to-nsstring-encoding (n) + (ccl::target-word-size-case + (32 `(ccl::s32->u32 ,n)) + (64 n))) + +;;; Create a paragraph style, mostly so that we can set tabs reasonably. +(defun rme-create-paragraph-style (font line-break-mode) + (let* ((p (make-instance 'ns:ns-mutable-paragraph-style)) + (charwidth (fround (nth-value 1 (size-of-char-in-font font))))) + (#/setLineBreakMode: p + (ecase line-break-mode + (:char #$NSLineBreakByCharWrapping) + (:word #$NSLineBreakByWordWrapping) + ;; This doesn't seem to work too well. + ((nil) #$NSLineBreakByClipping))) + ;; Clear existing tab stops. + (#/setTabStops: p (#/array ns:ns-array)) + ;; And set the "default tab interval". + (#/setDefaultTabInterval: p (* *tab-width* charwidth)) + p)) + +(defun rme-create-text-attributes (&key (font *editor-font*) + (line-break-mode :char) + (color nil) + (obliqueness nil) + (stroke-width nil)) + (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5))) + (#/setObject:forKey: dict (rme-create-paragraph-style font line-break-mode) + #&NSParagraphStyleAttributeName) + (#/setObject:forKey: dict font #&NSFontAttributeName) + (when color + (#/setObject:forKey: dict color #&NSForegroundColorAttributeName)) + (when stroke-width + (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width) + #&NSStrokeWidthAttributeName)) + (when obliqueness + (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness) + #&NSObliquenessAttributeName)) + dict)) + +(defun rme-make-editor-style-map () + (let* ((font *editor-font*) + (fm (#/sharedFontManager ns:ns-font-manager)) + (bold-font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask)) + (oblique-font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask)) + (bold-oblique-font (#/convertFont:toHaveTrait: + fm font (logior #$NSItalicFontMask + #$NSBoldFontMask))) + (colors (vector (#/blackColor ns:ns-color))) + (fonts (vector font bold-font oblique-font bold-oblique-font)) + (styles (make-instance 'ns:ns-mutable-array))) + (dotimes (c (length colors)) + (dotimes (i 4) + (let* ((mask (logand i 3)) + (f (svref fonts mask))) + (#/addObject: styles + (rme-create-text-attributes :font f + :color (svref colors c) + :obliqueness + (if (logbitp 1 i) + (when (eql f font) + 0.15f0)) + :stroke-width + (if (logbitp 0 i) + (when (eql f font) + -10.0f0))))))) + styles)) + +(defun make-editor-style-map () + (rme-make-editor-style-map)) + +#+nil +(defun make-editor-style-map () + (let* ((font-name *default-font-name*) + (font-size *default-font-size*) + (font (default-font :name font-name :size font-size)) + (bold-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold)))) + (unless (eql f font) f))) + (oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:italic)))) + (unless (eql f font) f))) + (bold-oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold :italic)))) + (unless (eql f font) f))) + (color-class (find-class 'ns:ns-color)) + (colors (vector (#/blackColor color-class))) + (styles (make-instance 'ns:ns-mutable-array + :with-capacity (the fixnum (* 4 (length colors))))) + (bold-stroke-width -10.0f0) + (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font))) + (real-fonts (vector font bold-font oblique-font bold-oblique-font)) + (s 0)) + (declare (dynamic-extent fonts real-fonts colors)) + (dotimes (c (length colors)) + (dotimes (i 4) + (let* ((mask (logand i 3))) + (#/addObject: styles + (create-text-attributes :font (svref fonts mask) + :color (svref colors c) + :obliqueness + (if (logbitp 1 i) + (unless (svref real-fonts mask) + 0.15f0)) + :stroke-width + (if (logbitp 0 i) + (unless (svref real-fonts mask) + bold-stroke-width))))) + (incf s))) + (#/retain styles))) + +(defun make-hemlock-buffer (&rest args) + (let* ((buf (apply #'hi::make-buffer args))) + (assert buf) + buf)) + +;;; Define some key event modifiers. + +;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use +;;; it to map NSEvent modifier keys to key-event modifiers. + +(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift") +(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control") +(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta") +(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock") + + +;;; We want to display a Hemlock buffer in a "pane" (an on-screen +;;; view) which in turn is presented in a "frame" (a Cocoa window). A +;;; 1:1 mapping between frames and panes seems to fit best into +;;; Cocoa's document architecture, but we should try to keep the +;;; concepts separate (in case we come up with better UI paradigms.) +;;; Each pane has a modeline (which describes attributes of the +;;; underlying document); each frame has an echo area (which serves +;;; to display some commands' output and to provide multi-character +;;; input.) + + +;;; I'd pretty much concluded that it wouldn't be possible to get the +;;; Cocoa text system (whose storage model is based on NSString +;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with +;;; Hemlock, and (since the whole point of using Hemlock was to be +;;; able to treat an editor buffer as a rich lisp data structure) it +;;; seemed like it'd be necessary to toss the higher-level Cocoa text +;;; system and implement our own scrolling, redisplay, selection +;;; ... code. +;;; +;;; Mikel Evins pointed out that NSString and friends were +;;; abstract classes and that there was therefore no reason (in +;;; theory) not to implement a thin wrapper around a Hemlock buffer +;;; that made it act like an NSString. As long as the text system can +;;; ask a few questions about the NSString (its length and the +;;; character and attributes at a given location), it's willing to +;;; display the string in a scrolling, mouse-selectable NSTextView; +;;; as long as Hemlock tells the text system when and how the contents +;;; of the abstract string changes, Cocoa will handle the redisplay +;;; details. +;;; + + + +;;; Hemlock-buffer-string objects: + +(defclass hemlock-buffer-string (ns:ns-string) + ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache)) + (:metaclass ns:+ns-object)) + +;;; Cocoa wants to treat the buffer as a linear array of characters; +;;; Hemlock wants to treat it as a doubly-linked list of lines, so +;;; we often have to map between an absolute position in the buffer +;;; and a relative position on a line. We can certainly do that +;;; by counting the characters in preceding lines every time that we're +;;; asked, but we're often asked to map a sequence of nearby positions +;;; and wind up repeating a lot of work. Caching the results of that +;;; work seems to speed things up a bit in many cases; this data structure +;;; is used in that process. (It's also the only way to get to the +;;; actual underlying Lisp buffer from inside the network of text-system +;;; objects.) + +(defstruct buffer-cache + buffer ; the hemlock buffer + buflen ; length of buffer, if known + workline ; cache for character-at-index + workline-offset ; cached offset of workline + workline-length ; length of cached workline + workline-start-font-index ; current font index at start of workline + ) + +;;; Initialize (or reinitialize) a buffer cache, so that it points +;;; to the buffer's first line (which is the only line whose +;;; absolute position will never change). Code which modifies the +;;; buffer generally has to call this, since any cached information +;;; might be invalidated by the modification. + +(defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d) + buffer-p)) + (when buffer-p (setf (buffer-cache-buffer d) buffer)) + (let* ((hi::*current-buffer* buffer) + (workline (hi::mark-line + (hi::buffer-start-mark buffer)))) + (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer) + (buffer-cache-workline-offset d) 0 + (buffer-cache-workline d) workline + (buffer-cache-workline-length d) (hi::line-length workline) + (buffer-cache-workline-start-font-index d) 0) + d)) + + +(defun adjust-buffer-cache-for-insertion (display pos n) + (if (buffer-cache-workline display) + (let* ((hi::*current-buffer* (buffer-cache-buffer display))) + (if (> (buffer-cache-workline-offset display) pos) + (incf (buffer-cache-workline-offset display) n) + (when (>= (+ (buffer-cache-workline-offset display) + (buffer-cache-workline-length display)) + pos) + (setf (buffer-cache-workline-length display) + (hi::line-length (buffer-cache-workline display))))) + (incf (buffer-cache-buflen display) n)) + (reset-buffer-cache display))) + + + + +;;; Update the cache so that it's describing the current absolute +;;; position. + +(defun update-line-cache-for-index (cache index) + (let* ((buffer (buffer-cache-buffer cache)) + (hi::*current-buffer* buffer) + (line (or + (buffer-cache-workline cache) + (progn + (reset-buffer-cache cache) + (buffer-cache-workline cache)))) + (pos (buffer-cache-workline-offset cache)) + (len (buffer-cache-workline-length cache)) + (moved nil)) + (loop + (when (and (>= index pos) + (< index (1+ (+ pos len)))) + (let* ((idx (- index pos))) + (when moved + (setf (buffer-cache-workline cache) line + (buffer-cache-workline-offset cache) pos + (buffer-cache-workline-length cache) len)) + (return (values line idx)))) + (setq moved t) + (if (< index pos) + (setq line (hi::line-previous line) + len (hi::line-length line) + pos (1- (- pos len))) + (setq line (hi::line-next line) + pos (1+ (+ pos len)) + len (hi::line-length line)))))) + +;;; Ask Hemlock to count the characters in the buffer. +(defun hemlock-buffer-length (buffer) + (let* ((hi::*current-buffer* buffer)) + (hemlock::count-characters (hemlock::buffer-region buffer)))) + +;;; Find the line containing (or immediately preceding) index, which is +;;; assumed to be less than the buffer's length. Return the character +;;; in that line or the trailing #\newline, as appropriate. +(defun hemlock-char-at-index (cache index) + (let* ((hi::*current-buffer* (buffer-cache-buffer cache))) + (multiple-value-bind (line idx) (update-line-cache-for-index cache index) + (let* ((len (hemlock::line-length line))) + (if (< idx len) + (hemlock::line-character line idx) + #\newline))))) + +;;; Given an absolute position, move the specified mark to the appropriate +;;; offset on the appropriate line. +(defun move-hemlock-mark-to-absolute-position (mark cache abspos) + (let* ((hi::*current-buffer* (buffer-cache-buffer cache))) + (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos) + #+debug + (#_NSLog #@"Moving point from current pos %d to absolute position %d" + :int (mark-absolute-position mark) + :int abspos) + (hemlock::move-to-position mark idx line) + #+debug + (#_NSLog #@"Moved mark to %d" :int (mark-absolute-position mark))))) + +;;; Return the absolute position of the mark in the containing buffer. +;;; This doesn't use the caching mechanism, so it's always linear in the +;;; number of preceding lines. +(defun mark-absolute-position (mark) + (let* ((hi::*current-buffer* (hi::line-%buffer (hi::mark-line mark))) + (pos (hi::mark-charpos mark))) + (+ (hi::get-line-origin (hi::mark-line mark)) pos))) + +;;; Return the length of the abstract string, i.e., the number of +;;; characters in the buffer (including implicit newlines.) +(objc:defmethod (#/length :nteger) ((self hemlock-buffer-string)) + (let* ((cache (hemlock-buffer-string-cache self))) + (or (buffer-cache-buflen cache) + (setf (buffer-cache-buflen cache) + (let* ((buffer (buffer-cache-buffer cache))) + (hemlock-buffer-length buffer)))))) + + + +;;; Return the character at the specified index (as a :unichar.) + +(objc:defmethod (#/characterAtIndex: :unichar) + ((self hemlock-buffer-string) (index :nteger)) + #+debug + (#_NSLog #@"Character at index: %d" :nteger index) + (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index))) + +(objc:defmethod (#/getCharacters:range: :void) + ((self hemlock-buffer-string) + (buffer (:* :unichar)) + (r :ange)) + (let* ((cache (hemlock-buffer-string-cache self)) + (index (ns:ns-range-location r)) + (length (ns:ns-range-length r)) + (hi::*current-buffer* (buffer-cache-buffer cache))) + #+debug + (#_NSLog #@"get characters: %d/%d" + :nteger index + :nteger length) + (multiple-value-bind (line idx) (update-line-cache-for-index cache index) + (let* ((len (hemlock::line-length line))) + (do* ((i 0 (1+ i))) + ((= i length)) + (cond ((< idx len) + (setf (paref buffer (:* :unichar) i) + (char-code (hemlock::line-character line idx))) + (incf idx)) + (t + (setf (paref buffer (:* :unichar) i) + (char-code #\Newline) + line (hi::line-next line) + len (if line (hi::line-length line) 0) + idx 0)))))))) + +(objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void) + ((self hemlock-buffer-string) + (startptr (:* :nteger)) + (endptr (:* :nteger)) + (contents-endptr (:* :nteger)) + (r :ange)) + (let* ((cache (hemlock-buffer-string-cache self)) + (index (pref r :ange.location)) + (length (pref r :ange.length)) + (hi::*current-buffer* (buffer-cache-buffer cache))) + #+debug + (#_NSLog #@"get line start: %d/%d" + :unsigned index + :unsigned length) + (update-line-cache-for-index cache index) + (unless (%null-ptr-p startptr) + ;; Index of the first character in the line which contains + ;; the start of the range. + (setf (pref startptr :nteger) + (buffer-cache-workline-offset cache))) + (unless (%null-ptr-p endptr) + ;; Index of the newline which terminates the line which + ;; contains the start of the range. + (setf (pref endptr :nteger) + (+ (buffer-cache-workline-offset cache) + (buffer-cache-workline-length cache)))) + (unless (%null-ptr-p contents-endptr) + ;; Index of the newline which terminates the line which + ;; contains the start of the range. + (unless (zerop length) + (update-line-cache-for-index cache (+ index length))) + (setf (pref contents-endptr :nteger) + (1+ (+ (buffer-cache-workline-offset cache) + (buffer-cache-workline-length cache))))))) + + + + + +;;; For debugging, mostly: make the printed representation of the string +;;; referenence the named Hemlock buffer. +(objc:defmethod #/description ((self hemlock-buffer-string)) + (let* ((cache (hemlock-buffer-string-cache self)) + (b (buffer-cache-buffer cache))) + (with-cstrs ((s (format nil "~a" b))) + (#/stringWithFormat: ns:ns-string #@"<%s for %s>" (#_object_getClassName self) s)))) + + + + +;;; hemlock-text-storage objects +(defclass hemlock-text-storage (ns:ns-text-storage) + ((string :foreign-type :id) + (hemlock-string :foreign-type :id) + (edit-count :foreign-type :int) + (mirror :foreign-type :id) + (styles :foreign-type :id) + (selection-set-by-search :foreign-type :)) + (:metaclass ns:+ns-object)) +(declaim (special hemlock-text-storage)) + + +;;; This is only here so that calls to it can be logged for debugging. +#+debug +(objc:defmethod (#/lineBreakBeforeIndex:withinRange: :nteger) + ((self hemlock-text-storage) + (index :nteger) + (r :ange)) + (#_NSLog #@"Line break before index: %d within range: %@" + :unsigned index + :id (#_NSStringFromRange r)) + (call-next-method index r)) + + + + +;;; Return true iff we're inside a "beginEditing/endEditing" pair +(objc:defmethod (#/editingInProgress :) ((self hemlock-text-storage)) + ;; This is meaningless outside the event thread, since you can't tell what + ;; other edit-count changes have already been queued up for execution on + ;; the event thread before it gets to whatever you might queue up next. + (assume-cocoa-thread) + (> (slot-value self 'edit-count) 0)) + +(defmethod assume-not-editing ((ts hemlock-text-storage)) + #+debug (assert (eql (slot-value ts 'edit-count) 0))) + +(defun textstorage-note-insertion-at-position (self pos n) + (ns:with-ns-range (r pos 0) + (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes r n) + (setf (ns:ns-range-length r) n) + (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r 0))) + + +;;; This runs on the main thread; it synchronizes the "real" NSMutableAttributedString +;;; with the hemlock string and informs the textstorage of the insertion. +(objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void) ((self hemlock-text-storage) + (pos :nteger) + (n :nteger) + (extra :nteger)) + (declare (ignorable extra)) + (assume-cocoa-thread) + (let* ((mirror (#/mirror self)) + (hemlock-string (#/hemlockString self)) + (display (hemlock-buffer-string-cache hemlock-string)) + (buffer (buffer-cache-buffer display)) + (hi::*current-buffer* buffer) + (font (buffer-active-font buffer)) + (document (#/document self)) + (undo-mgr (and document (#/undoManager document)))) + #+debug + (#_NSLog #@"insert: pos = %ld, n = %ld" :long pos :long n) + ;; We need to update the hemlock string mirror here so that #/substringWithRange: + ;; will work on the hemlock buffer string. + (adjust-buffer-cache-for-insertion display pos n) + (update-line-cache-for-index display pos) + (let* ((replacestring (#/substringWithRange: hemlock-string (ns:make-ns-range pos n)))) + (ns:with-ns-range (replacerange pos 0) + (#/replaceCharactersInRange:withString: + mirror replacerange replacestring)) + (when (and undo-mgr (not (#/isUndoing undo-mgr))) + (#/replaceCharactersAtPosition:length:withString: + (#/prepareWithInvocationTarget: undo-mgr self) + pos n #@""))) + (#/setAttributes:range: mirror font (ns:make-ns-range pos n)) + (textstorage-note-insertion-at-position self pos n))) + +(objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void) ((self hemlock-text-storage) + (pos :nteger) + (n :nteger) + (extra :nteger)) + (declare (ignorable extra)) + #+debug + (#_NSLog #@"delete: pos = %ld, n = %ld" :long pos :long n) + (ns:with-ns-range (range pos n) + (let* ((mirror (#/mirror self)) + (deleted-string (#/substringWithRange: (#/string mirror) range)) + (document (#/document self)) + (undo-mgr (and document (#/undoManager document))) + (display (hemlock-buffer-string-cache (#/hemlockString self)))) + ;; It seems to be necessary to call #/edited:range:changeInLength: before + ;; deleting from the mirror attributed string. It's not clear whether this + ;; is also true of insertions and modifications. + (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters + #$NSTextStorageEditedAttributes) + range (- n)) + (#/deleteCharactersInRange: mirror range) + (when (and undo-mgr (not (#/isUndoing undo-mgr))) + (#/replaceCharactersAtPosition:length:withString: + (#/prepareWithInvocationTarget: undo-mgr self) + pos 0 deleted-string)) + (reset-buffer-cache display) + (update-line-cache-for-index display pos)))) + +(objc:defmethod (#/noteHemlockModificationAtPosition:length: :void) ((self hemlock-text-storage) + (pos :nteger) + (n :nteger) + (extra :nteger)) + (declare (ignorable extra)) + #+debug + (#_NSLog #@"modify: pos = %ld, n = %ld" :long pos :long n) + (ns:with-ns-range (range pos n) + (let* ((hemlock-string (#/hemlockString self)) + (mirror (#/mirror self)) + (deleted-string (#/substringWithRange: (#/string mirror) range)) + (document (#/document self)) + (undo-mgr (and document (#/undoManager document)))) + (#/replaceCharactersInRange:withString: + mirror range (#/substringWithRange: hemlock-string range)) + (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters + #$NSTextStorageEditedAttributes) range 0) + (when (and undo-mgr (not (#/isUndoing undo-mgr))) + (#/replaceCharactersAtPosition:length:withString: + (#/prepareWithInvocationTarget: undo-mgr self) + pos n deleted-string))))) + +(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void) ((self hemlock-text-storage) + (pos :nteger) + (n :nteger) + (fontnum :nteger)) + (ns:with-ns-range (range pos n) + (#/setAttributes:range: (#/mirror self) (#/objectAtIndex: (#/styles self) fontnum) range) + (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0))) + +(defloadvar *buffer-change-invocation* + (with-autorelease-pool + (#/retain + (#/invocationWithMethodSignature: ns:ns-invocation + (#/instanceMethodSignatureForSelector: + hemlock-text-storage + (@selector #/noteHemlockInsertionAtPosition:length:)))))) + +(defstatic *buffer-change-invocation-lock* (make-lock)) + + + +(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage)) + (assume-cocoa-thread) + (with-slots (edit-count) self + #+debug + (#_NSLog #@"begin-editing") + (incf edit-count) + #+debug + (#_NSLog #@"after beginEditing on %@ edit-count now = %d" :id self :int edit-count) + (call-next-method))) + +(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage)) + (assume-cocoa-thread) + (with-slots (edit-count) self + #+debug + (#_NSLog #@"end-editing") + (call-next-method) + (assert (> edit-count 0)) + (decf edit-count) + #+debug + (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int edit-count))) + + + + + +;;; Access the string. It'd be nice if this was a generic function; +;;; we could have just made a reader method in the class definition. + + + +(objc:defmethod #/string ((self hemlock-text-storage)) + (slot-value self 'string)) + +(objc:defmethod #/mirror ((self hemlock-text-storage)) + (slot-value self 'mirror)) + +(objc:defmethod #/hemlockString ((self hemlock-text-storage)) + (slot-value self 'hemlock-string)) + +(objc:defmethod #/styles ((self hemlock-text-storage)) + (slot-value self 'styles)) + +(objc:defmethod #/document ((self hemlock-text-storage)) + (or + (let* ((string (#/hemlockString self))) + (unless (%null-ptr-p string) + (let* ((cache (hemlock-buffer-string-cache string))) + (when cache + (let* ((buffer (buffer-cache-buffer cache))) + (when buffer + (hi::buffer-document buffer))))))) + +null-ptr+)) + +(objc:defmethod #/initWithString: ((self hemlock-text-storage) s) + (setq s (%inc-ptr s 0)) + (let* ((newself (#/init self)) + (styles (make-editor-style-map)) + (mirror (#/retain (make-instance ns:ns-mutable-attributed-string + :with-string s + :attributes (#/objectAtIndex: styles 0))))) + (declare (type hemlock-text-storage newself)) + (setf (slot-value newself 'styles) styles) + (setf (slot-value newself 'hemlock-string) s) + (setf (slot-value newself 'mirror) mirror) + (setf (slot-value newself 'string) (#/retain (#/string mirror))) + newself)) + +;;; Should generally only be called after open/revert. +(objc:defmethod (#/updateMirror :void) ((self hemlock-text-storage)) + (with-slots (hemlock-string mirror styles) self + (#/replaceCharactersInRange:withString: mirror (ns:make-ns-range 0 (#/length mirror)) hemlock-string) + (#/setAttributes:range: mirror (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length mirror))))) + +;;; This is the only thing that's actually called to create a +;;; hemlock-text-storage object. (It also creates the underlying +;;; hemlock-buffer-string.) +(defun make-textstorage-for-hemlock-buffer (buffer) + (make-instance 'hemlock-text-storage + :with-string + (make-instance + 'hemlock-buffer-string + :cache + (reset-buffer-cache + (make-buffer-cache) + buffer)))) + +(objc:defmethod #/attributesAtIndex:effectiveRange: + ((self hemlock-text-storage) (index :nteger) (rangeptr (* :ange))) + #+debug + (#_NSLog #@"Attributes at index: %lu storage %@" :nteger index :id self) + (with-slots (mirror styles) self + (when (>= index (#/length mirror)) + (#_NSLog #@"Attributes at index: %lu edit-count: %d mirror: %@ layout: %@" :nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0)) + (for-each-textview-using-storage self + (lambda (tv) + (let* ((w (#/window tv)) + (proc (slot-value w 'command-thread))) + (process-interrupt proc #'ccl::dbg)))) + (ccl::dbg)) + (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr))) + (when (eql 0 (#/count attrs)) + (#_NSLog #@"No attributes ?") + (ns:with-ns-range (r) + (#/attributesAtIndex:longestEffectiveRange:inRange: + mirror index r (ns:make-ns-range 0 (#/length mirror))) + (setq attrs (#/objectAtIndex: styles 0)) + (#/setAttributes:range: mirror attrs r))) + attrs))) + +(objc:defmethod (#/replaceCharactersAtPosition:length:withString: :void) + ((self hemlock-text-storage) (pos nteger) (len nteger) string) + (let* ((document (#/document self)) + (undo-mgr (and document (#/undoManager document)))) + (when (and undo-mgr (not (#/isRedoing undo-mgr))) + (let ((replaced-string (#/substringWithRange: (#/hemlockString self) (ns:make-ns-range pos len)))) + (#/replaceCharactersAtPosition:length:withString: + (#/prepareWithInvocationTarget: undo-mgr self) + pos (#/length string) replaced-string))) + (ns:with-ns-range (r pos len) + (#/replaceCharactersInRange:withString: self r string)))) + +(objc:defmethod (#/replaceCharactersInRange:withString: :void) + ((self hemlock-text-storage) (r :ange) string) + #+debug (#_NSLog #@"Replace in range %ld/%ld with %@" + :nteger (pref r :ange.location) + :nteger (pref r :ange.length) + :id string) + (let* ((cache (hemlock-buffer-string-cache (#/hemlockString self))) + (buffer (if cache (buffer-cache-buffer cache))) + (hi::*current-buffer* buffer) + (location (pref r :ange.location)) + (length (pref r :ange.length)) + (point (hi::buffer-point buffer))) + (let* ((lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string))) + (document (if buffer (hi::buffer-document buffer))) + (textstorage (if document (slot-value document 'textstorage)))) + #+gz (unless (eql textstorage self) (break "why is self.ne.textstorage?")) + (when textstorage + (assume-cocoa-thread) + (#/beginEditing textstorage)) + (setf (hi::buffer-region-active buffer) nil) + (hi::with-mark ((start point :right-inserting)) + (move-hemlock-mark-to-absolute-position start cache location) + (unless (zerop length) + (hi::delete-characters start length)) + (when lisp-string + (hi::insert-string start lisp-string))) + (when textstorage + (#/endEditing textstorage) + (for-each-textview-using-storage + textstorage + (lambda (tv) + (hi::disable-self-insert + (hemlock-frame-event-queue (#/window tv))))) + (#/ensureSelectionVisible textstorage))))) + + +(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage) + attributes + (r :ange)) + #+debug + (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :ange.location) :int (pref r :ange.length)) + (with-slots (mirror) self + (#/setAttributes:range: mirror attributes r) + #+debug + (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: mirror (pref r :ange.location) +null-ptr+)))) + +(defun for-each-textview-using-storage (textstorage f) + (let* ((layouts (#/layoutManagers textstorage))) + (unless (%null-ptr-p layouts) + (dotimes (i (#/count layouts)) + (let* ((layout (#/objectAtIndex: layouts i)) + (containers (#/textContainers layout))) + (unless (%null-ptr-p containers) + (dotimes (j (#/count containers)) + (let* ((container (#/objectAtIndex: containers j)) + (tv (#/textView container))) + (funcall f tv))))))))) + +;;; Again, it's helpful to see the buffer name when debugging. +(objc:defmethod #/description ((self hemlock-text-storage)) + (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'hemlock-string))) + +;;; This needs to happen on the main thread. +(objc:defmethod (#/ensureSelectionVisible :void) ((self hemlock-text-storage)) + (assume-cocoa-thread) + (for-each-textview-using-storage + self + #'(lambda (tv) + (assume-not-editing tv) + (#/scrollRangeToVisible: tv (#/selectedRange tv))))) + + +(defun close-hemlock-textstorage (ts) + (declare (type hemlock-text-storage ts)) + (with-slots (styles) ts + (#/release styles) + (setq styles +null-ptr+)) + (let* ((hemlock-string (slot-value ts 'hemlock-string))) + (setf (slot-value ts 'hemlock-string) +null-ptr+) + + (unless (%null-ptr-p hemlock-string) + (let* ((cache (hemlock-buffer-string-cache hemlock-string)) + (buffer (if cache (buffer-cache-buffer cache)))) + (when buffer + (setf (buffer-cache-buffer cache) nil + (slot-value hemlock-string 'cache) nil + (hi::buffer-document buffer) nil) + (let* ((p (hi::buffer-process buffer))) + (when p + (setf (hi::buffer-process buffer) nil) + (process-kill p))) + (when (eq buffer hi::*current-buffer*) + (setf (hi::current-buffer) + (car (last hi::*buffer-list*)))) + (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer) + (hi::invoke-hook hemlock::delete-buffer-hook buffer) + (setq hi::*buffer-list* (delq buffer hi::*buffer-list*)) + (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*)))))) + + + +;;; Mostly experimental, so that we can see what happens when a +;;; real typesetter is used. +(defclass hemlock-ats-typesetter (ns:ns-ats-typesetter) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/layoutGlyphsInLayoutManager:startingAtGlyphIndex:maxNumberOfLineFragments:nextGlyphIndex: :void) + ((self hemlock-ats-typesetter) + layout-manager + (start-index :nteger) + (max-lines :nteger) + (next-index (:* :nteger))) + (#_NSLog #@"layoutGlyphs: start = %d, maxlines = %d" :int start-index :int max-lines) + (call-next-method layout-manager start-index max-lines next-index)) + + + +;;; An abstract superclass of the main and echo-area text views. +(defclass hemlock-textstorage-text-view (ns::ns-text-view) + ((blink-location :foreign-type :unsigned :accessor text-view-blink-location) + (blink-color-attribute :foreign-type :id :accessor text-view-blink-color) + (blink-enabled :foreign-type : :accessor text-view-blink-enabled) + (peer :foreign-type :id)) + (:metaclass ns:+ns-object)) +(declaim (special hemlock-textstorage-text-view)) + + +(defmethod assume-not-editing ((tv hemlock-textstorage-text-view)) + (assume-not-editing (#/textStorage tv))) + +(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view) + sender) + (declare (ignorable sender)) + #+debug (#_NSLog #@"Change color to = %@" :id (#/color sender))) + +(def-cocoa-default *layout-text-in-background* :bool t "When true, do text layout when idle.") + +(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void) + ((self hemlock-textstorage-text-view) layout cont (flag :)) + (declare (ignorable cont flag)) + #+debug (#_NSLog #@"layout complete: container = %@, atend = %d" :id cont :int (if flag 1 0)) + (unless *layout-text-in-background* + (#/setDelegate: layout +null-ptr+) + (#/setBackgroundLayoutEnabled: layout nil))) + +;;; Note changes to the textview's background color; record them +;;; as the value of the "temporary" foreground color (for blinking). +(objc:defmethod (#/setBackgroundColor: :void) + ((self hemlock-textstorage-text-view) color) + #+debug (#_NSLog #@"Set background color: %@" :id color) + (let* ((old (text-view-blink-color self))) + (unless (%null-ptr-p old) + (#/release old))) + (setf (text-view-blink-color self) (#/retain color)) + (call-next-method color)) + +;;; Maybe cause 1 character in the textview to blink (by drawing an empty +;;; character rectangle) in synch with the insertion point. + +(objc:defmethod (#/drawInsertionPointInRect:color:turnedOn: :void) + ((self hemlock-textstorage-text-view) + (r :ect) + color + (flag :)) + (unless (#/editingInProgress (#/textStorage self)) + (unless (eql #$NO (text-view-blink-enabled self)) + (let* ((layout (#/layoutManager self)) + (container (#/textContainer self)) + (blink-color (text-view-blink-color self))) + ;; We toggle the blinked character "off" by setting its + ;; foreground color to the textview's background color. + ;; The blinked character should be "off" whenever the insertion + ;; point is drawn as "on". (This means that when this method + ;; is invoked to tunr off the insertion point - as when a + ;; view loses keyboard focus - the matching paren character + ;; is drawn. + (ns:with-ns-range (char-range (text-view-blink-location self) 1) + (let* ((glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: + layout + char-range + +null-ptr+))) + #+debug (#_NSLog #@"Flag = %d, location = %d" : (if flag #$YES #$NO) :int (text-view-blink-location self)) + (let* ((rect (#/boundingRectForGlyphRange:inTextContainer: + layout + glyph-range + container))) + (#/set blink-color) + (#_NSRectFill rect)) + (unless flag + (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)))))))) + (call-next-method r color flag)) + + +(defmethod disable-blink ((self hemlock-textstorage-text-view)) + (when (eql (text-view-blink-enabled self) #$YES) + (setf (text-view-blink-enabled self) #$NO) + (ns:with-ns-range (char-range (text-view-blink-location self) 1) + (let* ((layout (#/layoutManager self)) + (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: + layout + char-range + +null-ptr+))) + (#/lockFocus self) + (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)) + (#/unlockFocus self))))) + + +(defmethod update-blink ((self hemlock-textstorage-text-view)) + (disable-blink self) + (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))) + (buffer (buffer-cache-buffer d))) + (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) + (let* ((hi::*current-buffer* buffer) + (point (hi::buffer-point buffer))) + #+debug (#_NSLog #@"Syntax check for blinking") + (update-buffer-package (hi::buffer-document buffer) buffer) + (cond ((eql (hi::next-character point) #\() + (hemlock::pre-command-parse-check point) + (when (hemlock::valid-spot point t) + (hi::with-mark ((temp point)) + (when (hemlock::list-offset temp 1) + #+debug (#_NSLog #@"enable blink, forward") + (setf (text-view-blink-location self) + (1- (mark-absolute-position temp)) + (text-view-blink-enabled self) #$YES))))) + ((eql (hi::previous-character point) #\)) + (hemlock::pre-command-parse-check point) + (when (hemlock::valid-spot point nil) + (hi::with-mark ((temp point)) + (when (hemlock::list-offset temp -1) + #+debug (#_NSLog #@"enable blink, backward") + (setf (text-view-blink-location self) + (mark-absolute-position temp) + (text-view-blink-enabled self) #$YES)))))))))) + +;;; Set and display the selection at pos, whose length is len and whose +;;; affinity is affinity. This should never be called from any Cocoa +;;; event handler; it should not call anything that'll try to set the +;;; underlying buffer's point and/or mark + +(objc:defmethod (#/updateSelection:length:affinity: :void) + ((self hemlock-textstorage-text-view) + (pos :int) + (length :int) + (affinity :electionffinity)) + (assume-cocoa-thread) + (when (eql length 0) + (update-blink self)) + (rlet ((range :ns-range :location pos :length length)) + (ccl::%call-next-objc-method self + hemlock-textstorage-text-view + (@selector #/setSelectedRange:affinity:stillSelecting:) + '(:void :ange :electionffinity :) + range + affinity + nil) + (assume-not-editing self) + (#/scrollRangeToVisible: self range) + (when (> length 0) + (let* ((ts (#/textStorage self))) + (with-slots (selection-set-by-search) ts + (when (prog1 (eql #$YES selection-set-by-search) + (setq selection-set-by-search #$NO)) + (highlight-search-selection self pos length))))) + )) + +(defloadvar *can-use-show-find-indicator-for-range* + (#/instancesRespondToSelector: ns:ns-text-view (@selector "showFindIndicatorForRange:"))) + +;;; Add transient highlighting to a selection established via a search +;;; primitive, if the OS supports it. +(defun highlight-search-selection (tv pos length) + (when *can-use-show-find-indicator-for-range* + (ns:with-ns-range (r pos length) + (objc-message-send tv "showFindIndicatorForRange:" :ange r :void)))) + +;;; A specialized NSTextView. The NSTextView is part of the "pane" +;;; object that displays buffers. +(defclass hemlock-text-view (hemlock-textstorage-text-view) + ((pane :foreign-type :id :accessor text-view-pane) + (char-width :foreign-type :loat :accessor text-view-char-width) + (char-height :foreign-type :loat :accessor text-view-char-height)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender) + (declare (ignore sender)) + (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) + (doc (#/documentForWindow: dc (#/window self))) + (buffer (hemlock-document-buffer doc)) + (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) + (pathname (hi::buffer-pathname buffer)) + (ranges (#/selectedRanges self)) + (text (#/string self))) + (dotimes (i (#/count ranges)) + (let* ((r (#/rangeValue (#/objectAtIndex: ranges i))) + (s (#/substringWithRange: text r))) + (setq s (lisp-string-from-nsstring s)) + (ui-object-eval-selection *NSApp* (list package-name pathname s)))))) + +(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender) + (declare (ignore sender)) + (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) + (doc (#/documentForWindow: dc (#/window self))) + (buffer (hemlock-document-buffer doc)) + (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) + (pathname (hi::buffer-pathname buffer))) + (ui-object-load-buffer *NSApp* (list package-name pathname)))) + +(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender) + (declare (ignore sender)) + (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) + (doc (#/documentForWindow: dc (#/window self))) + (buffer (hemlock-document-buffer doc)) + (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) + (pathname (hi::buffer-pathname buffer))) + (ui-object-compile-buffer *NSApp* (list package-name pathname)))) + +(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender) + (declare (ignore sender)) + (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) + (doc (#/documentForWindow: dc (#/window self))) + (buffer (hemlock-document-buffer doc)) + (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) + (pathname (hi::buffer-pathname buffer))) + (ui-object-compile-and-load-buffer *NSApp* (list package-name pathname)))) + +(defloadvar *text-view-context-menu* ()) + +(defun text-view-context-menu () + (or *text-view-context-menu* + (setq *text-view-context-menu* + (#/retain + (let* ((menu (make-instance 'ns:ns-menu :with-title #@"Menu"))) + (#/addItemWithTitle:action:keyEquivalent: + menu #@"Cut" (@selector #/cut:) #@"") + (#/addItemWithTitle:action:keyEquivalent: + menu #@"Copy" (@selector #/copy:) #@"") + (#/addItemWithTitle:action:keyEquivalent: + menu #@"Paste" (@selector #/paste:) #@"") + ;; Separator + (#/addItem: menu (#/separatorItem ns:ns-menu-item)) + (#/addItemWithTitle:action:keyEquivalent: + menu #@"Background Color ..." (@selector #/changeBackgroundColor:) #@"") + (#/addItemWithTitle:action:keyEquivalent: + menu #@"Text Color ..." (@selector #/changeTextColor:) #@"") + + menu))))) + + + + + +(objc:defmethod (#/changeBackgroundColor: :void) + ((self hemlock-text-view) sender) + (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel)) + (color (#/backgroundColor self))) + (#/close colorpanel) + (#/setAction: colorpanel (@selector #/updateBackgroundColor:)) + (#/setColor: colorpanel color) + (#/setTarget: colorpanel self) + (#/setContinuous: colorpanel nil) + (#/orderFrontColorPanel: *NSApp* sender))) + + + +(objc:defmethod (#/updateBackgroundColor: :void) + ((self hemlock-text-view) sender) + (when (#/isVisible sender) + (let* ((color (#/color sender))) + (unless (typep self 'echo-area-view) + (let* ((window (#/window self)) + (echo-view (unless (%null-ptr-p window) + (slot-value window 'echo-area-view)))) + (when echo-view (#/setBackgroundColor: echo-view color)))) + #+debug (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender) + (#/setBackgroundColor: self color)))) + +(objc:defmethod (#/changeTextColor: :void) + ((self hemlock-text-view) sender) + (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel)) + (textstorage (#/textStorage self)) + (color (#/objectForKey: + (#/objectAtIndex: (slot-value textstorage 'styles) 0) + #&NSForegroundColorAttributeName))) + (#/close colorpanel) + (#/setAction: colorpanel (@selector #/updateTextColor:)) + (#/setColor: colorpanel color) + (#/setTarget: colorpanel self) + (#/setContinuous: colorpanel nil) + (#/orderFrontColorPanel: *NSApp* sender))) + + + + + + + +(objc:defmethod (#/updateTextColor: :void) + ((self hemlock-textstorage-text-view) sender) + (unwind-protect + (progn + (#/setUsesFontPanel: self t) + (ccl::%call-next-objc-method + self + hemlock-textstorage-text-view + (@selector #/changeColor:) + '(:void :id) + sender)) + (#/setUsesFontPanel: self nil)) + (#/setNeedsDisplay: self t)) + +(objc:defmethod (#/updateTextColor: :void) + ((self hemlock-text-view) sender) + (let* ((textstorage (#/textStorage self)) + (styles (slot-value textstorage 'styles)) + (newcolor (#/color sender))) + (dotimes (i 4) + (let* ((dict (#/objectAtIndex: styles i))) + (#/setValue:forKey: dict newcolor #&NSForegroundColorAttributeName))) + (call-next-method sender))) + + + + +;;; Access the underlying buffer in one swell foop. +(defmethod text-view-buffer ((self hemlock-textstorage-text-view)) + (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))) + + + + +(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range) + ((self hemlock-textstorage-text-view) + (proposed :ns-range) + (g :electionranularity)) + #+debug + (#_NSLog #@"Granularity = %d" :int g) + (objc:returning-foreign-struct (r) + (block HANDLED + (let* ((index (ns:ns-range-location proposed)) + (length (ns:ns-range-length proposed))) + (when (and (eql 0 length) ; not extending existing selection + (not (eql g #$NSSelectByCharacter))) + (let* ((textstorage (#/textStorage self)) + (cache (hemlock-buffer-string-cache (#/hemlockString textstorage))) + (buffer (if cache (buffer-cache-buffer cache)))) + (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) + (let* ((hi::*current-buffer* buffer)) + (hi::with-mark ((m1 (hi::buffer-point buffer))) + (move-hemlock-mark-to-absolute-position m1 cache index) + (hemlock::pre-command-parse-check m1) + (when (hemlock::valid-spot m1 nil) + (cond ((eql (hi::next-character m1) #\() + (hi::with-mark ((m2 m1)) + (when (hemlock::list-offset m2 1) + (ns:init-ns-range r index (- (mark-absolute-position m2) index)) + (return-from HANDLED r)))) + ((eql (hi::previous-character m1) #\)) + (hi::with-mark ((m2 m1)) + (when (hemlock::list-offset m2 -1) + (ns:init-ns-range r (mark-absolute-position m2) (- index (mark-absolute-position m2))) + (return-from HANDLED r)))))))))))) + (call-next-method proposed g) + #+debug + (#_NSLog #@"range = %@, proposed = %@, granularity = %d" + :address (#_NSStringFromRange r) + :address (#_NSStringFromRange proposed) + :electionranularity g)))) + + + + + + +;;; Translate a keyDown NSEvent to a Hemlock key-event. +(defun nsevent-to-key-event (nsevent &optional quoted) + (let* ((modifiers (#/modifierFlags nsevent))) + (unless (logtest #$NSCommandKeyMask modifiers) + (let* ((chars (if quoted + (#/characters nsevent) + (#/charactersIgnoringModifiers nsevent))) + (n (if (%null-ptr-p chars) + 0 + (#/length chars))) + (c (if (eql n 1) + (#/characterAtIndex: chars 0)))) + (when c + (let* ((bits 0) + (useful-modifiers (logandc2 modifiers + (logior ;#$NSShiftKeyMask + #$NSAlphaShiftKeyMask)))) + (unless quoted + (dolist (map hemlock-ext::*modifier-translations*) + (when (logtest useful-modifiers (car map)) + (setq bits (logior bits (hemlock-ext::key-event-modifier-mask + (cdr map))))))) + (let* ((char (code-char c))) + (when (and char (standard-char-p char)) + (setq bits (logandc2 bits hi::+shift-event-mask+)))) + (hemlock-ext::make-key-event c bits))))))) + +(defun pass-key-down-event-to-hemlock (self event q) + #+debug + (#_NSLog #@"Key down event = %@" :address event) + (let* ((buffer (text-view-buffer self))) + (when buffer + (let* ((hemlock-event (nsevent-to-key-event event (hi::frame-event-queue-quoted-insert q )))) + (when hemlock-event + (hi::enqueue-key-event q hemlock-event)))))) + +(defun hi::enqueue-buffer-operation (buffer thunk) + (dolist (w (hi::buffer-windows buffer)) + (let* ((q (hemlock-frame-event-queue (#/window w))) + (op (hi::make-buffer-operation :thunk thunk))) + (hi::event-queue-insert q op)))) + + + +;;; Process a key-down NSEvent in a Hemlock text view by translating it +;;; into a Hemlock key event and passing it into the Hemlock command +;;; interpreter. + +(defun handle-key-down (self event) + (let* ((q (hemlock-frame-event-queue (#/window self)))) + (if (or (and (zerop (#/length (#/characters event))) + (hi::frame-event-queue-quoted-insert q)) + (#/hasMarkedText self)) + nil + (progn + (pass-key-down-event-to-hemlock self event q) + t)))) + + +(objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event) + (or (handle-key-down self event) + (call-next-method event))) + +(objc:defmethod (#/mouseDown: :void) ((self hemlock-text-view) event) + ;; If no modifier keys are pressed, send hemlock a no-op. + (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event)) + (let* ((q (hemlock-frame-event-queue (#/window self)))) + (hi::enqueue-key-event q #k"leftdown"))) + (call-next-method event)) + +;;; Update the underlying buffer's point (and "active region", if appropriate. +;;; This is called in response to a mouse click or other event; it shouldn't +;;; be called from the Hemlock side of things. + +(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void) + ((self hemlock-text-view) + (r :ange) + (affinity :electionffinity) + (still-selecting :)) + #+debug + (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d" + :int (pref r :ange.location) + :int (pref r :ange.length) + :electionffinity affinity + : (if still-selecting #$YES #$NO)) + #+debug + (#_NSLog #@"text view string = %@, textstorage string = %@" + :id (#/string self) + :id (#/string (#/textStorage self))) + (unless (#/editingInProgress (#/textStorage self)) + (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))) + (buffer (buffer-cache-buffer d)) + (hi::*current-buffer* buffer) + (point (hi::buffer-point buffer)) + (location (pref r :ange.location)) + (len (pref r :ange.length))) + (cond ((eql len 0) + #+debug + (#_NSLog #@"Moving point to absolute position %d" :int location) + (setf (hi::buffer-region-active buffer) nil) + (move-hemlock-mark-to-absolute-position point d location) + (update-blink self)) + (t + ;; We don't get much information about which end of the + ;; selection the mark's at and which end point is at, so + ;; we have to sort of guess. In every case I've ever seen, + ;; selection via the mouse generates a sequence of calls to + ;; this method whose parameters look like: + ;; a: range: {n0,0} still-selecting: false [ rarely repeats ] + ;; b: range: {n0,0) still-selecting: true [ rarely repeats ] + ;; c: range: {n1,m} still-selecting: true [ often repeats ] + ;; d: range: {n1,m} still-selecting: false [ rarely repeats ] + ;; + ;; (Sadly, "affinity" doesn't tell us anything interesting.) + ;; We've handled a and b in the clause above; after handling + ;; b, point references buffer position n0 and the + ;; region is inactive. + ;; Let's ignore c, and wait until the selection's stabilized. + ;; Make a new mark, a copy of point (position n0). + ;; At step d (here), we should have either + ;; d1) n1=n0. Mark stays at n0, point moves to n0+m. + ;; d2) n1+m=n0. Mark stays at n0, point moves to n0-m. + ;; If neither d1 nor d2 apply, arbitrarily assume forward + ;; selection: mark at n1, point at n1+m. + ;; In all cases, activate Hemlock selection. + (unless still-selecting + (let* ((pointpos (mark-absolute-position point)) + (selection-end (+ location len)) + (mark (hi::copy-mark point :right-inserting))) + (cond ((eql pointpos location) + (move-hemlock-mark-to-absolute-position point + d + selection-end)) + ((eql pointpos selection-end) + (move-hemlock-mark-to-absolute-position point + d + location)) + (t + (move-hemlock-mark-to-absolute-position mark + d + location) + (move-hemlock-mark-to-absolute-position point + d + selection-end))) + (hemlock::%buffer-push-buffer-mark buffer mark t))))))) + (call-next-method r affinity still-selecting)) + + + + +;;; Modeline-view + +;;; The modeline view is embedded in the horizontal scroll bar of the +;;; scrollview which surrounds the textview in a pane. (A view embedded +;;; in a scrollbar like this is sometimes called a "placard"). Whenever +;;; the view's invalidated, its drawRect: method draws a string containing +;;; the current values of the buffer's modeline fields. + +(defparameter *modeline-grays* #(255 255 253 247 242 236 231 + 224 229 234 239 245 252 255)) + +(defparameter *modeline-height* 14) +(defloadvar *modeline-pattern-image* nil) + +(defun create-modeline-pattern-image () + (let* ((n (length *modeline-grays*))) + (multiple-value-bind (samples-array samples-macptr) + (make-heap-ivector n '(unsigned-byte 8)) + (dotimes (i n) + (setf (aref samples-array i) (aref *modeline-grays* i))) + (rlet ((p :address samples-macptr)) + (let* ((rep (make-instance 'ns:ns-bitmap-image-rep + :with-bitmap-data-planes p + :pixels-wide 1 + :pixels-high n + :bits-per-sample 8 + :samples-per-pixel 1 + :has-alpha #$NO + :is-planar #$NO + :color-space-name #&NSDeviceWhiteColorSpace + :bytes-per-row 1 + :bits-per-pixel 8)) + (image (make-instance 'ns:ns-image + :with-size (ns:make-ns-size 1 n)))) + (#/addRepresentation: image rep) + (#/release rep) + (setf *modeline-pattern-image* image)))))) + +(defclass modeline-view (ns:ns-view) + ((pane :foreign-type :id :accessor modeline-view-pane) + (text-attributes :foreign-type :id :accessor modeline-text-attributes)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/initWithFrame: ((self modeline-view) (frame :ect)) + (call-next-method frame) + (unless *modeline-pattern-image* + (create-modeline-pattern-image)) + (let* ((size (#/smallSystemFontSize ns:ns-font)) + (font (#/systemFontOfSize: ns:ns-font size)) + (dict (#/dictionaryWithObject:forKey: ns:ns-dictionary font #&NSFontAttributeName))) + (setf (modeline-text-attributes self) (#/retain dict))) + self) + +;;; Find the underlying buffer. +(defun buffer-for-modeline-view (mv) + (let* ((pane (modeline-view-pane mv))) + (unless (%null-ptr-p pane) + (let* ((tv (text-pane-text-view pane))) + (unless (%null-ptr-p tv) + (text-view-buffer tv)))))) + +;;; Draw a string in the modeline view. The font and other attributes +;;; are initialized lazily; apparently, calling the Font Manager too +;;; early in the loading sequence confuses some Carbon libraries that're +;;; used in the event dispatch mechanism, +(defun draw-modeline-string (the-modeline-view) + (with-slots (pane text-attributes) the-modeline-view + (let* ((buffer (buffer-for-modeline-view the-modeline-view))) + (when buffer + (let* ((string + (apply #'concatenate 'string + (mapcar + #'(lambda (field) + (funcall (hi::modeline-field-function field) + buffer pane)) + (hi::buffer-modeline-fields buffer))))) + (#/drawAtPoint:withAttributes: (%make-nsstring string) + (ns:make-ns-point 5 1) + text-attributes)))))) + +;;; Draw the underlying buffer's modeline string on a white background +;;; with a bezeled border around it. +(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :ect)) + (declare (ignorable rect)) + (let* ((bounds (#/bounds self)) + (context (#/currentContext ns:ns-graphics-context))) + (#/saveGraphicsState context) + (ns:with-ns-point (p0 0 (ns:ns-rect-height bounds)) + (let ((p1 (#/convertPoint:toView: self p0 +null-ptr+))) + (#/setPatternPhase: context p1))) + (#/set (#/colorWithPatternImage: ns:ns-color *modeline-pattern-image*)) + (#_NSRectFill bounds) + (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.3333 1.0)) + (ns:with-ns-rect (r 0 0.5 (ns:ns-rect-width bounds) 0.5) + (#_NSRectFill r)) + (ns:with-ns-rect (r 0 (- (ns:ns-rect-height bounds) 0.5) + (ns:ns-rect-width bounds) (- (ns:ns-rect-height bounds) 0.5)) + (#_NSRectFill r)) + (#/set (#/blackColor ns:ns-color)) + (draw-modeline-string self) + (#/restoreGraphicsState context))) + +;;; Hook things up so that the modeline is updated whenever certain buffer +;;; attributes change. +(hi::%init-mode-redisplay) + + + +;;; Modeline-scroll-view + +;;; This is just an NSScrollView that draws a "placard" view (the modeline) +;;; in the horizontal scrollbar. The modeline's arbitrarily given the +;;; leftmost 75% of the available real estate. +(defclass modeline-scroll-view (ns:ns-scroll-view) + ((modeline :foreign-type :id :accessor scroll-view-modeline) + (pane :foreign-type :id :accessor scroll-view-pane)) + (:metaclass ns:+ns-object)) + +;;; Making an instance of a modeline scroll view instantiates the +;;; modeline view, as well. + +(objc:defmethod #/initWithFrame: ((self modeline-scroll-view) (frame :ect)) + (let* ((v (call-next-method frame))) + (when v + (let* ((modeline (make-instance 'modeline-view))) + (#/addSubview: v modeline) + (setf (scroll-view-modeline v) modeline))) + v)) + +;;; Scroll views use the "tile" method to lay out their subviews. +;;; After the next-method has done so, steal some room in the horizontal +;;; scroll bar and place the modeline view there. + +(objc:defmethod (#/tile :void) ((self modeline-scroll-view)) + (call-next-method) + (let* ((modeline (scroll-view-modeline self))) + (when (and (#/hasHorizontalScroller self) + (not (%null-ptr-p modeline))) + (let* ((hscroll (#/horizontalScroller self)) + (scrollbar-frame (#/frame hscroll)) + (modeline-frame (#/frame hscroll)) ; sic + (modeline-width (* (pref modeline-frame + :ect.size.width) + 0.75f0))) + (declare (type cgfloat modeline-width)) + (setf (pref modeline-frame :ect.size.width) + modeline-width + (the cgfloat + (pref scrollbar-frame :ect.size.width)) + (- (the cgfloat + (pref scrollbar-frame :ect.size.width)) + modeline-width) + (the cg-float + (pref scrollbar-frame :ect.origin.x)) + (+ (the cgfloat + (pref scrollbar-frame :ect.origin.x)) + modeline-width)) + (#/setFrame: hscroll scrollbar-frame) + (#/setFrame: modeline modeline-frame))))) + + + + + + +;;; Text-pane + +;;; The text pane is just an NSBox that (a) provides a draggable border +;;; around (b) encapsulates the text view and the mode line. + +(defclass text-pane (ns:ns-box) + ((text-view :foreign-type :id :accessor text-pane-text-view) + (mode-line :foreign-type :id :accessor text-pane-mode-line) + (scroll-view :foreign-type :id :accessor text-pane-scroll-view)) + (:metaclass ns:+ns-object)) + +;;; Mark the pane's modeline as needing display. This is called whenever +;;; "interesting" attributes of a buffer are changed. + +(defun hi::invalidate-modeline (pane) + (#/setNeedsDisplay: (text-pane-mode-line pane) t)) + +(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane") +(def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane") + + +(objc:defmethod #/initWithFrame: ((self text-pane) (frame :ect)) + (let* ((pane (call-next-method frame))) + (unless (%null-ptr-p pane) + (#/setAutoresizingMask: pane (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (#/setBoxType: pane #$NSBoxPrimary) + (#/setBorderType: pane #$NSNoBorder) + (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width* *text-pane-margin-height*)) + (#/setTitlePosition: pane #$NSNoTitle)) + pane)) + +(objc:defmethod #/defaultMenu ((class +hemlock-text-view)) + (text-view-context-menu)) + +;;; If we don't override this, NSTextView will start adding Google/ +;;; Spotlight search options and dictionary lookup when a selection +;;; is active. +(objc:defmethod #/menuForEvent: ((self hemlock-text-view) event) + (declare (ignore event)) + (#/menu self)) + +(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color style) + (let* ((scrollview (#/autorelease + (make-instance + 'modeline-scroll-view + :with-frame (ns:make-ns-rect x y width height))))) + (#/setBorderType: scrollview #$NSNoBorder) + (#/setHasVerticalScroller: scrollview t) + (#/setHasHorizontalScroller: scrollview t) + (#/setRulersVisible: scrollview nil) + (#/setAutoresizingMask: scrollview (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (#/setAutoresizesSubviews: (#/contentView scrollview) t) + (let* ((layout (make-instance 'ns:ns-layout-manager))) + #+suffer + (#/setTypesetter: layout (make-instance 'hemlock-ats-typesetter)) + (#/addLayoutManager: textstorage layout) + (#/setUsesScreenFonts: layout *use-screen-fonts*) + (#/release layout) + (let* ((contentsize (#/contentSize scrollview))) + (ns:with-ns-size (containersize large-number-for-text large-number-for-text) + (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) + (ns:init-ns-size containersize large-number-for-text large-number-for-text) + (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) + (let* ((container (#/autorelease (make-instance + 'ns:ns-text-container + :with-container-size containersize)))) + (#/addTextContainer: layout container) + (let* ((tv (#/autorelease (make-instance 'hemlock-text-view + :with-frame tv-frame + :text-container container)))) + (#/setDelegate: layout tv) + (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize))) + (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text)) + (#/setRichText: tv nil) + (#/setAutoresizingMask: tv #$NSViewWidthSizable) + (#/setBackgroundColor: tv color) + (#/setTypingAttributes: tv (#/objectAtIndex: (#/styles textstorage) style)) + (#/setSmartInsertDeleteEnabled: tv nil) + (#/setAllowsUndo: tv nil) ; don't want NSTextView undo + (#/setUsesFindPanel: tv t) + (#/setUsesFontPanel: tv nil) + (#/setMenu: tv (text-view-context-menu)) + + ;; The container tracking and the text view sizability along a + ;; particular axis must always be different, or else things can + ;; get really confused (possibly causing an infinite loop). + + (if (or tracks-width *wrap-lines-to-window*) + (progn + (#/setWidthTracksTextView: container t) + (#/setHeightTracksTextView: container nil) + (#/setHorizontallyResizable: tv nil) + (#/setVerticallyResizable: tv t)) + (progn + (#/setWidthTracksTextView: container nil) + (#/setHeightTracksTextView: container nil) + (#/setHorizontallyResizable: tv t) + (#/setVerticallyResizable: tv t))) + + (#/setDocumentView: scrollview tv) + (values tv scrollview))))))))) + +(defun make-scrolling-textview-for-pane (pane textstorage track-width color style) + (let* ((contentrect (#/frame (#/contentView pane)))) + (multiple-value-bind (tv scrollview) + (make-scrolling-text-view-for-textstorage + textstorage + (ns:ns-rect-x contentrect) + (ns:ns-rect-y contentrect) + (ns:ns-rect-width contentrect) + (ns:ns-rect-height contentrect) + track-width + color + style) + (#/setContentView: pane scrollview) + (setf (slot-value pane 'scroll-view) scrollview + (slot-value pane 'text-view) tv + (slot-value tv 'pane) pane + (slot-value scrollview 'pane) pane) + (let* ((modeline (scroll-view-modeline scrollview))) + (setf (slot-value pane 'mode-line) modeline + (slot-value modeline 'pane) pane)) + tv))) + + +(objc:defmethod (#/activateHemlockView :void) ((self text-pane)) + (let* ((the-hemlock-frame (#/window self)) + (text-view (text-pane-text-view self))) + #+debug (#_NSLog #@"Activating text pane") + (with-slots ((echo peer)) text-view + (deactivate-hemlock-view echo)) + (#/setEditable: text-view t) + (#/makeFirstResponder: the-hemlock-frame text-view))) + +(defmethod hi::activate-hemlock-view ((view text-pane)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + view + (@selector #/activateHemlockView) + +null-ptr+ + t)) + + + +(defmethod deactivate-hemlock-view ((self hemlock-text-view)) + #+debug (#_NSLog #@"deactivating text view") + (#/setSelectable: self nil)) + +(defclass echo-area-view (hemlock-textstorage-text-view) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/activateHemlockView :void) ((self echo-area-view)) + (assume-cocoa-thread) + (let* ((the-hemlock-frame (#/window self))) + #+debug + (#_NSLog #@"Activating echo area") + (with-slots ((pane peer)) self + (deactivate-hemlock-view pane)) + (#/setEditable: self t) + (#/makeFirstResponder: the-hemlock-frame self))) + +(defmethod hi::activate-hemlock-view ((view echo-area-view)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + view + (@selector #/activateHemlockView) + +null-ptr+ + t)) + +(defmethod deactivate-hemlock-view ((self echo-area-view)) + (assume-cocoa-thread) + #+debug (#_NSLog #@"deactivating echo area") + (let* ((ts (#/textStorage self))) + #+debug 0 + (when (#/editingInProgress ts) + (#_NSLog #@"deactivating %@, edit-count = %d" :id self :int (slot-value ts 'edit-count))) + (do* () + ((not (#/editingInProgress ts))) + (#/endEditing ts)) + + (#/setSelectable: self nil))) + + +;;; The "document" for an echo-area isn't a real NSDocument. +(defclass echo-area-document (ns:ns-object) + ((textstorage :foreign-type :id)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/undoManager :) ((self echo-area-document)) + nil) ;For now, undo is not supported for echo-areas + +(defmethod update-buffer-package ((doc echo-area-document) buffer) + (declare (ignore buffer))) + +(objc:defmethod (#/close :void) ((self echo-area-document)) + (let* ((ts (slot-value self 'textstorage))) + (unless (%null-ptr-p ts) + (setf (slot-value self 'textstorage) (%null-ptr)) + (close-hemlock-textstorage ts)))) + +(objc:defmethod (#/updateChangeCount: :void) + ((self echo-area-document) + (change :ocumenthangeype)) + (declare (ignore change))) + +(objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document))) + +(objc:defmethod (#/keyDown: :void) ((self echo-area-view) event) + (or (handle-key-down self event) + (call-next-method event))) + + +(defloadvar *hemlock-frame-count* 0) + +(defun make-echo-area (the-hemlock-frame x y width height main-buffer color) + (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height)))) + (#/setAutoresizingMask: box #$NSViewWidthSizable) + (let* ((box-frame (#/bounds box)) + (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame))) + (clipview (make-instance 'ns:ns-clip-view + :with-frame box-frame))) + (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable + #$NSViewHeightSizable)) + (#/setBackgroundColor: clipview color) + (#/addSubview: box clipview) + (#/setAutoresizesSubviews: box t) + (#/release clipview) + (let* ((buffer (hi:make-buffer (format nil "Echo Area ~d" + (prog1 + *hemlock-frame-count* + (incf *hemlock-frame-count*))) + :modes '("Echo Area"))) + (textstorage + (progn + ;; What's the reason for sharing this? Is it just the lock? + (setf (hi::buffer-gap-context buffer) (hi::buffer-gap-context main-buffer)) + (make-textstorage-for-hemlock-buffer buffer))) + (doc (make-instance 'echo-area-document)) + (layout (make-instance 'ns:ns-layout-manager)) + (container (#/autorelease + (make-instance 'ns:ns-text-container + :with-container-size + containersize)))) + (#/addLayoutManager: textstorage layout) + (#/setUsesScreenFonts: layout *use-screen-fonts*) + (#/addTextContainer: layout container) + (#/release layout) + (let* ((echo (make-instance 'echo-area-view + :with-frame box-frame + :text-container container))) + (#/setMinSize: echo (pref box-frame :ect.size)) + (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text)) + (#/setRichText: echo nil) + (#/setUsesFontPanel: echo nil) + (#/setHorizontallyResizable: echo t) + (#/setVerticallyResizable: echo nil) + (#/setAutoresizingMask: echo #$NSViewNotSizable) + (#/setBackgroundColor: echo color) + (#/setWidthTracksTextView: container nil) + (#/setHeightTracksTextView: container nil) + (#/setMenu: echo +null-ptr+) + (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer + (slot-value doc 'textstorage) textstorage + (hi::buffer-document buffer) doc) + (#/setDocumentView: clipview echo) + (#/setAutoresizesSubviews: clipview nil) + (#/sizeToFit echo) + (values echo box)))))) + +(defun make-echo-area-for-window (w main-buffer color) + (let* ((content-view (#/contentView w)) + (bounds (#/bounds content-view))) + (multiple-value-bind (echo-area box) + (make-echo-area w + 0.0f0 + 0.0f0 + (- (ns:ns-rect-width bounds) 16.0f0) + 20.0f0 + main-buffer + color) + (#/addSubview: content-view box) + echo-area))) + +(defclass hemlock-frame (ns:ns-window) + ((echo-area-view :foreign-type :id) + (pane :foreign-type :id) + (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue)) + :reader hemlock-frame-event-queue) + (command-thread :initform nil) + (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer) + (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream)) + (:metaclass ns:+ns-object)) +(declaim (special hemlock-frame)) + +(defun double-%-in (string) + ;; Replace any % characters in string with %%, to keep them from + ;; being treated as printf directives. + (let* ((%pos (position #\% string))) + (if %pos + (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos)))) + string))) + +(defun nsstring-for-lisp-condition (cond) + (%make-nsstring (double-%-in (princ-to-string cond)))) + +(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) info) + (let* ((message (#/objectAtIndex: info 0)) + (signal (#/objectAtIndex: info 1))) + #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal) + (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title + (if (logbitp 0 (random 2)) + #@"Not OK, but what can you do?" + #@"The sky is falling. FRED never did this!") + +null-ptr+ + +null-ptr+ + self + self + (@selector #/sheetDidEnd:returnCode:contextInfo:) + (@selector #/sheetDidDismiss:returnCode:contextInfo:) + signal + message))) + +(objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame)) + (declare (ignore sheet code info)) + #+debug + (#_NSLog #@"Sheet did end")) + +(objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void) + ((self hemlock-frame) sheet code info) + (declare (ignore sheet code)) + #+debug (#_NSLog #@"dismiss sheet: semaphore = %lx" :unsigned-doubleword (#/unsignedLongValue info)) + (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info)))) + +(defun report-condition-in-hemlock-frame (condition frame) + (let* ((semaphore (make-semaphore)) + (message (nsstring-for-lisp-condition condition)) + (sem-value (make-instance 'ns:ns-number + :with-unsigned-long (%ptr-to-int (ccl::semaphore.value semaphore))))) + #+debug + (#_NSLog #@"created semaphore with value %lx" :address (semaphore.value semaphore)) + (rlet ((paramptrs (:array :id 2))) + (setf (paref paramptrs (:array :id) 0) message + (paref paramptrs (:array :id) 1) sem-value) + (let* ((params (make-instance 'ns:ns-array + :with-objects paramptrs + :count 2)) + #|(*debug-io* *typeout-stream*)|#) + (stream-clear-output *debug-io*) + (ignore-errors (print-call-history :detailed-p t)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + frame (@selector #/runErrorSheet:) params t) + (wait-on-semaphore semaphore))))) + +(defun hi::report-hemlock-error (condition) + (let ((pane (hi::current-window))) + (when (and pane (not (%null-ptr-p pane))) + (report-condition-in-hemlock-frame condition (#/window pane))))) + + +(defun hemlock-thread-function (q buffer pane echo-buffer echo-window) + (let* ((hi::*real-editor-input* q) + (hi::*editor-input* q) + (hi::*current-buffer* hi::*current-buffer*) + (hi::*current-window* pane) + (hi::*echo-area-window* echo-window) + (hi::*echo-area-buffer* echo-buffer) + (region (hi::buffer-region echo-buffer)) + (hi::*echo-area-region* region) + (hi::*echo-area-stream* (hi::make-hemlock-output-stream + (hi::region-end region) :full)) + (hi::*parse-starting-mark* + (hi::copy-mark (hi::buffer-point hi::*echo-area-buffer*) + :right-inserting)) + (hi::*parse-input-region* + (hi::region hi::*parse-starting-mark* + (hi::region-end region))) + (hi::*cache-modification-tick* -1) + (hi::*disembodied-buffer-counter* 0) + (hi::*in-a-recursive-edit* nil) + (hi::*last-key-event-typed* nil) + (hi::*input-transcript* nil) + (hemlock::*target-column* 0) + (hemlock::*last-comment-start* " ") + (hi::*translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t)) + (hi::*current-command* (make-array 10 :fill-pointer 0 :adjustable t)) + (hi::*current-translation* (make-array 10 :fill-pointer 0 :adjustable t)) + (hi::*prompt-key* (make-array 10 :adjustable t :fill-pointer 0)) + (hi::*command-key-event-buffer* buffer)) + + (setf (hi::current-buffer) buffer) + (unwind-protect + (loop + (catch 'hi::editor-top-level-catcher + (handler-bind ((error #'(lambda (condition) + (hi::lisp-error-error-handler condition + :internal)))) + (hi::invoke-hook hemlock::abort-hook) + (hi::%command-loop)))) + (hi::invoke-hook hemlock::exit-hook)))) + + +(objc:defmethod (#/close :void) ((self hemlock-frame)) + (let* ((content-view (#/contentView self)) + (subviews (#/subviews content-view))) + (do* ((i (1- (#/count subviews)) (1- i))) + ((< i 0)) + (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i)))) + (let* ((proc (slot-value self 'command-thread))) + (when proc + (setf (slot-value self 'command-thread) nil) + (process-kill proc))) + (let* ((buf (hemlock-frame-echo-area-buffer self)) + (echo-doc (if buf (hi::buffer-document buf)))) + (when echo-doc + (setf (hemlock-frame-echo-area-buffer self) nil) + (#/close echo-doc))) + (release-canonical-nsobject self) + (call-next-method)) + +(defun new-hemlock-document-window (class) + (let* ((w (new-cocoa-window :class class + :activate nil))) + (values w (add-pane-to-window w :reserve-below 20.0)))) + + + +(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0)) + (let* ((window-content-view (#/contentView w)) + (window-frame (#/frame window-content-view))) + (ns:with-ns-rect (pane-rect 0 reserve-below (ns:ns-rect-width window-frame) (- (ns:ns-rect-height window-frame) (+ reserve-above reserve-below))) + (let* ((pane (make-instance 'text-pane :with-frame pane-rect))) + (#/addSubview: window-content-view pane) + pane)))) + +(defun textpane-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) + (let* ((pane (nth-value + 1 + (new-hemlock-document-window class)))) + (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color style) + (multiple-value-bind (height width) + (size-of-char-in-font (default-font)) + (size-text-pane pane height width nrows ncols)) + pane)) + + + + +(defun hemlock-buffer-from-nsstring (nsstring name &rest modes) + (let* ((buffer (make-hemlock-buffer name :modes modes))) + (nsstring-to-buffer nsstring buffer))) + +(defun %nsstring-to-mark (nsstring mark) + "returns line-termination of string" + (let* ((string (lisp-string-from-nsstring nsstring)) + (lfpos (position #\linefeed string)) + (crpos (position #\return string)) + (line-termination (if crpos + (if (eql lfpos (1+ crpos)) + :cp/m + :macos) + :unix))) + (hi::insert-string mark + (case line-termination + (:cp/m (remove #\return string)) + (:macos (nsubstitute #\linefeed #\return string)) + (t string))) + line-termination)) + +(defun nsstring-to-buffer (nsstring buffer) + (let* ((document (hi::buffer-document buffer)) + (hi::*current-buffer* buffer) + (region (hi::buffer-region buffer))) + (setf (hi::buffer-document buffer) nil) + (unwind-protect + (progn + (hi::delete-region region) + (hi::modifying-buffer buffer + (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting)) + (setf (hi::buffer-line-termination buffer) + (%nsstring-to-mark nsstring mark))) + (setf (hi::buffer-modified buffer) nil) + (hi::buffer-start (hi::buffer-point buffer)) + (hi::renumber-region region) + buffer)) + (setf (hi::buffer-document buffer) document)))) + + + +(setq hi::*beep-function* #'(lambda (stream) + (declare (ignore stream)) + (#_NSBeep))) + + +;;; This function must run in the main event thread. +(defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) + (assume-cocoa-thread) + (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style)) + (frame (#/window pane)) + (buffer (text-view-buffer (text-pane-text-view pane))) + (echo-area (make-echo-area-for-window frame buffer color)) + (tv (text-pane-text-view pane))) + (with-slots (peer) tv + (setq peer echo-area)) + (with-slots (peer) echo-area + (setq peer tv)) + (hi::activate-hemlock-view pane) + (setf (slot-value frame 'echo-area-view) echo-area + (slot-value frame 'pane) pane) + (setf (slot-value frame 'command-thread) + (process-run-function (format nil "Hemlock window thread for ~s" + (hi::buffer-name buffer)) + #'(lambda () + (hemlock-thread-function + (hemlock-frame-event-queue frame) + buffer + pane + (hemlock-frame-echo-area-buffer frame) + (slot-value frame 'echo-area-view))))) + frame)) + + + + +(defun hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) + (process-interrupt *cocoa-event-process* + #'%hemlock-frame-for-textstorage + class ts ncols nrows container-tracks-text-view-width color style)) + + + +(defun hi::lock-buffer (b) + (grab-lock (hi::buffer-lock b))) + +(defun hi::unlock-buffer (b) + (release-lock (hi::buffer-lock b))) + +(defun hi::document-begin-editing (document) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (slot-value document 'textstorage) + (@selector #/beginEditing) + +null-ptr+ + t)) + +(defun document-edit-level (document) + (assume-cocoa-thread) ;; see comment in #/editingInProgress + (slot-value (slot-value document 'textstorage) 'edit-count)) + +(defun hi::document-end-editing (document) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (slot-value document 'textstorage) + (@selector #/endEditing) + +null-ptr+ + t)) + +(defun hi::document-set-point-position (document) + (declare (ignorable document)) + #+debug + (#_NSLog #@"Document set point position called") + (let* ((textstorage (slot-value document 'textstorage))) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + textstorage (@selector #/updateHemlockSelection) +null-ptr+ t))) + + + +(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0)) + (with-lock-grabbed (*buffer-change-invocation-lock*) + (let* ((invocation *buffer-change-invocation*)) + (rlet ((ppos :nteger pos) + (pn :nteger n) + (pextra :nteger extra)) + (#/setTarget: invocation textstorage) + (#/setSelector: invocation selector) + (#/setArgument:atIndex: invocation ppos 2) + (#/setArgument:atIndex: invocation pn 3) + (#/setArgument:atIndex: invocation pextra 4)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + invocation + (@selector #/invoke) + +null-ptr+ + t)))) + +(defun textstorage-note-insertion-at-position (textstorage pos n) + #+debug + (#_NSLog #@"insertion at position %d, len %d" :int pos :int n) + (#/edited:range:changeInLength: + textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range pos 0) n) + (#/edited:range:changeInLength: + textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) 0)) + + +(defun hi::buffer-note-font-change (buffer region font) + (when (hi::bufferp buffer) + (let* ((document (hi::buffer-document buffer)) + (textstorage (if document (slot-value document 'textstorage))) + (pos (mark-absolute-position (hi::region-start region))) + (n (- (mark-absolute-position (hi::region-end region)) pos))) + (perform-edit-change-notification textstorage + (@selector #/noteHemlockAttrChangeAtPosition:length:) + pos + n + font)))) + +(defun buffer-active-font (buffer) + (let* ((style 0) + (region (hi::buffer-active-font-region buffer)) + (textstorage (slot-value (hi::buffer-document buffer) 'textstorage)) + (styles (#/styles textstorage))) + (when region + (let* ((start (hi::region-end region))) + (setq style (hi::font-mark-font start)))) + (#/objectAtIndex: styles style))) + +;; Note that inserted a string of length n at mark. Assumes this is called after +;; buffer marks were updated. +(defun hi::buffer-note-insertion (buffer mark n) + (when (hi::bufferp buffer) + (let* ((document (hi::buffer-document buffer)) + (textstorage (if document (slot-value document 'textstorage)))) + (when textstorage + (let* ((pos (mark-absolute-position mark))) + (when (eq (hi::mark-%kind mark) :left-inserting) + ;; Make up for the fact that the mark moved forward with the insertion. + ;; For :right-inserting and :temporary marks, they should be left back. + (decf pos n)) + (perform-edit-change-notification textstorage + (@selector #/noteHemlockInsertionAtPosition:length:) + pos + n)))))) + +(defun hi::buffer-note-modification (buffer mark n) + (when (hi::bufferp buffer) + (let* ((document (hi::buffer-document buffer)) + (textstorage (if document (slot-value document 'textstorage)))) + (when textstorage + (perform-edit-change-notification textstorage + (@selector #/noteHemlockModificationAtPosition:length:) + (mark-absolute-position mark) + n))))) + + +(defun hi::buffer-note-deletion (buffer mark n) + (when (hi::bufferp buffer) + (let* ((document (hi::buffer-document buffer)) + (textstorage (if document (slot-value document 'textstorage)))) + (when textstorage + (let* ((pos (mark-absolute-position mark))) + (perform-edit-change-notification textstorage + (@selector #/noteHemlockDeletionAtPosition:length:) + pos + (abs n))))))) + + + +(defun hi::set-document-modified (document flag) + (unless flag + (#/performSelectorOnMainThread:withObject:waitUntilDone: + document + (@selector #/documentChangeCleared) + +null-ptr+ + t))) + + +(defmethod hi::document-panes ((document t)) + ) + + + + + +(defun size-of-char-in-font (f) + (let* ((sf (#/screenFont f)) + (screen-p *use-screen-fonts*)) + (if (%null-ptr-p sf) (setq sf f screen-p nil)) + (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager))))) + (#/setUsesScreenFonts: layout screen-p) + (values (fround (#/defaultLineHeightForFont: layout sf)) + (fround (ns:ns-size-width (#/advancementForGlyph: sf (#/glyphWithName: sf #@" ")))))))) + + + +(defun size-text-pane (pane char-height char-width nrows ncols) + (let* ((tv (text-pane-text-view pane)) + (height (fceiling (* nrows char-height))) + (width (fceiling (* ncols char-width))) + (scrollview (text-pane-scroll-view pane)) + (window (#/window scrollview)) + (has-horizontal-scroller (#/hasHorizontalScroller scrollview)) + (has-vertical-scroller (#/hasVerticalScroller scrollview))) + (ns:with-ns-size (tv-size + (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv)))) + height) + (when has-vertical-scroller + (#/setVerticalLineScroll: scrollview char-height) + (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|char-height|#)) + (when has-horizontal-scroller + (#/setHorizontalLineScroll: scrollview char-width) + (#/setHorizontalPageScroll: scrollview (cgfloat 0.0) #|char-width|#)) + (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview))) + (pane-frame (#/frame pane)) + (margins (#/contentViewMargins pane))) + (incf (ns:ns-size-height sv-size) + (+ (ns:ns-rect-y pane-frame) + (* 2 (ns:ns-size-height margins)))) + (incf (ns:ns-size-width sv-size) + (ns:ns-size-width margins)) + (#/setContentSize: window sv-size) + (setf (slot-value tv 'char-width) char-width + (slot-value tv 'char-height) char-height) + (#/setResizeIncrements: window + (ns:make-ns-size char-width char-height)))))) + + +(defclass hemlock-editor-window-controller (ns:ns-window-controller) + () + (:metaclass ns:+ns-object)) + + +;;; Map *default-file-character-encoding* to an :tringncoding +(defun get-default-encoding () + (let* ((string (string (or *default-file-character-encoding* + "ISO-8859-1"))) + (len (length string))) + (with-cstrs ((cstr string)) + (with-nsstr (nsstr cstr len) + (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr))) + (if (= cf #$kCFStringEncodingInvalidId) + (setq cf (#_CFStringGetSystemEncoding))) + (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf))) + (if (= ns #$kCFStringEncodingInvalidId) + (#/defaultCStringEncoding ns:ns-string) + ns))))))) + +(defclass hemlock-document-controller (ns:ns-document-controller) + ((last-encoding :foreign-type :tringncoding)) + (:metaclass ns:+ns-object)) +(declaim (special hemlock-document-controller)) + +(objc:defmethod #/init ((self hemlock-document-controller)) + (prog1 + (call-next-method) + (setf (slot-value self 'last-encoding) 0))) + + +;;; The HemlockEditorDocument class. + + +(defclass hemlock-editor-document (ns:ns-document) + ((textstorage :foreign-type :id) + (encoding :foreign-type :tringncoding :initform (get-default-encoding))) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/documentChangeCleared :void) ((self hemlock-editor-document)) + (#/updateChangeCount: self #$NSChangeCleared)) + +(defmethod assume-not-editing ((doc hemlock-editor-document)) + (assume-not-editing (slot-value doc 'textstorage))) + +(defmethod update-buffer-package ((doc hemlock-editor-document) buffer) + (let* ((name (hemlock::package-at-mark (hi::buffer-point buffer)))) + (when name + (let* ((pkg (find-package name))) + (if pkg + (setq name (shortest-package-name pkg)))) + (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer))) + (if (or (null curname) + (not (string= curname name))) + (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name)))))) + +(defun hi::document-note-selection-set-by-search (doc) + (with-slots (textstorage) doc + (when textstorage + (with-slots (selection-set-by-search) textstorage + (setq selection-set-by-search #$YES))))) + +(objc:defmethod (#/validateMenuItem: :) + ((self hemlock-text-view) item) + (let* ((action (#/action item))) + #+debug (#_NSLog #@"action = %s" :address action) + (cond ((eql action (@selector #/hyperSpecLookUp:)) + ;; For now, demand a selection. + (and *hyperspec-lookup-enabled* + (hyperspec-root-url) + (not (eql 0 (ns:ns-range-length (#/selectedRange self)))))) + ((eql action (@selector #/cut:)) + (let* ((selection (#/selectedRange self))) + (and (> (ns:ns-range-length selection)) + (#/shouldChangeTextInRange:replacementString: self selection #@"")))) + ((eql action (@selector #/evalSelection:)) + (not (eql 0 (ns:ns-range-length (#/selectedRange self))))) + ;; if this hemlock-text-view is in an editor windowm and its buffer has + ;; an associated pathname, then activate the Load Buffer item + ((or (eql action (@selector #/loadBuffer:)) + (eql action (@selector #/compileBuffer:)) + (eql action (@selector #/compileAndLoadBuffer:))) + (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))) + (buffer (buffer-cache-buffer d)) + (pathname (hi::buffer-pathname buffer))) + (not (null pathname)))) + (t (call-next-method item))))) + +(defmethod user-input-style ((doc hemlock-editor-document)) + 0) + +(defvar *encoding-name-hash* (make-hash-table)) + +(defmethod hi::document-encoding-name ((doc hemlock-editor-document)) + (with-slots (encoding) doc + (if (eql encoding 0) + "Automatic" + (or (gethash encoding *encoding-name-hash*) + (setf (gethash encoding *encoding-name-hash*) + (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding))))))) + + +(defmethod textview-background-color ((doc hemlock-editor-document)) + *editor-background-color*) + + +(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts) + (let* ((doc (%inc-ptr self 0)) ; workaround for stack-consed self + (string (#/hemlockString ts)) + (cache (hemlock-buffer-string-cache string)) + (buffer (buffer-cache-buffer cache))) + (unless (%null-ptr-p doc) + (setf (slot-value doc 'textstorage) ts + (hi::buffer-document buffer) doc)))) + +;; This runs on the main thread. +(objc:defmethod (#/revertToSavedFromFile:ofType: :) + ((self hemlock-editor-document) filename filetype) + (declare (ignore filetype)) + (assume-cocoa-thread) + #+debug + (#_NSLog #@"revert to saved from file %@ of type %@" + :id filename :id filetype) + (let* ((encoding (slot-value self 'encoding)) + (nsstring (make-instance ns:ns-string + :with-contents-of-file filename + :encoding encoding + :error +null-ptr+)) + (buffer (hemlock-document-buffer self)) + (old-length (hemlock-buffer-length buffer)) + (hi::*current-buffer* buffer) + (textstorage (slot-value self 'textstorage)) + (point (hi::buffer-point buffer)) + (pointpos (mark-absolute-position point))) + (#/beginEditing textstorage) + (#/edited:range:changeInLength: + textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length)) + (nsstring-to-buffer nsstring buffer) + (let* ((newlen (hemlock-buffer-length buffer))) + (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen) + (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0) + (let* ((ts-string (#/hemlockString textstorage)) + (display (hemlock-buffer-string-cache ts-string))) + (reset-buffer-cache display) + (update-line-cache-for-index display 0) + (move-hemlock-mark-to-absolute-position point + display + (min newlen pointpos)))) + (#/updateMirror textstorage) + (#/endEditing textstorage) + (hi::document-set-point-position self) + (setf (hi::buffer-modified buffer) nil) + (hi::queue-buffer-change buffer) + t)) + + + +(objc:defmethod #/init ((self hemlock-editor-document)) + (let* ((doc (call-next-method))) + (unless (%null-ptr-p doc) + (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer + (make-hemlock-buffer + (lisp-string-from-nsstring + (#/displayName doc)) + :modes '("Lisp" "Editor"))))) + doc)) + + +(objc:defmethod (#/readFromURL:ofType:error: :) + ((self hemlock-editor-document) url type (perror (:* :id))) + (declare (ignorable type)) + (rlet ((pused-encoding :tringncoding 0)) + (let* ((pathname + (lisp-string-from-nsstring + (if (#/isFileURL url) + (#/path url) + (#/absoluteString url)))) + (buffer-name (hi::pathname-to-buffer-name pathname)) + (buffer (or + (hemlock-document-buffer self) + (let* ((b (make-hemlock-buffer buffer-name))) + (setf (hi::buffer-pathname b) pathname) + (setf (slot-value self 'textstorage) + (make-textstorage-for-hemlock-buffer b)) + b))) + (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding)) + (string + (if (zerop selected-encoding) + (#/stringWithContentsOfURL:usedEncoding:error: + ns:ns-string + url + pused-encoding + perror) + +null-ptr+))) + + (if (%null-ptr-p string) + (progn + (if (zerop selected-encoding) + (setq selected-encoding (get-default-encoding))) + (setq string (#/stringWithContentsOfURL:encoding:error: + ns:ns-string + url + selected-encoding + perror))) + (setq selected-encoding (pref pused-encoding :tringncoding))) + (unless (%null-ptr-p string) + (with-slots (encoding) self (setq encoding selected-encoding)) + (hi::queue-buffer-change buffer) + (hi::document-begin-editing self) + (nsstring-to-buffer string buffer) + + (let* ((textstorage (slot-value self 'textstorage)) + (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))) + + (reset-buffer-cache display) + + (#/updateMirror textstorage) + + (update-line-cache-for-index display 0) + + (textstorage-note-insertion-at-position + textstorage + 0 + (hemlock-buffer-length buffer))) + + (hi::document-end-editing self) + + (setf (hi::buffer-modified buffer) nil) + (hi::process-file-options buffer pathname) + t)))) + + + + + +(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files") + +(objc:defmethod (#/keepBackupFile :) ((self hemlock-editor-document)) + ;;; Don't use the NSDocument backup file scheme. + nil) + +(objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :) + ((self hemlock-editor-document) + absolute-url + type + (save-operation :aveperationype) + (error (:* :id))) + (when (and *editor-keep-backup-files* + (eql save-operation #$NSSaveOperation)) + (write-hemlock-backup-file (#/fileURL self))) + (call-next-method absolute-url type save-operation error)) + +(defun write-hemlock-backup-file (url) + (unless (%null-ptr-p url) + (when (#/isFileURL url) + (let* ((path (#/path url))) + (unless (%null-ptr-p path) + (let* ((newpath (#/stringByAppendingString: path #@"~")) + (fm (#/defaultManager ns:ns-file-manager))) + ;; There are all kinds of ways for this to lose. + ;; In order for the copy to succeed, the destination can't exist. + ;; (It might exist, but be a directory, or there could be + ;; permission problems ...) + (#/removeFileAtPath:handler: fm newpath +null-ptr+) + (#/copyPath:toPath:handler: fm path newpath +null-ptr+))))))) + + + +(defmethod hemlock-document-buffer (document) + (let* ((string (#/hemlockString (slot-value document 'textstorage)))) + (unless (%null-ptr-p string) + (let* ((cache (hemlock-buffer-string-cache string))) + (when cache (buffer-cache-buffer cache)))))) + +(defmethod hi:window-buffer ((frame hemlock-frame)) + (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) + (doc (#/documentForWindow: dc frame))) + ;; Sometimes doc is null. Why? What would cause a hemlock frame to + ;; not have a document? (When it happened, there seemed to be a hemlock + ;; frame in (windows) that didn't correspond to any visible window). + (unless (%null-ptr-p doc) + (hemlock-document-buffer doc)))) + +(defmethod hi:window-buffer ((pane text-pane)) + (hi:window-buffer (#/window pane))) + +(defun ordered-hemlock-windows () + (delete-if-not #'(lambda (win) + (and (typep win 'hemlock-frame) + (hi:window-buffer win))) + (windows))) + +(defmethod hi::document-panes ((document hemlock-editor-document)) + (let* ((ts (slot-value document 'textstorage)) + (panes ())) + (for-each-textview-using-storage + ts + #'(lambda (tv) + (let* ((pane (text-view-pane tv))) + (unless (%null-ptr-p pane) + (push pane panes))))) + panes)) + +(objc:defmethod (#/noteEncodingChange: :void) ((self hemlock-editor-document) + popup) + (with-slots (encoding) self + (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup))) + ;; Force modeline update. + (hi::queue-buffer-change (hemlock-document-buffer self)))) + +(objc:defmethod (#/prepareSavePanel: :) ((self hemlock-editor-document) + panel) + (with-slots (encoding) self + (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller) encoding))) + (#/setAction: popup (@selector #/noteEncodingChange:)) + (#/setTarget: popup self) + (#/setAccessoryView: panel popup))) + (#/setExtensionHidden: panel nil) + (#/setCanSelectHiddenExtension: panel nil) + (#/setAllowedFileTypes: panel +null-ptr+) + (call-next-method panel)) + + +(defloadvar *ns-cr-string* (%make-nsstring (string #\return))) +(defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed))) +(defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*)))) + +(objc:defmethod (#/writeToURL:ofType:error: :) + ((self hemlock-editor-document) url type (error (:* :id))) + (declare (ignore type)) + (with-slots (encoding textstorage) self + (let* ((string (#/string textstorage)) + (buffer (hemlock-document-buffer self))) + (case (when buffer (hi::buffer-line-termination buffer)) + (:cp/m (unless (typep string 'ns:ns-mutable-string) + (setq string (make-instance 'ns:ns-mutable-string :with string string)) + (#/replaceOccurrencesOfString:withString:options:range: + string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) + (:macos (setq string (if (typep string 'ns:ns-mutable-string) + string + (make-instance 'ns:ns-mutable-string :with string string))) + (#/replaceOccurrencesOfString:withString:options:range: + string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) + (when (#/writeToURL:atomically:encoding:error: + string url t encoding error) + (when buffer + (setf (hi::buffer-modified buffer) nil)) + t)))) + + + + +;;; Shadow the setFileURL: method, so that we can keep the buffer +;;; name and pathname in synch with the document. +(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document) + url) + (call-next-method url) + (let* ((buffer (hemlock-document-buffer self))) + (when buffer + (let* ((new-pathname (lisp-string-from-nsstring (#/path url)))) + (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname)) + (setf (hi::buffer-pathname buffer) new-pathname))))) + + +(def-cocoa-default *initial-editor-x-pos* :float 20.0f0 "X position of upper-left corner of initial editor") + +(def-cocoa-default *initial-editor-y-pos* :float -20.0f0 "Y position of upper-left corner of initial editor") + +(defloadvar *next-editor-x-pos* nil) ; set after defaults initialized +(defloadvar *next-editor-y-pos* nil) + +(defun x-pos-for-window (window x) + (let* ((frame (#/frame window)) + (screen (#/screen window))) + (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen))) + (let* ((screen-rect (#/visibleFrame screen))) + (if (>= x 0) + (+ x (ns:ns-rect-x screen-rect)) + (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame)))))) + +(defun y-pos-for-window (window y) + (let* ((frame (#/frame window)) + (screen (#/screen window))) + (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen))) + (let* ((screen-rect (#/visibleFrame screen))) + (if (>= y 0) + (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame)) + (+ (ns:ns-rect-height screen-rect) y))))) + +(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document)) + #+debug + (#_NSLog #@"Make window controllers") + (let* ((textstorage (slot-value self 'textstorage)) + (window (%hemlock-frame-for-textstorage + hemlock-frame + textstorage + *editor-columns* + *editor-rows* + nil + (textview-background-color self) + (user-input-style self))) + (controller (make-instance + 'hemlock-editor-window-controller + :with-window window))) + (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self) + (#/addWindowController: self controller) + (#/release controller) + (ns:with-ns-point (current-point + (or *next-editor-x-pos* + (x-pos-for-window window *initial-editor-x-pos*)) + (or *next-editor-y-pos* + (y-pos-for-window window *initial-editor-y-pos*))) + (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point))) + (setq *next-editor-x-pos* (ns:ns-point-x new-point) + *next-editor-y-pos* (ns:ns-point-y new-point)))))) + + +(objc:defmethod (#/close :void) ((self hemlock-editor-document)) + #+debug + (#_NSLog #@"Document close: %@" :id self) + (let* ((textstorage (slot-value self 'textstorage))) + (unless (%null-ptr-p textstorage) + (setf (slot-value self 'textstorage) (%null-ptr)) + (for-each-textview-using-storage + textstorage + #'(lambda (tv) + (let* ((layout (#/layoutManager tv))) + (#/setBackgroundLayoutEnabled: layout nil)))) + (close-hemlock-textstorage textstorage))) + (call-next-method)) + +(defun window-visible-range (text-view) + (let* ((rect (#/visibleRect text-view)) + (layout (#/layoutManager text-view)) + (text-container (#/textContainer text-view)) + (container-origin (#/textContainerOrigin text-view))) + ;; Convert from view coordinates to container coordinates + (decf (pref rect :ect.origin.x) (pref container-origin :oint.x)) + (decf (pref rect :ect.origin.y) (pref container-origin :oint.y)) + (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer: + layout rect text-container)) + (char-range (#/characterRangeForGlyphRange:actualGlyphRange: + layout glyph-range +null-ptr+))) + (values (pref char-range :ange.location) + (pref char-range :ange.length))))) + +(defun hi::scroll-window (textpane n) + (when n + (let* ((sv (text-pane-scroll-view textpane)) + (tv (text-pane-text-view textpane)) + (char-height (text-view-char-height tv)) + (sv-height (ns:ns-size-height (#/contentSize sv))) + (nlines (floor sv-height char-height)) + (count (case n + (:page-up (- nlines)) + (:page-down nlines) + (t n)))) + (multiple-value-bind (pages lines) (floor (abs count) nlines) + (dotimes (i pages) + (if (< count 0) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + tv + (@selector #/scrollPageUp:) + +null-ptr+ + t) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + tv + (@selector #/scrollPageDown:) + +null-ptr+ + t))) + (dotimes (i lines) + (if (< count 0) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + tv + (@selector #/scrollLineUp:) + +null-ptr+ + t) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + tv + (@selector #/scrollLineDown:) + +null-ptr+ + t)))) + ;; If point is not on screen, move it. + (let* ((point (hi::current-point)) + (point-pos (mark-absolute-position point))) + (multiple-value-bind (win-pos win-len) (window-visible-range tv) + (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len))) + (let* ((point (hi::current-point-collapsing-selection)) + (cache (hemlock-buffer-string-cache + (#/hemlockString (#/textStorage tv))))) + (move-hemlock-mark-to-absolute-position point cache win-pos) + ;; We should be done, but unfortunately, well, we're not. + ;; Something insists on recentering around point, so fake it out + #-work-around-overeager-centering + (or (hi::line-offset point (floor nlines 2)) + (if (< count 0) + (hi::buffer-start point) + (hi::buffer-end point)))))))))) + + +(defmethod hemlock::center-text-pane ((pane text-pane)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (text-pane-text-view pane) + (@selector #/centerSelectionInVisibleArea:) + +null-ptr+ + t)) + + +(defun iana-charset-name-of-nsstringencoding (ns) + (#_CFStringConvertEncodingToIANACharSetName + (#_CFStringConvertNSStringEncodingToEncoding ns))) + + +(defun nsstring-for-nsstring-encoding (ns) + (let* ((iana (iana-charset-name-of-nsstringencoding ns))) + (if (%null-ptr-p iana) + (#/stringWithFormat: ns:ns-string #@"{%@}" + (#/localizedNameOfStringEncoding: ns:ns-string ns)) + iana))) + +;;; Return a list of :tringncodings, sorted by the +;;; (localized) name of each encoding. +(defun supported-nsstring-encodings () + (ccl::collect ((ids)) + (let* ((ns-ids (#/availableStringEncodings ns:ns-string))) + (unless (%null-ptr-p ns-ids) + (do* ((i 0 (1+ i))) + () + (let* ((id (paref ns-ids (:* :tringncoding) i))) + (if (zerop id) + (return (sort (ids) + #'(lambda (x y) + (= #$NSOrderedAscending + (#/localizedCompare: + (nsstring-for-nsstring-encoding x) + (nsstring-for-nsstring-encoding y)))))) + (ids id)))))))) + + + + + +;;; TexEdit.app has support for allowing the encoding list in this +;;; popup to be customized (e.g., to suppress encodings that the +;;; user isn't interested in.) +(defmethod build-encodings-popup ((self hemlock-document-controller) + &optional (preferred-encoding (get-default-encoding))) + (let* ((id-list (supported-nsstring-encodings)) + (popup (make-instance 'ns:ns-pop-up-button))) + ;;; Add a fake "Automatic" item with tag 0. + (#/addItemWithTitle: popup #@"Automatic") + (#/setTag: (#/itemAtIndex: popup 0) 0) + (dolist (id id-list) + (#/addItemWithTitle: popup (nsstring-for-nsstring-encoding id)) + (#/setTag: (#/lastItem popup) (nsstring-encoding-to-nsinteger id))) + (when preferred-encoding + (#/selectItemWithTag: popup (nsstring-encoding-to-nsinteger preferred-encoding))) + (#/sizeToFit popup) + popup)) + + +(objc:defmethod (#/runModalOpenPanel:forTypes: :nteger) + ((self hemlock-document-controller) panel types) + (let* ((popup (build-encodings-popup self #|preferred|#))) + (#/setAccessoryView: panel popup) + (let* ((result (call-next-method panel types))) + (when (= result #$NSOKButton) + (with-slots (last-encoding) self + (setq last-encoding (nsinteger-to-nsstring-encoding (#/tag (#/selectedItem popup)))))) + result))) + +(defun hi::open-document () + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (#/sharedDocumentController hemlock-document-controller) + (@selector #/openDocument:) +null-ptr+ t)) + +(defmethod hi::save-hemlock-document ((self hemlock-editor-document)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + self (@selector #/saveDocument:) +null-ptr+ t)) + + +(defmethod hi::save-hemlock-document-as ((self hemlock-editor-document)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + self (@selector #/saveDocumentAs:) +null-ptr+ t)) + +(defmethod hi::save-hemlock-document-to ((self hemlock-editor-document)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + self (@selector #/saveDocumentTo:) +null-ptr+ t)) + +(defun initialize-user-interface () + ;; The first created instance of an NSDocumentController (or + ;; subclass thereof) becomes the shared document controller. So it + ;; may look like we're dropping this instance on the floor, but + ;; we're really not. + (make-instance 'hemlock-document-controller) + ;(#/sharedPanel lisp-preferences-panel) + (make-editor-style-map)) + +;;; This needs to run on the main thread. +(objc:defmethod (#/updateHemlockSelection :void) ((self hemlock-text-storage)) + (assume-cocoa-thread) + (let* ((string (#/hemlockString self)) + (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string))) + (hi::*current-buffer* buffer) + (point (hi::buffer-point buffer)) + (pointpos (mark-absolute-position point)) + (location pointpos) + (len 0)) + (when (hemlock::%buffer-region-active-p buffer) + (let* ((mark (hi::buffer-%mark buffer))) + (when mark + (let* ((markpos (mark-absolute-position mark))) + (if (< markpos pointpos) + (setq location markpos len (- pointpos markpos)) + (if (< pointpos markpos) + (setq location pointpos len (- markpos pointpos)))))))) + #+debug + (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d" + :int (hi::mark-charpos point) :int pointpos) + (for-each-textview-using-storage + self + #'(lambda (tv) + (#/updateSelection:length:affinity: tv location len (if (eql location 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream)))))) + + +(defun hi::allocate-temporary-object-pool () + (create-autorelease-pool)) + +(defun hi::free-temporary-objects (pool) + (release-autorelease-pool pool)) + + +(defloadvar *general-pasteboard* nil) + +(defun general-pasteboard () + (or *general-pasteboard* + (setq *general-pasteboard* + (#/retain (#/generalPasteboard ns:ns-pasteboard))))) + +(defloadvar *string-pasteboard-types* ()) + +(defun string-pasteboard-types () + (or *string-pasteboard-types* + (setq *string-pasteboard-types* + (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType))))) + + +(objc:defmethod (#/stringToPasteBoard: :void) + ((self lisp-application) string) + (let* ((pb (general-pasteboard))) + (#/declareTypes:owner: pb (string-pasteboard-types) nil) + (#/setString:forType: pb string #&NSStringPboardType))) + +(defun hi::string-to-clipboard (string) + (when (> (length string) 0) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t))) + +;;; The default #/paste method seems to want to set the font to +;;; something ... inappropriate. If we can figure out why it +;;; does that and persuade it not to, we wouldn't have to do +;;; this here. +;;; (It's likely to also be the case that Carbon applications +;;; terminate lines with #\Return when writing to the clipboard; +;;; we may need to continue to override this method in order to +;;; fix that.) +(objc:defmethod (#/paste: :void) ((self hemlock-text-view) sender) + (declare (ignorable sender)) + #+debug (#_NSLog #@"Paste: sender = %@" :id sender) + (let* ((pb (general-pasteboard)) + (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType)))) + (unless (%null-ptr-p string) + (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*))) + (setq string (make-instance 'ns:ns-mutable-string :with-string string)) + (#/replaceOccurrencesOfString:withString:options:range: + string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))) + (let* ((textstorage (#/textStorage self))) + (unless (#/shouldChangeTextInRange:replacementString: self (#/selectedRange self) string) + (#/setSelectedRange: self (ns:make-ns-range (#/length textstorage) 0))) + (let* ((selectedrange (#/selectedRange self))) + (#/replaceCharactersInRange:withString: textstorage selectedrange string)))))) + + +(objc:defmethod (#/hyperSpecLookUp: :void) + ((self hemlock-text-view) sender) + (declare (ignore sender)) + (let* ((range (#/selectedRange self))) + (unless (eql 0 (ns:ns-range-length range)) + (let* ((string (nstring-upcase (lisp-string-from-nsstring (#/substringWithRange: (#/string (#/textStorage self)) range))))) + (multiple-value-bind (symbol win) (find-symbol string "CL") + (when win + (lookup-hyperspec-symbol symbol self))))))) + + +(defun hi::edit-definition (name) + (let* ((info (ccl::get-source-files-with-types&classes name))) + (when (null info) + (let* ((seen (list name)) + (found ()) + (pname (symbol-name name))) + (dolist (pkg (list-all-packages)) + (let ((sym (find-symbol pname pkg))) + (when (and sym (not (member sym seen))) + (let ((new (ccl::get-source-files-with-types&classes sym))) + (when new + (setq info (append new info)) + (push sym found))) + (push sym seen)))) + (when found + ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer). + (hi::loud-message "No definitions for ~s, using ~s instead" + name (if (cdr found) found (car found)))))) + (if info + (if (cdr info) + (edit-definition-list name info) + (edit-single-definition name (car info))) + (hi::editor-error "No known definitions for ~s" name)))) + + +(defun find-definition-in-document (name indicator document) + (let* ((buffer (hemlock-document-buffer document)) + (hi::*current-buffer* buffer)) + (hemlock::find-definition-in-buffer buffer name indicator))) + + +(defstatic *edit-definition-id-map* (make-id-map)) + +;;; Need to force things to happen on the main thread. +(defclass cocoa-edit-definition-request (ns:ns-object) + ((name-id :foreign-type :int) + (info-id :foreign-type :int)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/initWithName:info: + ((self cocoa-edit-definition-request) + (name :int) (info :int)) + (#/init self) + (setf (slot-value self 'name-id) name + (slot-value self 'info-id) info) + self) + +(objc:defmethod (#/editDefinition: :void) + ((self hemlock-document-controller) request) + (let* ((name (id-map-free-object *edit-definition-id-map* (slot-value request 'name-id))) + (info (id-map-free-object *edit-definition-id-map* (slot-value request 'info-id)))) + (destructuring-bind (indicator . pathname) info + (let* ((namestring (native-translated-namestring pathname)) + (url (#/initFileURLWithPath: + (#/alloc ns:ns-url) + (%make-nsstring namestring))) + (document (#/openDocumentWithContentsOfURL:display:error: + self + url + nil + +null-ptr+))) + (unless (%null-ptr-p document) + (if (= (#/count (#/windowControllers document)) 0) + (#/makeWindowControllers document)) + (find-definition-in-document name indicator document) + (#/updateHemlockSelection (slot-value document 'textstorage)) + (#/showWindows document)))))) + +(defun edit-single-definition (name info) + (let* ((request (make-instance 'cocoa-edit-definition-request + :with-name (assign-id-map-id *edit-definition-id-map* name) + :info (assign-id-map-id *edit-definition-id-map* info)))) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (#/sharedDocumentController ns:ns-document-controller) + (@selector #/editDefinition:) + request + t))) + + +(defun edit-definition-list (name infolist) + (make-instance 'sequence-window-controller + :sequence infolist + :result-callback #'(lambda (info) + (edit-single-definition name info)) + :display #'(lambda (item stream) + (prin1 (car item) stream)) + :title (format nil "Definitions of ~s" name))) + + +(objc:defmethod (#/documentClassForType: :lass) ((self hemlock-document-controller) + type) + (if (#/isEqualToString: type #@"html") + display-document + (call-next-method type))) + + +(objc:defmethod #/newDisplayDocumentWithTitle:content: + ((self hemlock-document-controller) + title + string) + (assume-cocoa-thread) + (let* ((doc (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+))) + (unless (%null-ptr-p doc) + (#/addDocument: self doc) + (#/makeWindowControllers doc) + (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0)))) + (#/setTitle: window title) + (let* ((tv (slot-value doc 'text-view)) + (lm (#/layoutManager tv)) + (ts (#/textStorage lm))) + (#/beginEditing ts) + (#/replaceCharactersInRange:withAttributedString: + ts + (ns:make-ns-range 0 (#/length ts)) + string) + (#/endEditing ts)) + (#/makeKeyAndOrderFront: window self))) + doc)) + +(defun hi::revert-document (doc) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + doc + (@selector #/revertDocumentToSaved:) + +null-ptr+ + t)) + + +;;; Enable CL:ED +(defun cocoa-edit (&optional arg) + (let* ((document-controller (#/sharedDocumentController hemlock-document-controller))) + (cond ((null arg) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + document-controller + (@selector #/newDocument:) + +null-ptr+ + t)) + ((or (typep arg 'string) + (typep arg 'pathname)) + (unless (probe-file arg) + (ccl::touch arg)) + (with-autorelease-pool + (let* ((url (pathname-to-url arg)) + (signature (#/methodSignatureForSelector: + document-controller + (@selector #/openDocumentWithContentsOfURL:display:error:))) + (invocation (#/invocationWithMethodSignature: ns:ns-invocation + signature))) + + (#/setTarget: invocation document-controller) + (#/setSelector: invocation (@selector #/openDocumentWithContentsOfURL:display:error:)) + (rlet ((p :id) + (q :) + (perror :id +null-ptr+)) + (setf (pref p :id) url + (pref q :) #$YES) + (#/setArgument:atIndex: invocation p 2) + (#/setArgument:atIndex: invocation q 3) + (#/setArgument:atIndex: invocation perror 4) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + invocation + (@selector #/invoke) + +null-ptr+ + t))))) + ((ccl::valid-function-name-p arg) + (hi::edit-definition arg)) + (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))) + t)) + +(setq ccl::*resident-editor-hook* 'cocoa-edit) + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-grep.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-grep.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-grep.lisp (revision 8058) @@ -0,0 +1,163 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(defvar *grep-program* "grep") + +(defclass cocoa-edit-grep-line-request (ns:ns-object) + ((file-id :foreign-type :int) + (line-num :foreign-type :int)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/initWithFile:line: + ((self cocoa-edit-grep-line-request) (file :int) (line :int)) + (#/init self) + (setf (slot-value self 'file-id) file + (slot-value self 'line-num) line) + self) + +(objc:defmethod (#/editGrepLine: :void) + ((self hemlock-document-controller) request) + (let* ((file (id-map-free-object *edit-definition-id-map* (slot-value request 'file-id))) + (line-num (slot-value request 'line-num)) + (namestring (native-translated-namestring file)) + (url (#/initFileURLWithPath: + (#/alloc ns:ns-url) + (%make-nsstring namestring))) + (document (#/openDocumentWithContentsOfURL:display:error: + self + url + nil + +null-ptr+))) + (unless (%null-ptr-p document) + (when (= (#/count (#/windowControllers document)) 0) + (#/makeWindowControllers document)) + (let* ((buffer (hemlock-document-buffer document)) + (hi::*current-buffer* buffer)) + (edit-grep-line-in-buffer line-num)) + (#/updateHemlockSelection (slot-value document 'textstorage)) + (#/showWindows document)))) + +(defun edit-grep-line-in-buffer (line-num) + (let ((point (hi::current-point-collapsing-selection))) + (hi::buffer-start point) + (unless (hi::line-offset point line-num) + (hi::buffer-end point)))) + +(defun parse-grep-line (line) + (let* ((pos1 (position #\: line)) + (pos2 (and pos1 (position #\: line :start (1+ pos1)))) + (num (and pos2 (ignore-errors + (parse-integer line :start (1+ pos1) :end pos2 + :junk-allowed nil)))) + (file (and num (subseq line 0 pos1)))) + (when file + (values file (1- num))))) + +(defun request-edit-grep-line (line) + (multiple-value-bind (file line-num) (parse-grep-line line) + (when file + (let* ((request (make-instance 'cocoa-edit-grep-line-request + :with-file (assign-id-map-id *edit-definition-id-map* file) + :line line-num))) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (#/sharedDocumentController ns:ns-document-controller) + (@selector #/editGrepLine:) + request + t))))) + +(defun grep-comment-line-p (line) + (multiple-value-bind (file line-num) (parse-grep-line line) + #+gz (when (member "archive" (pathname-directory file) :test #'equalp) + (return-from grep-comment-line-p t)) + (with-open-file (stream file) + (loop while (> line-num 0) + for ch = (read-char stream nil nil) + when (null ch) do (return nil) + do (when (member ch '(#\Return #\Linefeed)) + (decf line-num) + (when (and (eql ch #\Return) + (eql (peek-char nil stream nil nil) #\Linefeed)) + (read-char stream)))) + (when (eql line-num 0) + (loop as ch = (read-char stream nil nil) + while (and ch (whitespacep ch) (not (member ch '(#\Return #\Linefeed)))) + finally (return (eql ch #\;))))))) + +(defun grep-remove-comment-lines (lines) + (remove-if #'grep-comment-line-p lines)) + +(defun split-grep-lines (output) + (loop with end = (length output) + for start = 0 then (1+ pos) + as pos = (or (position #\Newline output :start start :end end) end) + when (< start pos) collect (subseq output start pos) + while (< pos end))) + +(defvar *grep-ignore-case* t) +(defvar *grep-include-pattern* "*.lisp") +(defvar *grep-exclude-pattern* "*~.lisp") + +(defun grep (pattern directory &key (ignore-case *grep-ignore-case*) + (include *grep-include-pattern*) + (exclude *grep-exclude-pattern*)) + (with-output-to-string (stream) + (let* ((proc (run-program *grep-program* + (nconc (and include (list "--include" include)) + (and exclude (list "--exclude" exclude)) + (and ignore-case (list "--ignore-case")) + (list "--recursive" + "--with-filename" + "--line-number" + "--no-messages" + "-e" pattern + (ccl::native-untranslated-namestring directory))) + :input nil + :output stream))) + (multiple-value-bind (status exit-code) (external-process-status proc) + (let ((output (get-output-stream-string stream))) + (if (and (eq :exited status) (or (= exit-code 0) (= exit-code 2))) + (let ((lines (split-grep-lines output))) + (unless (hi:value hemlock::grep-search-comments) + (setq lines (grep-remove-comment-lines lines))) + (make-instance 'sequence-window-controller + :sequence lines + :result-callback #'request-edit-grep-line + :display #'princ + :title (format nil "~a in ~a" pattern directory))) + (hi:editor-error "Error in grep status ~s code ~s: ~a" status exit-code output))))))) + + +(hi:defhvar "Grep Directory" + "The directory searched by \"Grep\". NIL means to use the directory of the buffer." + :value nil) + +(hi:defhvar "Grep Search Comments" + "If true (the default) grep will find results anywhere. NIL means to ignore results + within comments. For now only recognizes as comments lines which start with semi-colon." + :value t) + +(hi:defcommand "Grep" (p) + "Prompts for a pattern and invokes grep, searching recursively through .lisp + files in \"Grep Directory\". + With an argument, prompts for a directory to search, and sets \"Grep Directory\" + for the next time." + "" + (let* ((default (make-pathname :name :unspecific + :type :unspecific + :defaults (or (hi:value hemlock::grep-directory) + (hi:buffer-pathname hi::*current-buffer*) + "ccl:"))) + (directory (if p + (setf (hi:value hemlock::grep-directory) + (hi:prompt-for-file :must-exist t + :default default + :default-string (namestring default) + :prompt "Directory: ")) + default)) + (pattern (hi:prompt-for-string + :prompt "Pattern: " + :help "Pattern to search for"))) + (grep pattern directory))) Index: /branches/experimentation/later/source/cocoa-ide/cocoa-inspector.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-inspector.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-inspector.lisp (revision 8058) @@ -0,0 +1,469 @@ +;;;-*-Mode: LISP; Package: GUI -*- + +(in-package "GUI") + +#| +(cinspect ) + +A cocoa-based lisp inspector, LGPL'ed by Hamilton Link + +This code is freely distributable, etc. but I would appreciate people +submitting changes back to me and making suggestions about how it +could be altered or improved to me rather than starting a totally +separate inspector. + +Major plans: + Shift all the browser columns over to allow the first column to just have the object + Make double-clicking an object bring any existing inspector for that object to the front unless shift key is held + +Minor tweaks: + test on all sorts of things for sanity of leaf-ness of nodes and fields + test on all sorts of things for santity in what's safely editable in table view + fix the leaf-ness fields with a macptr value + change the font to something smaller (or even better, be settable) + clean up this file, maybe make a dedicated cinspector package for such things + document lessons learned about NSBrowser and NSTableView for next time + +Bugs: + - when selecting a non-item in a lower column that was just being + displayed (in the NSBrowser), the tableview isn't cleared and it + probably should be. + + Possibly a reasonable next thing after that would be to make control- +or alt-double-clicking open new windows with other browsing metaphors +appropriate to the object (like a class heirarchy browser, maybe a +table view for matrices, etc.), we'll see. + Eventually I'd like to expand the whole inspector functionality to +deal with ObjC things (methods and objects) and C foreign data in +general, but that's further off unless someone wants to take a crack +at it. Once we know we've got a macptr into ObjC we can deal, but some +very carefully written functions need to exist to safely interrogate +a random pointer to make that determination. + +Note the variable name convention in this file: "cinspector" refers to +a cocoa-inspector object containing a set of objects being displayed, +while "inspector" refers to an inspector object from the :inspector +package, which are used for command-line inspecting. + +|# + + +#| +I'd rather set up this file to be +- in-package cl-user +- require of some things +- a package definition for this code that brings in inspector::this-and-that and ccl::objc-stuff +- a couple of load-file forms that populate the new package and have the bulk of the following code +|# + +;;; This is useful when @ won't work, dynamically creating a NSString +;;; pointer from a string. + +(defun nsstringptr (string) + (ccl::objc-constant-string-nsstringptr + (ccl::ns-constant-string string))) + +#+old +(defmacro handler-case-for-cocoa (id form) + (declare (ignorable id)) + `(handler-case + ,form + (condition (c) + (declare (ignorable c)) + #+ignore + (format t "~s: Trapping condition: ~a" ,id c) + nil))) + +; for now this will map windows to objects -- the windows are pretty big, +; though, so it would be nice to extend them so the list of inspected objects +; is switchable in a single window (shouldn't be too hard once basic functionality +; is slapped down) +(defparameter *cocoa-inspector-nswindows-table* (make-hash-table :test 'eql)) + +;;; this is what a window should map to - an object that manages all +;;; the data a window might be displaying +(defclass cocoa-inspector () + ((object-vector :initform (make-array 0 :adjustable t :fill-pointer 0) :accessor object-vector) + (inspector-vector :initform (make-array 0 :adjustable t :fill-pointer 0) :accessor inspector-vector) + (focal-point :initform 0 :accessor focal-point))) + +;;; note that ELT pays attention to the fill pointer, while AREF doesn't! +(defmethod object ((cinspector cocoa-inspector)) + (elt (object-vector cinspector) (focal-point cinspector))) +(defmethod nth-object ((cinspector cocoa-inspector) n) + (elt (object-vector cinspector) n)) +(defmethod inspector ((cinspector cocoa-inspector)) + ;; This can return nil. + (let* ((i (focal-point cinspector)) + (v (inspector-vector cinspector)) + (n (length v))) + (if (< i n) + (aref v i)))) +(defmethod nth-inspector ((cinspector cocoa-inspector) n) + (elt (inspector-vector cinspector) n)) +(defmethod push-object (object (cinspector cocoa-inspector)) + (let ((inspector (inspector::make-inspector object))) + (vector-push-extend object (object-vector cinspector)) + (vector-push-extend inspector (inspector-vector cinspector)) + (inspector::update-line-count inspector)) + #+ignore + (format t " after push-object, fill pointers = ~a ~a~%" + (fill-pointer (object-vector cinspector)) (fill-pointer (inspector-vector cinspector))) + object) +(defmethod (setf max-column) (value (cinspector cocoa-inspector)) + (when (and (numberp value) (<= 0 value (1- (fill-pointer (object-vector cinspector))))) + (setf ; new fill-pointers are just outside of the valid bounds + (fill-pointer (object-vector cinspector)) (1+ value) + (fill-pointer (inspector-vector cinspector)) (1+ value) + ; new focal point is either what it was before, or the new max column if that's smaller + (focal-point cinspector) (min value (focal-point cinspector))) + #+ignore + (format t " after (setf max-column), fill pointers = ~a ~a~%" + (fill-pointer (object-vector cinspector)) (fill-pointer (inspector-vector cinspector))) + value)) + +;; In the browser view, we'll find the element for some column +;; and consider whether any of its components merit further inspection +;; and, if so, which ones +(defmethod leaf-node-p ((thing t)) nil) +(defmethod leaf-node-p ((thing (eql t))) t) +(defmethod leaf-node-p ((thing null)) t) +(defmethod leaf-node-p ((thing number)) t) +(defmethod leaf-node-p ((thing string)) t) +(defmethod leaf-node-p ((thing inspector::unbound-marker)) t) +(defmethod leaf-field-p ((thing t) n) + (declare (ignore n)) + nil) ; for a non-leaf node, all fields are futher probable by default +(defmethod leaf-field-p ((thing symbol) n) + (when (and (keywordp thing) (= n 4)) t)) + +; whatever is currently the selected object in the inspector, get its +; properties and values for the tableView and print them to a string +(defun focus-nth-line (cinspector n) + (let* ((inspector (inspector cinspector)) + (*print-circle* t) + (output-stream (make-string-output-stream))) + (inspector::prin1-line-n inspector output-stream n) + (get-output-stream-string output-stream))) +(defun nth-object-nth-line (cinspector obj-n line-n) + (let* ((inspector (nth-inspector cinspector obj-n)) + (*print-circle* t) + (output-stream (make-string-output-stream))) + (inspector::prin1-line-n inspector output-stream line-n) + (get-output-stream-string output-stream))) +(defun focus-nth-property (cinspector n) + (let ((inspector (inspector cinspector))) + (multiple-value-bind (value label type) (inspector::line-n inspector n) + (declare (ignore value type)) + (if label + (format nil "~a" label) + "")))) +(defun focus-nth-value (cinspector n) + (let* ((inspector (inspector cinspector)) + (*print-circle* t) + (output-stream (make-string-output-stream)) + (*package* (find-package :cl-user))) + (multiple-value-bind (value label type) (inspector::line-n inspector n) + (declare (ignore label type)) + (format output-stream "~s" value)) + (get-output-stream-string output-stream))) +(defun nth-object-nth-value (cinspector obj-n line-n) + (let ((inspector (nth-inspector cinspector obj-n))) + (multiple-value-bind (value label type) (inspector::line-n inspector line-n) + (declare (ignore label type)) + value))) +(defun (setf focus-nth-value) (value cinspector n) + (let ((inspector (inspector cinspector))) + (setf (inspector::line-n inspector n) value))) +(defun focus-nth-value-editable (cinspector n) + (let ((inspector (inspector cinspector))) + (multiple-value-bind (value label type) (inspector::line-n inspector n) + (declare (ignore value)) + (and (or (null type) + (eq :normal type) + (eq :colon type)) + (editable-field-p (object cinspector) n label))))) +(defun nth-object-nth-value-editable (cinspector obj-n line-n) + (let ((inspector (nth-inspector cinspector obj-n))) + (multiple-value-bind (value label type) (inspector::line-n inspector line-n) + (declare (ignore value)) + (and (or (null type) + (eq :normal type) + (eq :colon type)) + (editable-field-p (nth-object cinspector obj-n) line-n label))))) +;; for now most of these will assume that field numbers are good enough, +;; certain things have inspector fields that move around (like symbols) +;; and can be dealt with on a case by case basis, but that's the reason +;; for passing in the label along with the field number +(defmethod editable-field-p ((thing t) n label) + (declare (ignore n label)) + t) +;; for lists field 4 is length, could cause a change but inspector doesn't just handle it +;; and at the moment I haven't started thinking of a framework for allowing such extensions +(defmethod editable-field-p ((thing list) n label) + (declare (ignore label)) + (/= n 4)) + +#| +I think most of the following should be pretty straightforward for +most utilities meant to run under openmcl: A NIB file, some delegates +and data sources, and some specialized callback functions for talking +with the ObjC world, and some standard code for keeping track of the +appropriate windows. -hel +|# + +; When loading a NIB file with an NSWindowController, DON'T omit the .nib extension +; if you're calling initWithWindowNibPath:owner: (even though the documentation says you should!) +#+ignore +(defparameter *default-inspector-nib-pathname* #p"CCL:OpenMCL.app;Contents;Resources;English.lproj;OpenmclInspector.nib") +; When loading it with a custom WindowController and initWithWindowNibName:, just the main file name +(defparameter *default-inspector-nib-pathname* #p"OpenmclInspector") + +;; Q: Is this subclass of NSBrowser enabling the doubleAction? I added it expecting to have to +;; specialize mouseDown (or whatever) to track double-clicking, but it just started working. +(defclass inspector-ns-browser (ns:ns-browser) ; just to specialize mousing, not add slots + () + (:metaclass ns:+ns-object)) + +(defclass inspector-window-controller (ns:ns-window-controller) + ((inspector-browser :foreign-type :id :reader inspector-browser)) + (:metaclass ns:+ns-object)) + +(defclass inspector-browser-delegate (ns:ns-object) + ((inspector-table-view :foreign-type :id :reader inspector-table-view) + (inspector-window :foreign-type :id :reader inspector-window)) + (:metaclass ns:+ns-object)) + +; why is the order of these two slots important? +; I get a segfault selecting the browser when they're in window/browser order after doing modifications in the table. +(defclass inspector-table-view-data-source (ns:ns-object) + ((inspector-browser :foreign-type :id :reader inspector-browser) + (inspector-window :foreign-type :id :reader inspector-window)) + (:metaclass ns:+ns-object)) + +(defclass inspector-table-view-delegate (ns:ns-object) + ((inspector-window :foreign-type :id :reader inspector-window)) + (:metaclass ns:+ns-object)) + + +;;; is there some reason this is called before the cell is actually +;;; selected? In any case, when a non-leaf cell is selected, this +;;; function is called first for the new column, so it has to push the +;;; new element into the cinspector -- what the browserAction will be +;;; left doing it remains to be seen. The only other time this is +;;; called AFAICT is when loadColumnZero or reloadColumn is called +(objc:defmethod (#/browser:numberOfRowsInColumn: :nteger) + ((self inspector-browser-delegate) + browser + (column :nteger)) + (or (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (selected-column (#/selectedColumn browser)) ; probably always (1- column), when a column is selected + (cinspector-column (1- selected-column)) ; 2nd column of nsbrowser <-> 1st column of cinspector + (row (#/selectedRowInColumn: browser selected-column))) + #+ignore + (format t "getting length of column ~d based on row ~d in column ~d~%" column row selected-column) + (cond ((not cinspector) 0) + ((= column 0) 1) ; just displaying the printed representaiton of the top inspected object + ((= selected-column 0) ; selected the printed rep of the inspected object (column should = 1) + (setf (max-column cinspector) 0) ; crop object-vector in cinspector + (let ((inspector (nth-inspector cinspector 0))) ; inspector for top object + (inspector::inspector-line-count inspector))) + ((>= selected-column 1) ; (-1 is the N/A column) + (setf (max-column cinspector) cinspector-column) ; crop object-vector in cinspector + (push-object (nth-object-nth-value cinspector cinspector-column row) cinspector) + (let ((inspector (nth-inspector cinspector (1+ cinspector-column)))) ; inspector for object just pushed + (inspector::inspector-line-count inspector))))) + 0)) + +#| +;; temporarily saved in case the above fails horribly + (if cinspector + (handler-case + (progn (when (<= 0 selected-column) ; -1 is sort of the N/A column + (setf (max-column cinspector) selected-column) + (push-object (nth-object-nth-value cinspector selected-column row) cinspector)) + (let ((inspector (nth-inspector cinspector column))) + (inspector::inspector-line-count inspector))) + (condition () 0)) + 0))) +|# + +;; In the following method defn this is unnecessary, the Browser can tell this for itself +;; [cell "setLoaded:" : #$YES] +(objc:defmethod (#/browser:willDisplayCell:atRow:column: :void) + ((self inspector-browser-delegate) + browser + cell + (row :nteger) + (column :nteger)) + (declare (ignorable browser column)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (cinspector-column (1- column))) ; 2nd column of nsbrowser <-> 1st column of cinspector + #+ignore + (format t "asking for value for column ~a, row ~a~%" column row) + (cond ((not cinspector) nil) + ((= column 0) + (#/setStringValue: cell (nsstringptr (format nil "~s" (nth-object cinspector 0)))) + (#/setLeaf: cell nil)) + (t + ;; when switching between widgets to the browser, we can + ;; have reloaded a column and need to drill down a row + ;; from where we are at the moment + (#/setStringValue: cell (nsstringptr (nth-object-nth-line cinspector cinspector-column row))) + ;; leaf-p should really consider the type of the object in + ;; question (eventually taking into account whether we're + ;; browsing the class heirarchy or into objc or whatever) + (#/setLeaf: cell (or (leaf-node-p (nth-object cinspector cinspector-column)) ; i.e. no fields drill down + (leaf-field-p (nth-object cinspector cinspector-column) row) + ;; for now... + (= row 0) + (not (nth-object-nth-value-editable cinspector cinspector-column row)))))))) + +;;; when all is said and done and once the cinspector is properly +;;; populated, the selected object in the browser's nth column is +;;; actually the object in the cinspector's nth column (i.e. because +;;; the selected object is displayed in the next browser column over, +;;; and the cinspector and nsbrowser have a 1-off discrepancy, they +;;; cancel out) -- just a note to make the difference between these +;;; next two functions and the previous two functions + +;;; change the focus of the the table view to be the selected object +(objc:defmethod (#/browserAction: :void) + ((self inspector-browser-delegate) + sender); don't know why I'd want to, but could use a separate IBTarget class + #+ignore (format t "browserAction~%") + (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (column (#/selectedColumn sender))) + (when (<= 0 column) + (setf (focal-point cinspector) column) + (#/reloadData (inspector-table-view self)) + #+ignore + (format t " responding to selection in column ~d~%" column)))) + +;; open a new inspector on the selected object +(objc:defmethod (#/browserDoubleAction: :void) + ((self inspector-browser-delegate) + sender) + #+ignore (format t "browserDoubleAction~%") + (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (column (#/selectedColumn sender))) + (when (< -1 column (length (object-vector cinspector))) + ;; this seems to work, but I'm not really paying attention to + ;; thread stuff... + (cinspect (nth-object cinspector column))))) + +(objc:defmethod (#/numberOfRowsInTableView: :nteger) + ((self inspector-table-view-data-source) + table-view) + (declare (ignore table-view)) + + (or (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + (if cinspector + (let ((inspector (inspector cinspector))) + (if inspector + (inspector::inspector-line-count inspector) + 0)))) + 0)) + +(objc:defmethod #/tableView:objectValueForTableColumn:row: + ((self inspector-table-view-data-source) + table-view + table-column + (row :nteger)) + (declare (ignore table-view)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + (cond ((not cinspector) + #@"") + ((#/isEqual: (#/identifier table-column) #@"property") + (nsstringptr (focus-nth-property cinspector row))) + ((#/isEqual: (#/identifier table-column) #@"value") + (nsstringptr (focus-nth-value cinspector row)))))) + +;; I'm hoping that the delegate will prevent this from being called willy-nilly +(objc:defmethod (#/tableView:setObjectValue:forTableColumn:row: :void) + ((self inspector-table-view-data-source) + table-view object table-column (row :nteger)) + (declare (ignore table-column)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + ;; without any formatters, object appears to be an NSCFString + ;; also note we should probably save the original value (including unboundness etc) + ;; first so that we can return to it in the event of any error + ;; plus we should avoid doing anything if the original string and the new string are equal + (when cinspector + (setf (focus-nth-value cinspector row) + (let ((*package* (find-package :cl-user))) + ;; with-autorelease-pool could possibly be needed to + ;; autorelease the cString we're handling (I think) + (eval (read-from-string (lisp-string-from-nsstring object))))) + (#/reloadData table-view) ; really could just reload that one cell, but don't know how... + ;; changing the focused object may effect the browser's path, + ;; reload its column and keep the cinspector consistent Here we + ;; have to make sure that the column we're reloading and the + ;; column after both have values to display, for when + ;; reloadColumn: invokes browser:willDisplayCell:atRow:column: + (#/reloadColumn: (inspector-browser self) (focal-point cinspector)) + ;; [inspector-browser "scrollColumnToVisible:" :int (focal-point cinspector)] ; maybe need this, too + ))) + +;;; In the table view, the properties are not editable, but the +;;; values (if editable) allow lisp forms to be entered that are +;;; read and evaluated to determine the new property value. +(objc:defmethod (#/tableView:shouldEditTableColumn:row: :) + ((self inspector-table-view-delegate) + table-view table-column (row :nteger)) + (declare (ignore table-view)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + (and cinspector + (#/isEqual: (#/identifier table-column) #@"value") + (/= row 0) ; in practice the reference to + ; the object isn't editable, and + ; the GUI semantics aren't clear anyway, + ; possibly there will come a + ; time when I put row 0 in the + ; table title, but I need to + ; maintain the 0-indexed + ; focus-nth-whatever API here + ; and elsewhere if I do that + (focus-nth-value-editable cinspector row)))) + +;; the inspectorwindowcontroller is set up as the delegate of the window... +;; we now eliminate the dangling pointer to the window from the hash table +(objc:defmethod (#/windowWillClose: :void) + ((self inspector-window-controller) notification) + (let ((nswindow (#/object notification))) + (remhash nswindow *cocoa-inspector-nswindows-table*))) + +;;; hopefully a generally useful function +(defun load-windowcontroller-from-nib (wc-classname nib-pathname) + "Takes a NIB name and returns a new window controller" + (with-autorelease-pool + (make-instance + wc-classname + :with-window-nib-name (nsstringptr (namestring nib-pathname))))) + +;;; make a new inspector window from the nib file, and hash the window's +;;; browser and tableview to the object +(defun cinspect (object) + (with-autorelease-pool + (let* ((windowcontroller (load-windowcontroller-from-nib 'inspector-window-controller *default-inspector-nib-pathname*)) + (window (#/window windowcontroller)) + (cinspector (make-instance 'cocoa-inspector))) + ;; set up the window's initial "focused" object -- this may change as + ;; different parts of the inspector are clicked on, and actually we + ;; probably want to track more information than that associated with the + ;; window, so probably this will eventually be hashed to something like + ;; an inspector for the object or an even bigger wrapper + (setf (gethash window *cocoa-inspector-nswindows-table*) cinspector) + (push-object object cinspector) + ;; is this working? it isn't breaking, but double-clicking is + ;; being handled as two single actions + (let* ((browser (inspector-browser windowcontroller))) + (#/setColumnResizingType: browser #$NSBrowserUserColumnResizing) + (#/setPrefersAllColumnUserResizing: browser nil) + (#/setDoubleAction: browser (@selector #/browserDoubleAction:)) + (#/setIgnoresMultiClick: browser t)) + (#/showWindow: windowcontroller window) + window))) + +;;; Make INSPECT call CINSPECT. +(setq inspector::*default-inspector-ui-creation-function* 'cinspect) Index: /branches/experimentation/later/source/cocoa-ide/cocoa-listener.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-listener.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-listener.lisp (revision 8058) @@ -0,0 +1,599 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(def-cocoa-default *listener-input-font* :font #'(lambda () + (#/fontWithName:size: + ns:ns-font + #@"Monaco" 10.0)) + "Default font for listener input") +(def-cocoa-default *listener-output-font* :font #'(lambda () + (#/fontWithName:size: + ns:ns-font + #@"Monaco" 10.0)) + "Default font for listener output") + +(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters") +(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters") + +(def-cocoa-default hi::*listener-output-style* :int 1 "Text style index for listener output") + +(def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output") + +(def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color") + +(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output") + +;;; Setup the server end of a pty pair. +(defun setup-server-pty (pty) + (set-tty-raw pty) + pty) + +;;; Setup the client end of a pty pair. +(defun setup-client-pty (pty) + ;; Since the same (Unix) process will be reading from and writing + ;; to the pty, it's critical that we make the pty non-blocking. + ;; Has this been true for the last few years (native threads) ? + ;(fd-set-flag pty #$O_NONBLOCK) + (set-tty-raw pty) + #+no + (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG)) + #+no + (disable-tty-output-modes pty #$ONLCR) + pty) + + +(defloadvar *cocoa-listener-count* 0) + +(defclass cocoa-listener-process (process) + ((input-stream :reader cocoa-listener-process-input-stream) + (output-stream :reader cocoa-listener-process-output-stream) + (input-peer-stream :reader cocoa-listener-process-input-peer-stream) + (backtrace-contexts :initform nil + :accessor cocoa-listener-process-backtrace-contexts) + (window :reader cocoa-listener-process-window) + (buffer :initform nil :reader cocoa-listener-process-buffer))) + + +(defun new-cocoa-listener-process (procname input-fd output-fd peer-fd window buffer) + (let* ((input-stream (ccl::make-selection-input-stream + input-fd + :peer-fd peer-fd + :elements-per-buffer (#_fpathconf + input-fd + #$_PC_MAX_INPUT) + :encoding :utf-8)) + (output-stream (ccl::make-fd-stream output-fd :direction :output + :sharing :lock + :elements-per-buffer + (#_fpathconf + output-fd + #$_PC_MAX_INPUT) + :encoding :utf-8)) + (peer-stream (ccl::make-fd-stream peer-fd :direction :output + :sharing :lock + :elements-per-buffer + (#_fpathconf + peer-fd + #$_PC_MAX_INPUT) + :encoding :utf-8)) + (proc + (ccl::make-mcl-listener-process + procname + input-stream + output-stream + #'(lambda ()` + (let* ((buf (find *current-process* hi:*buffer-list* + :key #'hi::buffer-process)) + (doc (if buf (hi::buffer-document buf)))) + (when doc + (setf (hi::buffer-process buf) nil) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + doc + (@selector #/close) + +null-ptr+ + nil)))) + :initial-function + #'(lambda () + (setq ccl::*listener-autorelease-pool* (create-autorelease-pool)) + (ccl::listener-function)) + :class 'cocoa-listener-process))) + (setf (slot-value proc 'input-stream) input-stream) + (setf (slot-value proc 'output-stream) output-stream) + (setf (slot-value proc 'input-peer-stream) peer-stream) + (setf (slot-value proc 'window) window) + (setf (slot-value proc 'buffer) buffer) + proc)) + + +(defclass hemlock-listener-frame (hemlock-frame) + () + (:metaclass ns:+ns-object)) +(declaim (special hemlock-listener-frame)) + + +(defclass hemlock-listener-window-controller (hemlock-editor-window-controller) + ((filehandle :foreign-type :id) ;Filehandle for I/O + (clientfd :foreign-type :int) ;Client (listener)'s side of pty + (nextra :foreign-type :int) ;count of untranslated bytes remaining + (translatebuf :foreign-type :address) ;buffer for utf8 translation + (bufsize :foreign-type :int) ;size of translatebuf + ) + (:metaclass ns:+ns-object) + ) +(declaim (special hemlock-listener-window-controller)) + +;;; Listener documents are never (or always) ediited. Don't cause their +;;; close boxes to be highlighted. +(objc:defmethod (#/setDocumentEdited: :void) + ((self hemlock-listener-window-controller) (edited :)) + (declare (ignorable edited))) + + +(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w) + (let* ((new (call-next-method w))) + (unless (%null-ptr-p new) + (multiple-value-bind (server client) (ignore-errors (open-pty-pair)) + (when server + (let* ((fh (make-instance + 'ns:ns-file-handle + :with-file-descriptor (setup-server-pty server) + :close-on-dealloc t))) + (setf (slot-value new 'filehandle) fh) + (setf (slot-value new 'clientfd) (setup-client-pty client)) + (let* ((bufsize #$BUFSIZ) + (buffer (#_malloc bufsize))) + (setf (slot-value new 'translatebuf) buffer + (slot-value new 'bufsize) bufsize + (slot-value new 'nextra) 0)) + (#/addObserver:selector:name:object: + (#/defaultCenter ns:ns-notification-center) + new + (@selector #/gotData:) + #&NSFileHandleReadCompletionNotification + fh) + (#/readInBackgroundAndNotify fh))))) + new)) + +(objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller) + notification) + (with-slots (filehandle nextra translatebuf bufsize) self + (let* ((data (#/objectForKey: (#/userInfo notification) + #&NSFileHandleNotificationDataItem)) + (document (#/document self)) + (encoding (load-time-value (get-character-encoding :utf-8))) + (data-length (#/length data)) + (buffer (hemlock-document-buffer document)) + (n nextra) + (cursize bufsize) + (need (+ n data-length)) + (xlate translatebuf) + (fh filehandle)) + (when (> need cursize) + (let* ((new (#_malloc need))) + (dotimes (i n) (setf (%get-unsigned-byte new i) + (%get-unsigned-byte xlate i))) + (#_free xlate) + (setq xlate new translatebuf new bufsize need))) + #+debug (#_NSLog #@"got %d bytes of data" :int data-length) + (with-macptrs ((target (%inc-ptr xlate n))) + (#/getBytes:range: data target (ns:make-ns-range 0 data-length))) + (let* ((total (+ n data-length))) + (multiple-value-bind (nchars noctets-used) + (funcall (ccl::character-encoding-length-of-memory-encoding-function encoding) + xlate + total + 0) + (let* ((string (make-string nchars))) + (funcall (ccl::character-encoding-memory-decode-function encoding) + xlate + noctets-used + 0 + string) + (unless (zerop (setq n (- total noctets-used))) + ;; By definition, the number of untranslated octets + ;; can't be more than 3. + (dotimes (i n) + (setf (%get-unsigned-byte xlate i) + (%get-unsigned-byte xlate (+ noctets-used i))))) + (setq nextra n) + (hi::enqueue-buffer-operation + buffer + #'(lambda () + (unwind-protect + (progn + (hi::buffer-document-begin-editing buffer) + (hemlock::append-buffer-output buffer string)) + (hi::buffer-document-end-editing buffer)))) + (#/readInBackgroundAndNotify fh))))))) + + + +(objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller)) + (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self) + (call-next-method)) + +(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name) + (let* ((doc (#/document self))) + (if (or (%null-ptr-p doc) + (not (%null-ptr-p (#/fileURL doc)))) + (call-next-method name) + (let* ((buffer (hemlock-document-buffer doc)) + (bufname (if buffer (hi::buffer-name buffer)))) + (if bufname + (%make-nsstring bufname) + (call-next-method name)))))) + + +;;; The HemlockListenerDocument class. + + +(defclass hemlock-listener-document (hemlock-editor-document) + () + (:metaclass ns:+ns-object)) +(declaim (special hemlock-listener-document)) + +(defmethod update-buffer-package ((doc hemlock-listener-document) buffer) + (declare (ignore buffer))) + +(defmethod hi::document-encoding-name ((doc hemlock-listener-document)) + "UTF-8") + +(defmethod user-input-style ((doc hemlock-listener-document)) + hi::*listener-input-style*) + +(defmethod textview-background-color ((doc hemlock-listener-document)) + *listener-background-color*) + + +(defun hemlock::listener-document-send-string (document string) + (let* ((buffer (hemlock-document-buffer document)) + (process (if buffer (hi::buffer-process buffer)))) + (if process + (hi::send-string-to-listener-process process string)))) + + +(objc:defmethod #/topListener ((self +hemlock-listener-document)) + (let* ((all-documents (#/orderedDocuments *NSApp*))) + (dotimes (i (#/count all-documents) +null-ptr+) + (let* ((doc (#/objectAtIndex: all-documents i))) + (when (eql (#/class doc) self) + (return doc)))))) + +(defun symbol-value-in-top-listener-process (symbol) + (let* ((listenerdoc (#/topListener hemlock-listener-document)) + (buffer (unless (%null-ptr-p listenerdoc) + (hemlock-document-buffer listenerdoc))) + (process (if buffer (hi::buffer-process buffer)))) + (if process + (ignore-errors (symbol-value-in-process symbol process)) + (values nil t)))) + +(defun hi::top-listener-output-stream () + (let* ((doc (#/topListener hemlock-listener-document))) + (unless (%null-ptr-p doc) + (let* ((buffer (hemlock-document-buffer doc)) + (process (if buffer (hi::buffer-process buffer)))) + (when (typep process 'cocoa-listener-process) + (cocoa-listener-process-output-stream process)))))) + + + +(objc:defmethod (#/isDocumentEdited :) ((self hemlock-listener-document)) + nil) + + + +(objc:defmethod #/init ((self hemlock-listener-document)) + (let* ((doc (call-next-method))) + (unless (%null-ptr-p doc) + (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*)) + "Listener" + (format nil + "Listener-~d" *cocoa-listener-count*))) + (buffer (hemlock-document-buffer doc))) + (setf (hi::buffer-pathname buffer) nil + (hi::buffer-minor-mode buffer "Listener") t + (hi::buffer-name buffer) listener-name) + (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*))) + doc)) + +(def-cocoa-default *initial-listener-x-pos* :float -100.0f0 "X position of upper-left corner of initial listener") + +(def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener") + +(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized +(defloadvar *next-listener-y-pos* nil) ; likewise + +(objc:defmethod (#/close :void) ((self hemlock-listener-document)) + (if (zerop (decf *cocoa-listener-count*)) + (setq *next-listener-x-pos* nil + *next-listener-y-pos* nil)) + (call-next-method)) + +(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document)) + (let* ((textstorage (slot-value self 'textstorage)) + (window (%hemlock-frame-for-textstorage + hemlock-listener-frame + textstorage + *listener-columns* + *listener-rows* + t + (textview-background-color self) + (user-input-style self))) + (listener-styles (#/arrayWithObjects: ns:ns-mutable-array + (rme-create-text-attributes + :font *listener-input-font*) + (rme-create-text-attributes + :font *listener-output-font*) + +null-ptr+)) + (controller (make-instance + 'hemlock-listener-window-controller + :with-window window)) + (listener-name (hi::buffer-name (hemlock-document-buffer self)))) + (with-slots (styles) textstorage + ;; We probably should be more disciplined about + ;; Cocoa memory management. Having retain/release in + ;; random places all over the code is going to get + ;; unwieldy. + (#/release styles) + (setf styles (#/retain listener-styles))) + ;; Disabling background layout on listeners is an attempt to work + ;; around a bug. The bug's probably gone ... + (let* ((layout-managers (#/layoutManagers textstorage))) + (dotimes (i (#/count layout-managers)) + (let* ((layout (#/objectAtIndex: layout-managers i))) + (#/setBackgroundLayoutEnabled: layout nil)))) + (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self) + (#/addWindowController: self controller) + (#/release controller) + (ns:with-ns-point (current-point + (or *next-listener-x-pos* + (x-pos-for-window window *initial-listener-x-pos*)) + (or *next-listener-y-pos* + (y-pos-for-window window *initial-listener-y-pos*))) + (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point))) + (setf *next-listener-x-pos* (ns:ns-point-x new-point) + *next-listener-y-pos* (ns:ns-point-y new-point)))) + (setf (hi::buffer-process (hemlock-document-buffer self)) + (let* ((tty (slot-value controller 'clientfd)) + (peer-tty (#/fileDescriptor (slot-value controller 'filehandle)))) + (new-cocoa-listener-process listener-name tty tty peer-tty window (hemlock-document-buffer self)))) + controller)) + +(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :) + ((self hemlock-listener-document) + tv + (range :ange) + string) + (declare (ignore tv string)) + (let* ((range-start (ns:ns-range-location range)) + (range-end (+ range-start (ns:ns-range-length range))) + (buffer (hemlock-document-buffer self)) + (protected-region (hi::buffer-protected-region buffer))) + (if protected-region + (let* ((prot-start (mark-absolute-position (hi::region-start protected-region))) + (prot-end (mark-absolute-position (hi::region-end protected-region)))) + (not (or (and (>= range-start prot-start) + (< range-start prot-end)) + (and (>= range-end prot-start) + (< range-end prot-end))))) + t))) + + +;;; Action methods +(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender) + (declare (ignore sender)) + (let* ((buffer (hemlock-document-buffer self)) + (process (if buffer (hi::buffer-process buffer)))) + (when (typep process 'cocoa-listener-process) + (ccl::force-break-in-listener process)))) + + + +(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender) + (declare (ignore sender)) + (let* ((buffer (hemlock-document-buffer self)) + (process (if buffer (hi::buffer-process buffer)))) + (when (typep process 'cocoa-listener-process) + (process-interrupt process #'abort-break)))) + +(defmethod listener-backtrace-context ((proc cocoa-listener-process)) + (car (cocoa-listener-process-backtrace-contexts proc))) + +(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender) + (let* ((buffer (hemlock-document-buffer self)) + (process (if buffer (hi::buffer-process buffer)))) + (when (typep process 'cocoa-listener-process) + (let* ((context (listener-backtrace-context process))) + (when context + (#/showWindow: (backtrace-controller-for-context context) sender)))))) + +(defun restarts-controller-for-context (context) + (or (car (ccl::bt.restarts context)) + (setf (car (ccl::bt.restarts context)) + (let* ((tcr (ccl::bt.tcr context)) + (tsp-range (inspector::make-tsp-stack-range tcr context)) + (vsp-range (inspector::make-vsp-stack-range tcr context)) + (csp-range (inspector::make-csp-stack-range tcr context)) + (process (context-process context))) + (make-instance 'sequence-window-controller + :sequence (cdr (ccl::bt.restarts context)) + :result-callback #'(lambda (r) + (process-interrupt + process + #'invoke-restart-interactively + r)) + :display #'(lambda (item stream) + (let* ((ccl::*aux-vsp-ranges* vsp-range) + (ccl::*aux-tsp-ranges* tsp-range) + (ccl::*aux-csp-ranges* csp-range)) + (princ item stream))) + :title (format nil "Restarts for ~a(~d), break level ~d" + (process-name process) + (process-serial-number process) + (ccl::bt.break-level context))))))) + +(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender) + (let* ((buffer (hemlock-document-buffer self)) + (process (if buffer (hi::buffer-process buffer)))) + (when (typep process 'cocoa-listener-process) + (let* ((context (listener-backtrace-context process))) + (when context + (#/showWindow: (restarts-controller-for-context context) sender)))))) + +(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender) + (declare (ignore sender)) + (let* ((buffer (hemlock-document-buffer self)) + (process (if buffer (hi::buffer-process buffer)))) + (when (typep process 'cocoa-listener-process) + (let* ((context (listener-backtrace-context process))) + (when context + (process-interrupt process #'invoke-restart-interactively 'continue)))))) + + + + + + +;;; Menu item action validation. It'd be nice if we could distribute this a +;;; bit better, so that this method didn't have to change whenever a new +;;; action was implemented in this class. For now, we have to do so. + +(defmethod document-validate-menu-item ((doc hemlock-listener-document) item) + ;; Return two values: the first is true if the second is definitive. + ;; So far, all actions demand that there be an underlying process, so + ;; check for that first. + (let* ((buffer (hemlock-document-buffer doc)) + (process (if buffer (hi::buffer-process buffer)))) + (if (typep process 'cocoa-listener-process) + (let* ((action (#/action item))) + (cond + ((or (eql action (@selector #/revertDocumentToSaved:)) + (eql action (@selector #/saveDocument:)) + (eql action (@selector #/saveDocumentAs:))) + (values t nil)) + ((eql action (@selector #/interrupt:)) (values t t)) + ((eql action (@selector #/continue:)) + (let* ((context (listener-backtrace-context process))) + (values + t + (and context + (find 'continue (cdr (ccl::bt.restarts context)) + :key #'restart-name))))) + ((or (eql action (@selector #/backtrace:)) + (eql action (@selector #/exitBreak:)) + (eql action (@selector #/restarts:))) + (values t + (not (null (listener-backtrace-context process))))))) + (values nil nil)))) + +(objc:defmethod (#/validateMenuItem: :) + ((self hemlock-listener-document) item) + (multiple-value-bind (have-opinion opinion) + (document-validate-menu-item self item) + (if have-opinion + opinion + (call-next-method item)))) + +(defun shortest-package-name (package) + (let* ((name (package-name package)) + (len (length name))) + (dolist (nick (package-nicknames package) name) + (let* ((nicklen (length nick))) + (if (< nicklen len) + (setq name nick len nicklen)))))) + +(defmethod ui-object-note-package ((app ns:ns-application) package) + (with-autorelease-pool + (process-interrupt *cocoa-event-process* + #'(lambda (proc name) + (dolist (buf hi::*buffer-list*) + (when (eq proc (hi::buffer-process buf)) + (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))) + *current-process* + (shortest-package-name package)))) + +;;; This is basically used to provide INPUT to the listener process, by +;;; writing to an fd which is conntected to that process's standard +;;; input. +(defmethod hi::send-string-to-listener-process ((process cocoa-listener-process) + string &key path package) + (let* ((stream (cocoa-listener-process-input-peer-stream process))) + (labels ((out-raw-char (ch) + (write-char ch stream)) + (out-ch (ch) + (when (or (eql ch #\^v) + (eql ch #\^p) + (eql ch #\newline) + (eql ch #\^q) + (eql ch #\^d)) + (out-raw-char #\^q)) + (out-raw-char ch)) + (out-string (s) + (dotimes (i (length s)) + (out-ch (char s i))))) + (out-raw-char #\^p) + (when package (out-string package)) + (out-raw-char #\newline) + (out-raw-char #\^v) + (when path (out-string path)) + (out-raw-char #\newline) + (out-string string) + (out-raw-char #\^d) + (force-output stream)))) + + +(defun hemlock::evaluate-input-selection (selection) + (ccl::application-ui-operation *application* :eval-selection selection)) + +(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application) + selection) + (declare (ignore selection)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + (#/delegate *NSApp*) (@selector #/ensureListener:) +null-ptr+ #$YES) + (let* ((top-listener-document (#/topListener hemlock-listener-document))) + (if top-listener-document + (let* ((buffer (hemlock-document-buffer top-listener-document))) + (if buffer + (let* ((proc (hi::buffer-process buffer))) + (if (typep proc 'cocoa-listener-process) + proc))))))) + +(defmethod ui-object-eval-selection ((app ns:ns-application) + selection) + (let* ((target-listener (ui-object-choose-listener-for-selection + app selection))) + (if (typep target-listener 'cocoa-listener-process) + (destructuring-bind (package path string) selection + (hi::send-string-to-listener-process target-listener string :package package :path path))))) + +(defmethod ui-object-load-buffer ((app ns:ns-application) selection) + (let* ((target-listener (ui-object-choose-listener-for-selection app nil))) + (if (typep target-listener 'cocoa-listener-process) + (destructuring-bind (package path) selection + (let ((string (format nil "(load ~S)" path))) + (hi::send-string-to-listener-process target-listener string :package package :path path)))))) + +(defmethod ui-object-compile-buffer ((app ns:ns-application) selection) + (let* ((target-listener (ui-object-choose-listener-for-selection app nil))) + (if (typep target-listener 'cocoa-listener-process) + (destructuring-bind (package path) selection + (let ((string (format nil "(compile-file ~S)" path))) + (hi::send-string-to-listener-process target-listener string :package package :path path)))))) + +(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection) + (let* ((target-listener (ui-object-choose-listener-for-selection app nil))) + (if (typep target-listener 'cocoa-listener-process) + (destructuring-bind (package path) selection + (let ((string (format nil "(progn (compile-file ~S)(load ~S))" + path + (make-pathname :directory (pathname-directory path) + :name (pathname-name path) + :type (pathname-type path))))) + (hi::send-string-to-listener-process target-listener string :package package :path path)))))) + + + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-prefs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-prefs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-prefs.lisp (revision 8058) @@ -0,0 +1,192 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2004 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "GUI") + +(defloadvar *lisp-preferences-panel* nil) + +(defclass lisp-preferences-panel (ns:ns-panel) + () + (:metaclass ns:+ns-object)) + +(defclass font-name-transformer (ns:ns-value-transformer) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod #/transformedNameClass ((self +font-name-transformer)) + ns:ns-string) + + +(objc:defmethod (#/allowsReverseTransformation :) + ((self +font-name-transformer)) + nil) + +(objc:defmethod #/transformValue ((self font-name-transformer) value) + ;; Is there any better way of doing this that doesn't involve + ;; making a font ? + (#/displayName (make-instance ns:ns-font + :with-name value + :size (cgfloat 12.0)))) + + + +(defclass lisp-preferences-window-controller (ns:ns-window-controller) + () + (:metaclass ns:+ns-object)) +(declaim (special lisp-preferences-window-controller)) + +(objc:defmethod (#/fontPanelForDefaultFont: :void) + ((self lisp-preferences-window-controller) sender) + (let* ((fm (#/sharedFontManager ns:ns-font-manager))) + (#/setSelectedFont:isMultiple: fm (default-font) nil) + (#/setEnabled: fm t) + (#/setTarget: fm self) + (#/setAction: fm (@selector #/changeDefaultFont:))) + (#/orderFrontFontPanel: *NSApp* sender)) + + +(objc:defmethod (#/fontPanelForModelineFont: :void) + ((self lisp-preferences-window-controller) sender) + (declare (special *modeline-font-name* *modeline-font-size*)) + (let* ((fm (#/sharedFontManager ns:ns-font-manager))) + (#/setSelectedFont:isMultiple: fm (default-font + :name *modeline-font-name* + :size *modeline-font-size*) + nil) + (#/setTarget: fm self) + (#/setAction: fm (@selector #/changeModelineFont:))) + (#/orderFrontFontPanel: *NSApp* sender)) + + +(objc:defmethod (#/changeDefaultFont: :void) ((self lisp-preferences-window-controller) sender) + (let* ((f (#/convertFont: sender (default-font)))) + (when (is-fixed-pitch-font f) + (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) + (#/setValue:forKey: values (#/fontName f) #@"defaultFontName") + (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"defaultFontSize"))))) + +(objc:defmethod (#/changeModelineFont: :void) ((self lisp-preferences-window-controller) sender) + (declare (special *modeline-font-name* *modeline-font-size*)) + (let* ((f (#/convertFont: sender (default-font + :name *modeline-font-name* + :size *modeline-font-size*)))) + (when (is-fixed-pitch-font f) + (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) + (#/setValue:forKey: values (#/fontName f) #@"modelineFontName") + (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"modelineFontSize"))))) + + +(objc:defmethod (#/changeColor: :void) ((self lisp-preferences-panel) + sender) + (declare (ignore sender))) + + +(objc:defmethod (#/selectHyperspecFileURL: :void) + ((self lisp-preferences-window-controller) + sender) + (declare (ignore sender)) + (let* ((panel (make-instance 'ns:ns-open-panel)) + (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) + (#/setAllowsMultipleSelection: panel nil) + (#/setCanChooseDirectories: panel t) + (#/setCanChooseFiles: panel nil) + (when (eql + (#/runModalForDirectory:file:types: + panel + (#/valueForKey: values #@"hyperspecFileURLString") + +null-ptr+ + +null-ptr+) + #$NSOKButton) + (let* ((filename (#/objectAtIndex: (#/filenames panel) 0))) + (#/setValue:forKey: values filename #@"hyperspecFileURLString"))))) + +(objc:defmethod (#/selectCCLdirectory: :void) + ((self lisp-preferences-window-controller) + sender) + (declare (ignore sender)) + (let* ((panel (make-instance 'ns:ns-open-panel)) + (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))) + (#/setAllowsMultipleSelection: panel nil) + (#/setCanChooseDirectories: panel t) + (#/setCanChooseFiles: panel nil) + (when (eql + (#/runModalForDirectory:file:types: + panel + (#/valueForKey: values #@"cclDirectory") + +null-ptr+ + +null-ptr+) + #$NSOKButton) + ;; #/stringByStandardizingPath seems to strip trailing slashes + (let* ((filename (#/stringByAppendingString: + (#/stringByStandardizingPath (#/objectAtIndex: (#/filenames panel) 0)) + #@"/"))) + (#/setValue:forKey: values filename #@"cclDirectory"))))) + + + +(objc:defmethod #/sharedPanel ((self +lisp-preferences-panel)) + (cond (*lisp-preferences-panel*) + (t + (let* ((domain (#/standardUserDefaults ns:ns-user-defaults)) + (initial-values (cocoa-defaults-initial-values))) + (#/registerDefaults: domain initial-values) + (update-cocoa-defaults) + (#/setValueTransformer:forName: + ns:ns-value-transformer + (make-instance 'font-name-transformer) + #@"FontNameTransformer") + (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller))) + (#/setAppliesImmediately: sdc nil) + (#/setInitialValues: sdc initial-values) + (let* ((controller (make-instance lisp-preferences-window-controller + :with-window-nib-name #@"preferences")) + (window (#/window controller))) + (unless (%null-ptr-p window) + (#/setFloatingPanel: window t) + (#/addObserver:selector:name:object: + (#/defaultCenter ns:ns-notification-center) + controller + (@selector #/defaultsChanged:) + #&NSUserDefaultsDidChangeNotification + (#/standardUserDefaults ns:ns-user-defaults)) + (setq *lisp-preferences-panel* window)))))))) + + +(objc:defmethod #/init ((self lisp-preferences-panel)) + (let* ((class (class-of self))) + (#/dealloc self) + (#/sharedPanel class))) + + +(objc:defmethod (#/makeKeyAndOrderFront: :void) + ((self lisp-preferences-panel) sender) + (let* ((color-panel (#/sharedColorPanel ns:ns-color-panel))) + (#/close color-panel) + (#/setAction: color-panel +null-ptr+) + (#/setShowsAlpha: color-panel t)) + (call-next-method sender)) + +(objc:defmethod (#/show :void) ((self lisp-preferences-panel)) + (#/makeKeyAndOrderFront: self +null-ptr+)) + +(objc:defmethod (#/defaultsChanged: :void) + ((self lisp-preferences-window-controller) + notification) + (declare (ignore notification)) + (update-cocoa-defaults)) + + + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-typeout.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-typeout.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-typeout.lisp (revision 8058) @@ -0,0 +1,193 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +;; +;; a typeout window is just an ns-window containing a scroll-view +;; which contains a text-view. The text is read only. +;; +;; the window is implicitly bound to a stream, and text written to +;; the stream is written into the text-view object. The stream is +;; available via the function (gui::typeout-stream) +;; + +;; @class typeout-view +;; +(defclass typeout-view (ns:ns-view) + ((scroll-view :foreign-type :id :reader typeout-view-scroll-view) + (text-view :foreign-type :id :reader typeout-view-text-view)) + (:metaclass ns:+ns-object)) +(declaim (special typeout-view)) + +(defclass typeout-text-view (ns:ns-text-view) + () + (:metaclass ns:+ns-object)) +(declaim (special typeout-text-view)) + +(objc:defmethod (#/clearAll: :void) ((self typeout-text-view)) + (#/selectAll: self +null-ptr+) + (#/delete: self +null-ptr+)) + +(objc:defmethod (#/insertString: :void) ((self typeout-text-view) text) + (#/setEditable: self t) + (#/insertText: self text) + (#/setEditable: self nil)) + + +(objc:defmethod #/initWithFrame: ((self typeout-view) (frame :ect)) + (call-next-method frame) + (let* ((scrollview (make-instance 'ns:ns-scroll-view + :with-frame frame)) + (scroll-content (#/contentView scrollview))) + (#/setBorderType: scrollview #$NSBezelBorder) + (#/setHasVerticalScroller: scrollview t) + (#/setHasHorizontalScroller: scrollview t) + (#/setRulersVisible: scrollview nil) + (#/setAutoresizingMask: scrollview (logior #$NSViewWidthSizable #$NSViewHeightSizable)) + (#/setAutoresizesSubviews: scroll-content t) + (#/addSubview: self scrollview) + (setf (slot-value self 'scroll-view) scrollview) + (let* ((contentsize (#/contentSize scrollview))) + (ns:with-ns-rect (text-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) + (let* ((text-view (make-instance 'typeout-text-view + :with-frame text-frame))) + (#/setEditable: text-view nil) + (#/setHorizontallyResizable: text-view t) + (#/setAutoresizingMask: text-view #$NSViewWidthSizable) + (#/setTypingAttributes: text-view (create-text-attributes + :font (default-font :name *default-font-name* :size *default-font-size*) + :line-break-mode :char)) + (#/setDocumentView: scrollview text-view) + (ns:with-ns-size (container-size 1.0f7 1.0f7) + (let* ((layout (#/layoutManager text-view)) + (container (make-instance 'ns:ns-text-container + :with-container-size container-size))) + (#/setWidthTracksTextView: container t) + (#/setHeightTracksTextView: container nil) + (#/addTextContainer: layout container))) + + (setf (slot-value self 'text-view) text-view))))) + self) + +;; +;; @class typeout-panel +;; +(defloadvar *typeout-window* nil) + +(defclass typeout-window (ns:ns-window) + ((typeout-view :foreign-type :id :accessor typeout-window-typeout-view)) + (:metaclass ns:+ns-object)) +(declaim (special typeout-window)) + +(defloadvar *typeout-windows* ()) +(defstatic *typeout-windows-lock* (make-lock)) + +(defun get-typeout-window (title) + (with-lock-grabbed (*typeout-windows-lock*) + (when *typeout-windows* + (let* ((w (pop *typeout-windows*))) + (set-window-title w title) + w)))) + +(objc:defmethod #/typeoutWindowWithTitle: ((self +typeout-window) title) + (let* ((panel (new-cocoa-window :class self + :title title + :width 600 + :activate nil))) + (#/setReleasedWhenClosed: panel nil) + (let* ((view (make-instance 'typeout-view :with-frame (#/bounds (#/contentView panel))))) + (#/setAutoresizingMask: view (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (#/setContentView: panel view) + (#/setNeedsDisplay: view t) + (setf (slot-value panel 'typeout-view) view) + panel))) + +(objc:defmethod #/sharedPanel ((self +typeout-window)) + (cond (*typeout-window*) + (t + (setq *typeout-window* (#/typeoutWindowWithTitle: self "Typeout"))))) + + + +(objc:defmethod (#/close :void) ((self typeout-window)) + (call-next-method) + (unless (eql self *typeout-window*) + (with-lock-grabbed (*typeout-windows-lock*) + (push (%inc-ptr self 0) *typeout-windows*)))) + + + +(objc:defmethod (#/show :void) ((self typeout-window)) + (#/makeKeyAndOrderFront: self +null-ptr+)) + + +(defclass typeout-stream (fundamental-character-output-stream) + ((string-stream :initform (make-string-output-stream)) + (window :initform (#/sharedPanel typeout-window) :initarg :window))) + +(defun prepare-typeout-stream (stream) + (declare (ignorable stream)) + (with-slots (window) stream + (#/show window))) + + + +;;; +;;; TYPEOUT-STREAM methods +;;; + +(defmethod stream-write-char ((stream typeout-stream) char) + (prepare-typeout-stream stream) + (write-char char (slot-value stream 'string-stream))) + +(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) + (prepare-typeout-stream stream) + (write-string (if (and (eql start 0) (or (null end) (eql end (length string)))) + string + (subseq string start end)) + (slot-value stream 'string-stream))) + + +(defmethod stream-fresh-line ((stream typeout-stream)) + (prepare-typeout-stream stream) + (fresh-line (slot-value stream 'string-stream))) + +(defmethod stream-line-column ((stream typeout-stream)) + (stream-line-column (slot-value stream 'string-stream))) + +(defmethod stream-clear-output ((stream typeout-stream)) + (prepare-typeout-stream stream) + (let* ((window (slot-value stream 'window)) + (the-typeout-view (typeout-window-typeout-view window)) + (text-view (slot-value the-typeout-view 'text-view)) + (string-stream (slot-value stream 'string-stream))) + (get-output-stream-string string-stream) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + text-view + (@selector #/clearAll:) + +null-ptr+ + t))) + +(defmethod stream-force-output ((stream typeout-stream)) + (let* ((window (slot-value stream 'window)) + (the-typeout-view (typeout-window-typeout-view window)) + (text-view (slot-value the-typeout-view 'text-view))) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + text-view + (@selector #/insertString:) + (%make-nsstring (get-output-stream-string (slot-value stream 'string-stream))) + t))) + + +(defloadvar *typeout-stream* nil) + +(defun typeout-stream (&optional title) + (if (null title) + (or *typeout-stream* + (setq *typeout-stream* (make-instance 'typeout-stream))) + (make-instance 'typeout-stream :window (#/typeoutWindowWithTitle: typeout-window (%make-nsstring (format nil "~a" title)))))) + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-utils.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-utils.lisp (revision 8058) @@ -0,0 +1,124 @@ +; -*- Mode: Lisp; Package: GUI; -*- + +(in-package "GUI") + +(defclass sequence-window-controller (ns:ns-window-controller) + ((table-view :foreign-type :id :reader sequence-window-controller-table-view) + (sequence :initform nil :initarg :sequence :type sequence :reader sequence-window-controller-sequence) + (result-callback :initarg :result-callback) + (display :initform #'(lambda (item stream) (prin1 item stream)) :initarg :display) + (title :initform "Sequence dialog" :initarg :title)) + (:metaclass ns:+ns-object)) + + +(objc:defmethod #/init ((self sequence-window-controller)) + (call-next-method) + (let* ((w (new-cocoa-window :activate nil)) + (contentview (#/contentView w)) + (contentframe (#/frame contentview)) + (scrollview (make-instance 'ns:ns-scroll-view :with-frame contentframe))) + (#/setWindow: self w) + (#/setDelegate: w self) + (#/setWindowController: w self) + (#/setHasVerticalScroller: scrollview t) + (#/setHasHorizontalScroller: scrollview t) + (#/setAutohidesScrollers: scrollview t) + (#/setRulersVisible: scrollview nil) + (#/setAutoresizingMask: scrollview (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (#/setAutoresizesSubviews: (#/contentView scrollview) t) + (let* ((table-view (make-instance 'ns:ns-table-view))) + (#/setDocumentView: scrollview table-view) + (#/release table-view) + (#/setColumnAutoresizingStyle: table-view #$NSTableViewUniformColumnAutoresizingStyle) + (setf (slot-value self 'table-view) table-view) + (let* ((column (make-instance 'ns:ns-table-column :with-identifier #@""))) + (#/setEditable: column nil) + (#/setResizingMask: column #$NSTableColumnAutoresizingMask) + (#/addTableColumn: table-view column) + (#/release column)) + (#/setAutoresizingMask: table-view (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (#/sizeToFit table-view) + (#/setDataSource: table-view self) + (#/setTarget: table-view self) + (#/setHeaderView: table-view +null-ptr+) + (#/setUsesAlternatingRowBackgroundColors: table-view t) + (#/setDoubleAction: table-view (@selector #/sequenceDoubleClick:)) + (#/addSubview: contentview scrollview) + (#/release scrollview) + self))) + +(objc:defmethod (#/dealloc :void) ((self sequence-window-controller)) + (call-next-method)) + +(objc:defmethod (#/windowWillClose: :void) ((self sequence-window-controller) + notification) + (declare (ignore notification)) + (#/autorelease self)) + +(objc:defmethod (#/sequenceDoubleClick: :void) + ((self sequence-window-controller) sender) + (let* ((n (#/clickedRow sender))) + (when (>= n 0) + (with-slots (sequence result-callback) self + (funcall result-callback (elt sequence n)))))) + +(objc:defmethod (#/numberOfRowsInTableView: :nteger) + ((self sequence-window-controller) view) + (declare (ignore view)) + (length (slot-value self 'sequence))) + + +(objc:defmethod #/tableView:objectValueForTableColumn:row: + ((self sequence-window-controller) view column (row :nteger)) + (declare (ignore column view)) + (with-slots (display sequence) self + (#/autorelease + (%make-nsstring (with-output-to-string (s) + (funcall display (elt sequence row) s)))))) + +(defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys) + (let* ((window (#/window self))) + (with-slots (title) self + (when title (#/setTitle: window (%make-nsstring title)))) + (#/reloadData (sequence-window-controller-table-view self)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + self + (@selector #/showWindow:) + +null-ptr+ + nil))) + +;;; Looks like a "util" to me ... +(defun pathname-to-url (pathname) + (make-instance 'ns:ns-url + :file-url-with-path + (%make-nsstring (native-translated-namestring pathname)))) + +(defun cgfloat (number) + (float number ccl::+cgfloat-zero+)) + +(defun color-values-to-nscolor (red green blue alpha) + (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color + (cgfloat red) + (cgfloat green) + (cgfloat blue) + (cgfloat alpha))) + +(defun windows () + (let* ((win-arr (#/orderedWindows *NSApp*)) + (ret nil)) + (dotimes (i (#/count win-arr)) + (push (#/objectAtIndex: win-arr i) ret)) + (nreverse ret))) + +(defun log-debug (format-string &rest args) + (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args)))) + +(defun assume-cocoa-thread () + #+debug (assert (eq *current-process* *initial-process*))) + +(defmethod assume-not-editing ((whatever t))) + Index: /branches/experimentation/later/source/cocoa-ide/cocoa-window.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa-window.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa-window.lisp (revision 8058) @@ -0,0 +1,387 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2002-2007 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "GUI") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-cocoa-default *default-font-name* :string "Courier" "Name of font to use in editor windows") + (def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT") + (def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters")) + +(defun init-cocoa-application () + (with-autorelease-pool + (#/standardUserDefaults ns:ns-user-defaults) + (let* ((bundle (open-main-bundle)) + (dict (#/infoDictionary bundle)) + (classname (#/objectForKey: dict #@"NSPrincipalClass")) + (mainnibname (#/objectForKey: dict #@"NSMainNibFile")) + (progname (#/objectForKey: dict #@"CFBundleName"))) + (if (%null-ptr-p classname) + (error "problems loading bundle: can't determine class name")) + (if (%null-ptr-p mainnibname) + (error "problems loading bundle: can't determine main nib name")) + (unless (%null-ptr-p progname) + (#/setProcessName: (#/processInfo ns:ns-process-info) progname)) + (let* ((appclass (#_NSClassFromString classname)) + (app (#/sharedApplication appclass))) + (#/loadNibNamed:owner: ns:ns-bundle mainnibname app) + app)))) + + + +#+apple-objc +(defun trace-dps-events (flag) + (external-call "__DPSSetEventsTraced" + :unsigned-byte (if flag #$YES #$NO) + :void)) + +(defstatic *appkit-process-interrupt-ids* (make-id-map)) +(defun register-appkit-process-interrupt (thunk) + (assign-id-map-id *appkit-process-interrupt-ids* thunk)) +(defun appkit-interrupt-function (id) + (id-map-free-object *appkit-process-interrupt-ids* id)) + +(defclass appkit-process (process) ()) + +(defconstant process-interrupt-event-subtype 17) + + + + +(defclass lisp-application (ns:ns-application) + ((termp :foreign-type :)) + (:metaclass ns:+ns-object)) + + +(objc:defmethod (#/postEventAtStart: :void) ((self ns:ns-application) e) + (#/postEvent:atStart: self e t)) + +;;; Interrupt the AppKit event process, by enqueing an event (if the +;;; application event loop seems to be running.) It's possible that +;;; the event loop will stop after the calling thread checks; in that +;;; case, the application's probably already in the process of +;;; exiting, and isn't that different from the case where asynchronous +;;; interrupts are used. An attribute of the event is used to identify +;;; the thunk which the event handler needs to funcall. +(defmethod process-interrupt ((process appkit-process) function &rest args) + (if (eq process *current-process*) + (apply function args) + (if (or (not *NSApp*) (not (#/isRunning *NSApp*))) + (call-next-method) + (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2: + ns:ns-event + #$NSApplicationDefined + (ns:make-ns-point 0 0) + 0 + 0.0d0 + 0 + +null-ptr+ + process-interrupt-event-subtype + (register-appkit-process-interrupt + #'(lambda () (apply function args))) 0))) + (#/retain e) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + *NSApp* (@selector "postEventAtStart:") e t))))) + + +(defparameter *debug-in-event-process* t) + +(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.") + +(defmethod ccl::process-debug-condition ((process appkit-process) condition frame-pointer) + "Better than nothing. Not much better." + (when *debug-in-event-process* + (let* ((c (if (typep condition 'ccl::ns-lisp-exception) + (ccl::ns-lisp-exception-condition condition) + condition))) + (unless (member c *event-process-reported-conditions*) + (push c *event-process-reported-conditions*) + (catch 'need-a-catch-frame-for-backtrace + (let* ((*debug-in-event-process* nil) + (context (ccl::new-backtrace-info nil + frame-pointer + (if ccl::*backtrace-contexts* + (or (ccl::child-frame + (ccl::bt.youngest (car ccl::*backtrace-contexts*)) + nil) + (ccl::last-frame-ptr)) + (ccl::last-frame-ptr)) + (ccl::%current-tcr) + condition + (ccl::%current-frame-ptr) + #+ppc-target ccl::*fake-stack-frames* + #+x86-target (ccl::%current-frame-ptr) + (ccl::db-link) + (1+ ccl::*break-level*))) + (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) + (format t "~%~%*** Error in event process: ~a~%~%" condition) + (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer) + (format t "~%~%~%") + (force-output t) + )))))) + + +(defloadvar *default-ns-application-proxy-class-name* + "LispApplicationDelegate") + + +#+apple-objc +(defun enable-foreground () + (rlet ((psn :

rocesserialumber)) + (#_GetCurrentProcess psn) + (#_TransformProcessType psn #$kProcessTransformToForegroundApplication) + (eql 0 (#_SetFrontProcess psn)))) + +;;; I'm not sure if there's another way to recognize events whose +;;; type is #$NSApplicationDefined. +(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e) + (if (and (eql (#/type e) #$NSApplicationDefined) + (eql (#/subtype e) process-interrupt-event-subtype)) + ;;; The thunk to funcall is identified by the value + ;;; of the event's data1 attribute. + (funcall (appkit-interrupt-function (#/data1 e))) + (call-next-method e))) + +#+nil +(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender) + (declare (ignore sender)) + (#/show (#/sharedPanel lisp-preferences-panel))) + +(objc:defmethod (#/toggleTypeout: :void) ((self lisp-application) sender) + (declare (ignore sender)) + (#/show (#/sharedPanel typeout-window))) + +(defun nslog-condition (c) + (let* ((rep (format nil "~a" c))) + (with-cstrs ((str rep)) + (with-nsstr (nsstr str (length rep)) + (#_NSLog #@"Error in event loop: %@" :address nsstr))))) + + +(defmethod ccl::process-exit-application ((process appkit-process) thunk) + (when (eq process ccl::*initial-process*) + (%set-toplevel thunk) + (#/terminate: *NSApp* +null-ptr+))) + +(defun run-event-loop () + (%set-toplevel nil) + (change-class *cocoa-event-process* 'appkit-process) + (let* ((app *NSApp*)) + (loop + (handler-case (let* ((*event-process-reported-conditions* nil)) + (#/run app)) + (error (c) (nslog-condition c))) + (unless (#/isRunning app) + (return))))) + + + +(defun start-cocoa-application (&key + (application-proxy-class-name + *default-ns-application-proxy-class-name*)) + + (flet ((cocoa-startup () + ;; Start up a thread to run periodic tasks. + (process-run-function "housekeeping" + #'(lambda () + (loop + (ccl::%nanosleep ccl::*periodic-task-seconds* + ccl::*periodic-task-nanoseconds*) + (ccl::housekeeping)))) + + (with-autorelease-pool + (enable-foreground) + (or *NSApp* (setq *NSApp* (init-cocoa-application))) + (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon"))) + (unless (%null-ptr-p icon) + (#/setApplicationIconImage: *NSApp* icon))) + (setf (ccl::application-ui-object *application*) *NSApp*) + (when application-proxy-class-name + (let* ((classptr (ccl::%objc-class-classptr + (ccl::load-objc-class-descriptor application-proxy-class-name))) + (instance (#/init (#/alloc classptr)))) + + (#/setDelegate: *NSApp* instance)))) + (run-event-loop))) + (process-interrupt *cocoa-event-process* #'(lambda () + (%set-toplevel + #'cocoa-startup) + (toplevel))))) + +(defparameter *font-attribute-names* + '((:bold . #.#$NSBoldFontMask) + (:italic . #.#$NSItalicFontMask) + (:small-caps . #.#$NSSmallCapsFontMask))) + + +;;; The NSFont method #/isFixedPitch has returned random answers +;;; in many cases for the last few OSX releases. Try to return +;;; a reasonable answer, by checking to see if the width of the +;;; advancement for the #\i glyph matches that of the advancement +;;; of the #\m glyph. + +(defun is-fixed-pitch-font (font) + (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i"))) + (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m"))))) + +;;; Try to find the specified font. If it doesn't exist (or isn't +;;; fixed-pitch), try to find a fixed-pitch font of the indicated size. +(defun default-font (&key (name *default-font-name*) + (size *default-font-size*) + (attributes ())) + + (setq size (cgfloat size)) + (with-cstrs ((name name)) + (with-autorelease-pool + (rletz ((matrix (:array :loat 6))) + (setf (paref matrix (:* :loat) 0) size + (paref matrix (:* :loat) 3) size) + (let* ((fontname (#/stringWithCString: ns:ns-string name)) + (font (#/fontWithName:matrix: ns:ns-font fontname matrix)) + + (implemented-attributes ())) + (if (or (%null-ptr-p font) + (and + (not (is-fixed-pitch-font font)))) + (setq font (#/userFixedPitchFontOfSize: ns:ns-font size))) + (when attributes + (dolist (attr-name attributes) + (let* ((pair (assoc attr-name *font-attribute-names*)) + (newfont)) + (when pair + (setq newfont + (#/convertFont:toHaveTrait: + (#/sharedFontManager ns:ns-font-manager) font (cdr pair))) + (unless (eql font newfont) + (setq font newfont) + (push attr-name implemented-attributes)))))) + (values (#/retain font) implemented-attributes)))))) + + +;;; Create a paragraph style, mostly so that we can set tabs reasonably. +(defun create-paragraph-style (font line-break-mode) + (let* ((p (make-instance 'ns:ns-mutable-paragraph-style)) + (charwidth (fround (nth-value 1 (size-of-char-in-font font))))) + (#/setLineBreakMode: p + (ecase line-break-mode + (:char #$NSLineBreakByCharWrapping) + (:word #$NSLineBreakByWordWrapping) + ;; This doesn't seem to work too well. + ((nil) #$NSLineBreakByClipping))) + ;; Clear existing tab stops. + (#/setTabStops: p (#/array ns:ns-array)) + ;; And set the "default tab interval". + (#/setDefaultTabInterval: p (cgfloat (* *tab-width* charwidth))) + p)) + +(defun create-text-attributes (&key (font (default-font)) + (line-break-mode :char) + (color nil) + (obliqueness nil) + (stroke-width nil)) + (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5))) + (#/setObject:forKey: dict (create-paragraph-style font line-break-mode) + #&NSParagraphStyleAttributeName) + (#/setObject:forKey: dict font #&NSFontAttributeName) + (when color + (#/setObject:forKey: dict color #&NSForegroundColorAttributeName)) + (when stroke-width + (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width) + #&NSStrokeWidthAttributeName)) + (when obliqueness + (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness) + #&NSObliquenessAttributeName)) + dict)) + + +(defun get-cocoa-window-flag (w flagname) + (case flagname + (:accepts-mouse-moved-events + (#/acceptsMouseMovedEvents w)) + (:cursor-rects-enabled + (#/areCursorRectsEnabled w)) + (:auto-display + (#/isAutodisplay w)))) + + + +(defun (setf get-cocoa-window-flag) (value w flagname) + (case flagname + (:accepts-mouse-moved-events + (#/setAcceptsMouseMovedEvents: w value)) + (:auto-display + (#/setAutodisplay: w value)))) + + + +(defun activate-window (w) + ;; Make w the "key" and frontmost window. Make it visible, if need be. + (#/makeKeyAndOrderFront: w nil)) + +(defun set-window-title (window title) + (#/setTitle: window (if title + (if (typep title 'ns:ns-string) + title + (%make-nsstring title)) + #@"") )) + +(defun new-cocoa-window (&key + (class (find-class 'ns:ns-window)) + (title nil) + (x 200.0) + (y 200.0) + (height 200.0) + (width 500.0) + (closable t) + (iconifyable t) + (metal nil) + (expandable t) + (backing :buffered) + (defer t) + (accepts-mouse-moved-events nil) + (auto-display t) + (activate t)) + (ns:with-ns-rect (frame x y width height) + (let* ((stylemask + (logior #$NSTitledWindowMask + (if closable #$NSClosableWindowMask 0) + (if iconifyable #$NSMiniaturizableWindowMask 0) + (if expandable #$NSResizableWindowMask 0) + (if metal #$NSTexturedBackgroundWindowMask 0))) + (backing-type + (ecase backing + ((t :retained) #$NSBackingStoreRetained) + ((nil :nonretained) #$NSBackingStoreNonretained) + (:buffered #$NSBackingStoreBuffered))) + (w (make-instance + class + :with-content-rect frame + :style-mask stylemask + :backing backing-type + :defer defer))) + (setf (get-cocoa-window-flag w :accepts-mouse-moved-events) + accepts-mouse-moved-events + (get-cocoa-window-flag w :auto-display) + auto-display) + (#/setBackgroundColor: w (#/whiteColor ns:ns-color)) + (when activate (activate-window w)) + (when title (set-window-title w title)) + w))) + + + + Index: /branches/experimentation/later/source/cocoa-ide/cocoa.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/cocoa.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/cocoa.lisp (revision 8058) @@ -0,0 +1,6 @@ +(in-package "CCL") + +(defvar *cocoa-application-path* "ccl:temp bundle.app;") +(defvar *cocoa-application-copy-headers-p* nil) +(load "ccl:cocoa-ide;defsystem.lisp") +(load-ide) Index: /branches/experimentation/later/source/cocoa-ide/compile-hemlock.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/compile-hemlock.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/compile-hemlock.lisp (revision 8058) @@ -0,0 +1,108 @@ +(in-package "CCL") + +(defparameter *hemlock-src-dir-pathname* "ccl:cocoa-ide;hemlock;src;") + +(defparameter *hemlock-binary-dir-pathname* "ccl:cocoa-ide;hemlock;bin;openmcl;") + +(defparameter *hemlock-binary-file-extension* + (pathname-type (compile-file-pathname "foo.lisp"))) + +(defun hemlock-source-pathname (name) + (make-pathname :name name + :type "lisp" + :defaults *hemlock-src-dir-pathname*)) + +(defun hemlock-binary-pathname (name) + (make-pathname :name name + :type *hemlock-binary-file-extension* + :defaults *hemlock-binary-dir-pathname*)) + +(defun compile-and-load-hemlock-file (name &optional force) + (let* ((source-pathname (hemlock-source-pathname name)) + (binary-pathname (hemlock-binary-pathname name))) + (when (or force + (not (probe-file binary-pathname)) + (> (file-write-date source-pathname) + (file-write-date binary-pathname))) + (compile-file source-pathname :output-file binary-pathname :verbose t)) + (load binary-pathname :verbose t))) + + +(defparameter *hemlock-files* + '("package" + + ;; Lisp implementation specific stuff goes into one of + ;; the next two files. + "lispdep" + "hemlock-ext" + + "decls" ;early declarations of functions and stuff + + "struct" + "charmacs" + "key-event" + "keysym-defs" + "cocoa-hemlock" + "rompsite" + + "macros" + "line" + "ring" + "vars" + "interp" + "syntax" + "htext1" + "buffer" + "htext2" + "htext3" + "htext4" + "files" + "search1" + "search2" + "table" + "modeline" + "linimage" + "pop-up-stream" + "cursor" + "font" + "streams" + "main" + "echo" + "echocoms" + "command" + "indent" + ;; moved "comments" + "morecoms" + "undo" + "killcoms" + "searchcoms" + "filecoms" + "doccoms" + "fill" + "text" + "lispmode" + "listener" + "comments" + "icom" + "kbdmac" + "defsyn" + "edit-defs" + "register" + "completion" + "symbol-completion" + "bindings" + "bindings-gb" ;Gilbert's bindings + )) + +(defun compile-hemlock (&optional force) + (with-compilation-unit () + (dolist (name *hemlock-files*) + (compile-and-load-hemlock-file name force))) + (fasl-concatenate "ccl:cocoa-ide;hemlock" + (mapcar #'hemlock-binary-pathname *hemlock-files*) + :if-exists :supersede) + (provide "HEMLOCK") + ) + + +(provide "COMPILE-HEMLOCK") Index: /branches/experimentation/later/source/cocoa-ide/defsystem.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/defsystem.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/defsystem.lisp (revision 8058) @@ -0,0 +1,107 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2007 Clozure Associates +;;; + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :cocoa)) + +;; These are used to communicate with ide-bundle, which must be loaded before objc-support. +;; They are defvar'ed so the caller can set them before loading us. +(defvar *cocoa-application-path* nil) +(defvar *cocoa-application-copy-headers-p* nil) +(require "IDE-BUNDLE") + +(require "OBJC-SUPPORT") + +(require "PTY") + + +(defpackage "GUI" + (:use :common-lisp :ccl) + (:import-from + "CCL" + ;; symbols defined here + *cocoa-application-path* + *cocoa-application-copy-headers-p* + load-ide + build-ide + ;; Misc symbols that perhaps should be exported from CCL but currently aren't. + report-bad-arg + native-translated-namestring + make-id-map + assign-id-map-id + id-map-free-object + process-thread + process-serial-number + ensure-directory-pathname + recursive-copy-directory + application + ;; Symbols that perhaps should be exported by ObjC support but aren't + @selector + *nsapp* + with-nsstr + %make-nsstring + lisp-string-from-nsstring + with-autorelease-pool + ns-height + ns-width + *cocoa-event-process* + create-autorelease-pool + release-autorelease-pool + release-canonical-nsobject + objc-message-send + open-main-bundle + ;; Symbols perhaps that should be exported by library;pty.lisp but aren't + open-pty-pair + set-tty-raw + ) + (:export + )) + +(defparameter *ide-files* + '(;"ide-bundle" - loaded by hand above + "cocoa-utils" + "cocoa-defaults" + "cocoa-prefs" + "cocoa-typeout" + "cocoa-window" + "cocoa-doc" + "compile-hemlock" + "hemlock" ;; treated specially below, compile-hemlock must come before. + "cocoa-editor" + "cocoa-listener" + "cocoa-grep" + "cocoa-backtrace" + "cocoa-inspector" + "preferences" + "processes-window" + "apropos-window" + "app-delegate" + "start" + )) + +(defun load-ide (&optional force-compile) + (declare (special *hemlock-files*)) ;; kludge + (let ((src-dir "ccl:cocoa-ide;") + (bin-dir "ccl:cocoa-ide;fasls;")) + (ensure-directories-exist bin-dir) + (with-compilation-unit () + (dolist (name *ide-files*) + (let* ((source (make-pathname :name name :type (pathname-type *.lisp-pathname*) + :defaults src-dir)) + (fasl (make-pathname :name name :type (pathname-type *.fasl-pathname*) + :defaults bin-dir)) + (sources (cons source + (and (equalp name "hemlock") + ;; This is defined in compile-hemlock, which is loaded first + (mapcar #'hemlock-source-pathname *hemlock-files*))))) + (if (needs-compile-p fasl sources force-compile) + (progn + ;; Once compile something, keep compiling, in case macros changed. + (setq force-compile t) + (compile-file source :output-file fasl :verbose t :load t)) + (load fasl :verbose t))))) + (provide "COCOA"))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock.lisp (revision 8058) @@ -0,0 +1,9 @@ +;;;-*- Mode: LISP; Package: CCL -*- + +(in-package "CCL") + +(require "COMPILE-HEMLOCK") + +(format t "~&;;; Compiling Hemlock ...") + +(compile-hemlock t) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/INSTALL =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/INSTALL (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/INSTALL (revision 8058) @@ -0,0 +1,16 @@ + INSTALLATION NOTES + +Phemlock comes with a mk:defsystem style .system file. So when you are +lucky you just can fire up your Lisp and say + + (oos :hemlock :load) + + (hemlock) + +This was tested with: + + - CMUCL + - ACL + - CLISP using MIT CLX + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/README =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/README (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/README (revision 8058) @@ -0,0 +1,98 @@ + Phemlock + The Portable Hemlock + +Please see: + + http://www.stud.uni-karlsruhe.de/~unk6/hemlock/ + +This is an attempt to free Hemlock from its CMUCL prison. In the long +run I want to be able to run Hemlock on any system which supports ANSI +Common Lisp and CLIM. + +The source code of Hemlock showed unportability (or better its age) in +the following areas: + + - Buffers sometimes also serve as streams. As Hemlock was written + there was no universal de-facto standard interface for user defined + streams and the source code defined CMUCL streams. These days we + have Gray streams. + + - File I/O was tied to both CMUCL and Unix and probably slow + machines. The file i/o functions directly called unix-read and + unix-write and beam data direcly to and fro system areas. I changed + that using standard CL functions doing i/o on a line-by-line basis + now. + + - The TTY interface is inherently unportable. Currently it is + disabled altogether. I think we could reclaim some useful code from + Hemlock's TTY interface and morph it into a CLIM TTY port. And + since my screen cannot even display a text console interface, this + has very low priority on my list, though other people might want to + have it. + + - The X11 interface uses the SERVE-EVENT facility of CMUCL, which + naturally is only available there. I provided a thin portability + layer to provide the same API using just the standard CLX + interface. + +This already summaries pretty well the current state of Phemlock. You +can edit files using the X11 interface on an ANSI CL which provides +for CLX. + + +FUTURE + +The next steps I have in mind are: + + - Port the missing files except the TTY interface. + + - Hemlock has the idea that characters are 8-bit wide. We need to + teach it otherwise as we have Unicode strings now. This involves + syntax tables and probably searching. + + - I want a CLIM Hemlock. + + How exactly to do this is still not decided. I see two + possibilities: + + . Hemlock already provides for a kind of device interface. We can + implement a new device which is just a CLIM device. + + . Or we rip this device abstraction layer and state that CLIM + itself is the device layer. (Making the bet that we'll have a TTY + CLIM in the future). + +After that is done, we can talk about extending Phemlock in various +ways like syntax highlighting, color, new modes, ... + + +RANDOM NOTES + +. Hemlock has this feature of so called buffered lines; from the + documentation in line.lisp: + + ;; A buffered line: + ;; The line hasn't been touched since it was read from a file, and the + ;; actual contents are in some system I/O area. This is indicated by + ;; the Line-Buffered-P slot being true. In buffered lines on the RT, + ;; the %Chars slot contains the system-area-pointer to the beginning + ;; of the characters. + + This sounds like a good idea actually. Though it seems that the CMUCL + implementation does this by using sap pointers and beams some data + back and fro to actual strings. + + However, I am not very fond of random low-level byte-bashing hacks and + so the READ-FILE and WRITE-FILE functions are now just reading and + writing on a line by line basis which makes them clean an portable. + + So the current state in Phemlock is: line-buffered-p is always nil. + +. It uses EXT:COMPLETE-FILE which is defined in cmucl:filesys.lisp. + We'll need a portable definition. + + +-- +Gilbert Baumann +2003-02-06 +$Id$ Index: /branches/experimentation/later/source/cocoa-ide/hemlock/TODO =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/TODO (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/TODO (revision 8058) @@ -0,0 +1,21 @@ +TODO + +Feel free to stick your own notes into it, be sure to append a +signature. + +- we need to get rid of hemlock11.cursor and hemlock11.mask + --GB 2003-03-26 + +- Provide the classes fundamental-character-{input|output}-stream for SCL + +- Write a style guide. + . signed comments + . no 80-characters-per-line limitations + . no #+/#- in the main code body + . no :: in the main code body + . no changes to bindings in bindings.lisp + unless one updates the manual too. + +- Import the scribe parser and work on the html converter + +$Id$ Index: /branches/experimentation/later/source/cocoa-ide/hemlock/bin/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/bin/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/bin/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/bin/openmcl/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/bin/openmcl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/bin/openmcl/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/aux-sys.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/aux-sys.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/aux-sys.mss (revision 8058) @@ -0,0 +1,694 @@ +@comment{-*- Dictionary: /usr/lisp/scribe/hem/hem; Mode: spell; Package: Hemlock; Log: /usr/lisp/scribe/hem/hem-docs.log -*-} +@chapter (Auxiliary Systems) +This chapter describes utilities that some implementations of @hemlock may +leave unprovided or unsupported. + + +@section[Key-events] +@index(I/O) +@index[keyboard input] +@index[input, keyboard] +@index[mouse input] +@index[input, mouse] +@label[key-events] + +These routines are defined in the @f["EXTENSIONS"] package since other projects +have often used @hemlock's input translations for interfacing to CLX. + + +@subsection[Introduction] + +The canonical representation of editor input is a key-event structure. Users +can bind commands to keys (see section @ref[key-bindings]), which are non-zero +length sequences of key-events. A key-event consists of an identifying token +known as a @i[keysym] and a field of bits representing modifiers. Users define +keysyms, integers between 0 and 65535 inclusively, by supplying names that +reflect the legends on their keyboard's keys. Users define modifier names +similarly, but the system chooses the bit and mask for recognizing the +modifier. You can use keysym and modifier names to textually specify +key-events and Hemlock keys in a @f[#k] syntax. The following are some +examples: +@begin[programexample] + #k"C-u" + #k"Control-u" + #k"c-m-z" + #k"control-x meta-d" + #k"a" + #k"A" + #k"Linefeed" +@end[programexample] +This is convenient for use within code and in init files containing +@f[bind-key] calls. + +The @f[#k] syntax is delimited by double quotes, but the system parses the +contents rather than reading it as a Common Lisp string. Within the double +quotes, spaces separate multiple key-events. A single key-event optionally +starts with modifier names terminated by hyphens. Modifier names are +alphabetic sequences of characters which the system uses case-insensitively. +Following modifiers is a keysym name, which is case-insensitive if it consists +of multiple characters, but if the name consists of only a single character, +then it is case-sensitive. + +You can escape special characters @dash hyphen, double quote, open angle +bracket, close angle bracket, and space @dash with a backslash, and you can +specify a backslash by using two contiguously. You can use angle brackets to +enclose a keysym name with many special characters in it. Between angle +brackets appearing in a keysym name position, there are only two special +characters, the closing angle bracket and backslash. + + + +@subsection[Interface] + +All of the following routines and variables are exported from the "EXTENSIONS" +("EXT") package. + + +@defun[fun {define-keysym}, args {@i[keysym] @i[preferred-name] @rest @i[other-names]}] +This function establishes a mapping from @i[preferred-name] to @i[keysym] for +purposes of @f[#k] syntax. @i[Other-names] also map to @i[keysym], but the +system uses @i[preferred-name] when printing key-events. The names are +case-insensitive simple-strings; however, if the string contains a single +character, then it is used case-sensitively. Redefining a keysym or re-using +names has undefined effects. + +You can use this to define unused keysyms, but primarily this defines keysyms +defined in the @i[X Window System Protocol, MIT X Consortium Standard, X +Version 11, Release 4]. @f[translate-key-event] uses this knowledge to +determine what keysyms are modifier keysyms and what keysym stand for +alphabetic key-events. +@enddefun + + +@defun[fun {define-mouse-keysym}, args {@i[button] @i[keysym] @i[name] @i[shifted-bit] @i[event-key]}] +This function defines @i[keysym] named @i[name] for key-events representing the +X @i[button] cross the X @i[event-key] (@kwd[button-press] or +@kwd[button-release]). @i[Shifted-bit] is a defined modifier name that +@f[translate-mouse-key-event] sets in the key-event it returns whenever the X +shift bit is set in an incoming event. + +Note, by default, there are distinct keysyms for each button distinguishing +whether the user pressed or released the button. + +@i[Keysym] should be an one unspecified in @i[X Window System Protocol, MIT X +Consortium Standard, X Version 11, Release 4]. +@enddefun + + +@defun[fun {name-keysym}, args {@i[name]}] +This function returns the keysym named @i[name]. If @i[name] is unknown, this +returns @nil. +@enddefun + +@defun[fun {keysym-names}, args {@i[keysym]}] +This function returns the list of all names for @i[keysym]. If @i[keysym] is +undefined, this returns @nil. +@enddefun + +@defun[fun {keysym-preferred-name}, args {@i[keysym]}] +This returns the preferred name for @i[keysym], how it is typically printed. +If @i[keysym] is undefined, this returns @nil. +@enddefun + +@defun[fun {define-key-event-modifier}, args {@i[long-name] @i[short-name]}] +This establishes @i[long-name] and @i[short-name] as modifier names for +purposes of specifying key-events in @f[#k] syntax. The names are +case-insensitive simple-strings. If either name is already defined, this +signals an error. + +The system defines the following default modifiers (first the long name, +then the short name): +@begin[Itemize] +@f["Hyper"], @f["H"] + +@f["Super"], @f["S"] + +@f["Meta"], @f["M"] + +@f["Control"], @f["C"] + +@f["Shift"], @f["Shift"] + +@f["Lock"], @f["Lock"] +@end[Itemize] +@enddefun + + +@defvar[var {all-modifier-names}] +This variable holds all the defined modifier names. +@enddefvar + + +@defun[fun {define-clx-modifier}, args {@i[clx-mask] @i[modifier-name]}] +This function establishes a mapping from @i[clx-mask] to a defined key-event +@i[modifier-name]. @f[translate-key-event] and @f[translate-mouse-key-event] +can only return key-events with bits defined by this routine. + +The system defines the following default mappings between CLX modifiers and +key-event modifiers: +@begin[Itemize] +@f[(xlib:make-state-mask :mod-1) --> "Meta"] + +@f[(xlib:make-state-mask :control) --> "Control"] + +@f[(xlib:make-state-mask :lock) --> "Lock"] + +@f[(xlib:make-state-mask :shift) --> "Shift"] +@end[Itemize] +@enddefun + + +@defun[fun {make-key-event-bits}, args {@rest @i[modifier-names]}] +This function returns bits suitable for @f[make-key-event] from the supplied +@i[modifier-names]. If any name is undefined, this signals an error. +@enddefun + +@defun[fun {key-event-modifier-mask}, args {@i[modifier-name]}] +This function returns a mask for @i[modifier-name]. This mask is suitable for +use with @f[key-event-bits]. If @i[modifier-name] is undefined, this signals +an error. +@enddefun + +@defun[fun {key-event-bits-modifiers}, args {@i[bits]}] +This returns a list of key-event modifier names, one for each modifier +set in @i[bits]. +@enddefun + + +@defun[fun {translate-key-event}, args {@i[display] @i[scan-code] @i[bits]}] +This function translates the X @i[scan-code] and X @i[bits] to a key-event. +First this maps @i[scan-code] to an X keysym using @f[xlib:keycode->keysym] +looking at @i[bits] and supplying index as @f[1] if the X shift bit is on, +@f[0] otherwise. + +If the resulting keysym is undefined, and it is not a modifier keysym, +then this signals an error. If the keysym is a modifier key, then this +returns @nil. + +If these conditions are satisfied +@begin[Itemize] +The keysym is defined. + +The X shift bit is off. + +The X lock bit is on. + +The X keysym represents a lowercase letter. +@end[Itemize] +then this maps the @i[scan-code] again supplying index as @f[1] this time, +treating the X lock bit as a caps-lock bit. If this results in an undefined +keysym, this signals an error. Otherwise, this makes a key-event with the +keysym and bits formed by mapping the X bits to key-event bits. + +Otherwise, this makes a key-event with the keysym and bits formed by +mapping the X bits to key-event bits. +@enddefun + + +@defun[fun {translate-mouse-key-event}, args {@i[scan-code] @i[bits] @i[event-key]}] +This function translates the X button code, @i[scan-code], and modifier bits, +@i[bits], for the X @i[event-key] into a key-event. See +@f[define-mouse-keysym]. +@enddefun + +@defun[fun {make-key-event}, args {@i[object] @i[bits]}] +This function returns a key-event described by @i[object] with @i[bits]. +@i[Object] is one of keysym, string, or key-event. When @i[object] is a +key-event, this uses @f[key-event-keysym]. You can form @i[bits] with +@f[make-key-event-bits] or @f[key-event-modifier-mask]. +@enddefun + +@defun[fun {key-event-p}, args {@i[object]}] +This function returns whether @i[object] is a key-event. +@enddefun + +@defun[fun {key-event-bits}, args {@i[key-event]}] +This function returns the bits field of a @i[key-event]. +@enddefun + +@defun[fun {key-event-keysym}, args {@i[key-event]}] +This function returns the keysym field of a @i[key-event]. +@enddefun + +@defun[fun {char-key-event}, args {@i[character]}] +This function returns the key-event associated with @i[character]. You can +associate a key-event with a character by @f[setf]'ing this form. +@enddefun + +@defun[fun {key-event-char}, args {@i[key-event]}] +This function returns the character associated with @i[key-event]. You can +associate a character with a key-event by @f[setf]'ing this form. The system +defaultly translates key-events in some implementation dependent way for text +insertion; for example, under an ASCII system, the key-event @f[#k"C-h"], as +well as @f[#k"backspace"] would map to the Common Lisp character that causes a +backspace. +@enddefun + +@defun[fun {key-event-bit-p}, args {@i[key-event] @i[bit-name]}] +This function returns whether @i[key-event] has the bit set named by +@i[bit-name]. This signals an error if @i[bit-name] is undefined. +@enddefun + +@defmac[fun {do-alpha-key-events}, args +{(@i[var] @i[kind] @optional @i[result]) @mstar<@i[form]>}] + This macro evaluates each @i[form] with @i[var] bound to a key-event +representing an alphabetic character. @i[Kind] is one of @kwd[lower], +@kwd[upper], or @kwd[both], and this binds @i[var] to each key-event in order +as specified in @i[X Window System Protocol, MIT X Consortium Standard, X +Version 11, Release 4]. When @kwd[both] is specified, this processes lowercase +letters first. +@enddefmac + +@defun[fun {print-pretty-key}, args {@i[key] @optional @i[stream] @i[long-names-p]}] +This prints @i[key], a key-event or vector of key-events, in a user-expected +fashion to @i[stream]. @i[Long-names-p] indicates whether modifiers should +print with their long or short name. @i[Stream] defaults to +@var[standard-output]. +@enddefun + +@defun[fun {print-pretty-key-event}, args {@i[key-event] @optional @i[stream] @i[long-names-p]}] +This prints @i[key-event] to @i[stream] in a user-expected fashion. +@i[Long-names-p] indicates whether modifier names should appear using the long +name or short name. @i[Stream] defaults to @var[standard-output]. +@enddefun + + + +@section (CLX Interface) + +@subsection (Graphics Window Hooks) +This section describes a few hooks used by Hemlock's internals to handle +graphics windows that manifest Hemlock windows. Some heavy users of Hemlock as +a tool have needed these in the past, but typically functions that replace the +default values of these hooks must be written in the "@f[HEMLOCK-INTERNALS]" +package. All of these symbols are internal to this package. + +If you need this level of control for your application, consult the current +implementation for code fragments that will be useful in correctly writing your +own window hook functions. + +@defvar[var {create-window-hook}] +This holds a function that @Hemlock calls when @f[make-window] executes under +CLX. @Hemlock passes the CLX display and the following arguments from +@f[make-window]: starting mark, ask-user, x, y, width, height, and modelinep. +The function returns a CLX window or nil indicating one could not be made. +@enddefvar + +@defvar[var {delete-window-hook}] +This holds a function that @hemlock calls when @f[delete-window] executes under +CLX. @hemlock passes the CLX window and the @hemlock window to this function. +@enddefvar + +@defvar[var {random-typeout-hook}] +This holds a function that @hemlock calls when random typeout occurs under CLX. +@hemlock passes it a @hemlock device, a pre-existing CLX window or @nil, and +the number of pixels needed to display the number of lines requested in the +@f[with-pop-up-display] form. It should return a window, and if a new window +is created, then a CLX gcontext must be the second value. +@enddefvar + +@defvar[var {create-initial-windows-hook}] +This holds a function that @hemlock calls when it initializes the screen +manager and makes the first windows, typically windows for the @hid[Main] and +@hid[Echo Area] buffers. @hemlock passes the function a @hemlock device. +@enddefvar + + +@subsection (Entering and Leaving Windows) + +@defhvar[var "Enter Window Hook"] +When the mouse enters an editor window, @hemlock invokes the functions in this +hook. These functions take a @Hemlock window as an argument. +@enddefhvar + +@defhvar[var "Exit Window Hook"] +When the mouse exits an editor window, @hemlock invokes the functions in this +hook. These functions take a @Hemlock window as an argument. +@enddefhvar + + +@subsection (How to Lose Up-Events) +Often the only useful activity user's design for the mouse is to click on +something. @Hemlock sees a character representing the down event, but what do +you do with the up event character that you know must follow? Having the +command eat it would be tasteless, and would inhibit later customizations that +make use of it, possibly adding on to the down click command's functionality. +Bind the corresponding up character to the command described here. + +@defcom[com "Do Nothing"] +This does nothing as many times as you tell it. +@enddefcom + + +@section (Slave Lisps) +@index (Slave lisp interface functions) +Some implementations of @hemlock feature the ability to manage multiple slave +Lisps, each connected to one editor Lisp. The routines discussed here spawn +slaves, send evaluation and compilation requests, return the current server, +etc. This is very powerful because without it you can lose your editing state +when code you are developing causes a fatal error in Lisp. + +The routines described in this section are best suited for creating editor +commands that interact with slave Lisps, but in the past users implemented +several independent Lisps as nodes communicating via these functions. There is +a better level on which to write such code that avoids the extra effort these +routines take for the editor's sake. See the @i[CMU Common Lisp User's Manual] +for the @f[remote] and @f[wire] packages. + + +@subsection (The Current Slave) +There is a slave-information structure that these return which is suitable for +passing to the routines described in the following subsections. + +@defun[fun {create-slave}, args {@optional @i[name]}] +This creates a slave that tries to connect to the editor. When the slave +connects to the editor, this returns a slave-information structure, and the +interactive buffer is the buffer named @i[name]. This generates a name if +@i[name] is @nil. In case the slave never connects, this will eventually +timeout and signal an editor-error. +@enddefun + +@defun[fun {get-current-eval-server}, args {@optional @i[errorp]}] +@defhvar1[var {Current Eval Server}] +This returns the server-information for the @hid[Current Eval Server] after +making sure it is valid. Of course, a slave Lisp can die at anytime. If this +variable is @nil, and @i[errorp] is non-@nil, then this signals an +editor-error; otherwise, it tries to make a new slave. If there is no current +eval server, then this tries to make a new slave, prompting the user based on a +few variables (see the @i[Hemlock User's Manual]). +@enddefun + +@defun[fun {get-current-compile-server}] +@defhvar1[var {Current Compile Server}] +This returns the server-information for the @hid[Current Compile Server] after +making sure it is valid. This may return nil. Since multiple slaves may +exist, it is convenient to use one for developing code and one for compiling +files. The compilation commands that use slave Lisps prefer to use the current +compile server but will fall back on the current eval server when necessary. +Typically, users only have separate compile servers when the slave Lisp can +live on a separate workstation to save cycles on the editor machine, and the +@hemlock commands only use this for compiling files. +@enddefun + + +@subsection (Asynchronous Operation Queuing) +The routines in this section queue requests with an eval server. Requests are +always satisfied in order, but these do not wait for notification that the +operation actually happened. Because of this, the user can continue editing +while his evaluation or compilation occurs. Note, these usually execute in the +slave immediately, but if the interactive buffer connected to the slave is +waiting for a form to return a value, the operation requested must wait until +the slave is free again. + +@defun[fun {string-eval}, args {@i[string]}, keys {[server][package][context]}] +@defun1[fun {region-eval}, args {@i[region]}, keys {[server][package][context]}] +@defun1[fun {region-compile}, args {@i[region]}, keys {[server][package]}] +@f[string-eval] queues the evaluation of the form read from @i[string] on eval +server @i[server]. @i[Server] defaults to the result of +@f[get-current-server], and @i[string] is a simple-string. The evaluation +occurs with @var[package] bound in the slave to the package named by +@i[package], which defaults to @hid[Current Package] or the empty string; the +empty string indicates that the slave should evaluate the form in its current +package. The slave reads the form in @i[string] within this context as well. +@i[Context] is a string to use when reporting start and end notifications in +the @hid[Echo Area] buffer; it defaults to the concatenation of @f["evaluation +of "] and @i[string]. + +@f[region-eval] is the same as @f[string-eval], but @i[context] defaults +differently. If the user leaves this unsupplied, then it becomes a string +involving part of the first line of region. + +@f[region-compile] is the same as the above. @i[Server] defaults the same; it +does not default to @f[get-current-compile-server] since this compiles the +region into the slave Lisp's environment, to affect what you are currently +working on. +@enddefun + +@defun[fun {file-compile}, args {@i[file]}, + keys {[output-file][error-file][load][server]}, + morekeys {[package]}] +@defhvar1[var {Remote Compile File}, val {nil}] +This compiles @i[file] in a slave Lisp. When @i[output-file] is @true (the +default), this uses a temporary output file that is publicly writable in case +the client is on another machine, which allows for file systems that do not +permit remote write access. This renames the temporary file to the appropriate +binary name or deletes it after compilation. Setting @hid[Remote Compile File] +to @nil, inhibits this. If @i[output-file] is non-@nil and not @true, then it +is the name of the binary file to write. The compilation occurs with +@var[package] bound in the slave to the package named by @i[package], which +defaults to @hid[Current Package] or the empty string; the empty string +indicates that the slave should evaluate the form in its current package. +@i[Error-file] is the file in which to record compiler output, and a @nil value +inhibits this file's creation. @i[Load] indicates whether to load the +resulting binary file, defaults to @nil. @i[Server] defaults to +@f[get-current-compile-server], but if this returns nil, then @i[server] +defaults to @f[get-current-server]. +@enddefun + +@subsection (Synchronous Operation Queuing) +The routines in this section queue requests with an eval server and wait for +confirmation that the evaluation actually occurred. Because of this, the user +cannot continue editing while the slave executes the request. Note, these +usually execute in the slave immediately, but if the interactive buffer +connected to the slave is waiting for a form to return a value, the operation +requested must wait until the slave is free again. + +@defun[fun {eval-form-in-server}, + args {@i[server-info] @i[string] @optional @i[package]}] + This function queues the evaluation of a form in the server associated with +@i[server-info] and waits for the results. The server @f[read]'s the form from +@i[string] with @var[package] bound to the package named by @i[package]. This +returns the results from the slave Lisp in a list of string values. You can +@f[read] from the strings or simply display them depending on the @f[print]'ing +of the evaluation results. + +@i[Package] defaults to @hid[Current Package]. If this is @nil, the server +uses the value of @var[package] in the server. + +While the slave executes the form, it binds @var[terminal-io] to a stream that +signals errors when read from and dumps output to a bit-bucket. This prevents +the editor and slave from dead locking by waiting for each other to reply. +@enddefun + +@defun[fun {eval-form-in-server-1}, + args {@i[server-info] @i[string] @optional @i[package]}] + This function calls @f[eval-form-in-server] and @f[read]'s the result in the +first string it returns. This result must be @f[read]'able in the editor's +Lisp. +@enddefun + + +@section (Spelling) +@index (Spelling checking) +@hemlock supports spelling checking and correcting commands based on the ITS +Ispell dictionary. These commands use the following routines which include +adding and deleting entries, reading the Ispell dictionary in a compiled binary +format, reading user dictionary files in a text format, and checking and +correcting possible spellings. + +@defun[fun {maybe-read-spell-dictionary}, package {spell}] +This reads the default binary Ispell dictionary. Users must call this before +the following routines will work. +@enddefun + +@defun[fun {spell-read-dictionary}, package {spell}, args {@i[filename]}] +This adds entries to the dictionary from the lines in the file @i[filename]. +Dictionary files contain line oriented records like the following: +@begin[programexample] +entry1/flag1/flag2 +entry2 +entry3/flag1 +@end[programexample] +The flags are the Ispell flags indicating which endings are appropriate for the +given entry root, but these are unnecessary for user dictionary files. You can +consult Ispell documentation if you want to know more about them. +@enddefun + +@defun[fun {spell-add-entry}, package {spell}, + args {@i[line] @optional @i[word-end]}] +This takes a line from a dictionary file, and adds the entry described by +@i[line] to the dictionary. @i[Word-end] defaults to the position of the first +slash character or the length of the line. @i[Line] is destructively modified. +@enddefun + +@defun[fun {spell-remove-entry}, package {spell}, args {@i[entry]}] +This removes entry, a simple-string, from the dictionary, so it will be an +unknown word. This destructively modifies @i[entry]. If it is a root word, +then all words derived with @i[entry] and its flags will also be deleted. If +@i[entry] is a word derived from some root word, then the root and any words +derived from it remain known words. +@enddefun + +@defun[fun {correct-spelling}, package {spell}, args {@i[word]}] +This checks the spelling of @i[word] and outputs the results. If this finds +@i[word] is correctly spelled due to some appropriate suffix on a root, it +generates output indicating this. If this finds @i[word] as a root entry, it +simply outputs that it found @i[word]. If this cannot find @i[word] at all, +then it outputs possibly correct close spellings. This writes to +@var[standard-output], and it calls @f[maybe-read-spell-dictionary] before +attempting any lookups. +@enddefun + +@defun[fun {spell-try-word}, package {spell}, args {@i[word] @i[word-len]}] +@defcon1[var {max-entry-length}, val {31}] +This returns an index into the dictionary if it finds @i[word] or an +appropriate root. @i[Word-len] must be inclusively in the range 2 through +@f[max-entry-length], and it is the length of @i[word]. @i[Word] must be +uppercase. This returns a second value indicating whether it found @i[word] +due to a suffix flag, @nil if @i[word] is a root entry. +@enddefun + +@defun[fun {spell-root-word}, package {spell}, args {@i[index]}] +This returns a copy of the root word at dictionary entry @i[index]. This index +is the same as returned by @f[spell-try-word]. +@enddefun + +@defun[fun {spell-collect-close-words}, package {spell}, args {@i[word]}] +This returns a list of words correctly spelled that are @i[close] to @i[word]. +@i[Word] must be uppercase, and its length must be inclusively in the range 2 +through @f[max-entry-length]. Close words are determined by the Ispell rules: +@begin[enumerate] +Two adjacent letters can be transposed to form a correct spelling. + +One letter can be changed to form a correct spelling. + +One letter can be added to form a correct spelling. + +One letter can be removed to form a correct spelling. +@end[enumerate] +@enddefun + +@defun[fun {spell-root-flags}, package {spell}, args {@i[index]}] +This returns a list of suffix flags as capital letters that apply to the +dictionary root entry at @i[index]. This index is the same as returned by +@f[spell-try-word]. +@enddefun + + +@section (File Utilities) +Some implementations of @hemlock provide extensive directory editing commands, +@hid[Dired], including a single wildcard feature. An asterisk denotes a +wildcard. + +@defun[fun {copy-file}, package {dired}, + args {@i[spec1] @i[spec2]}, keys {[update][clobber][directory]}] + This function copies @i[spec1] to @i[spec2]. It accepts a single wildcard in +the filename portion of the specification, and it accepts directories. This +copies files maintaining the source's write date. + +If @i[spec1] and @i[spec2] are both directories, this recursively copies the +files and subdirectory structure of @i[spec1]; if @i[spec2] is in the +subdirectory structure of @i[spec1], the recursion will not descend into it. +Use @f["/spec1/*"] to copy only the files from @i[spec1] to directory +@i[spec2]. + +If @i[spec2] is a directory, and @i[spec1] is a file, then this copies +@i[spec1] into @i[spec2] with the same @f[pathname-name]. + +When @kwd[update] is non-@nil, then the copying process only copies files if the +source is newer than the destination. + +When @kwd[update] and @kwd[clobber] are @nil, and the destination exists, the +copying process stops and asks the user whether the destination should be +overwritten. + +When the user supplies @kwd[directory], it is a list of pathnames, directories +excluded, and @i[spec1] is a pattern containing one wildcard. This then copies +each of the pathnames whose @f[pathname-name] matches the pattern. @i[Spec2] +is either a directory or a pathname whose @f[pathname-name] contains a +wildcard. +@enddefun + +@defun[fun {rename-file}, package {dired}, + args {@i[spec1] @i[spec2]}, keys {[clobber][directory]}] + This function renames @i[spec1] to @i[spec2]. It accepts a single wildcard in +the filename portion of the specification, and @i[spec2] may be a directory +with the destination specification resulting in the merging of @i[spec2] with +@i[spec1]. If @kwd[clobber] is @nil, and @i[spec2] exists, then this asks the +user to confirm the renaming. When renaming a directory, end the specification +without the trailing slash. + +When the user supplies @kwd[directory], it is a list of pathnames, directories +excluded, and @i[spec1] is a pattern containing one wildcard. This then copies +each of the pathnames whose @f[pathname-name] matches the pattern. @i[Spec2] +is either a directory or a pathname whose @f[pathname-name] contains a +wildcard. +@enddefun + +@defun[fun {delete-file}, package {dired}, + args {@i[spec]}, keys {[recursive][clobber]}] + This function deletes @i[spec]. It accepts a single wildcard in the filename +portion of the specification, and it asks for confirmation on each file if +@kwd[clobber] is @nil. If @kwd[recursive] is non-@nil, then @i[spec] may be a +directory to recursively delete the entirety of the directory and its +subdirectory structure. An empty directory may be specified without +@kwd[recursive] being non-@nil. Specify directories with the trailing +slash. +@enddefun + +@defun[fun {find-file}, package {dired}, + args {@i[name] @optional @i[directory] @i[find-all]}] + This function finds the file with @f[file-namestring] @i[name], recursively +looking in @i[directory]. If @i[find-all] is non-@nil (defaults to @nil), then +this continues searching even after finding a first occurrence of file. +@i[Name] may contain a single wildcard, which causes @i[find-all] to default to +@true instead of @nil. +@enddefun + +@defun[fun {make-directory}, package {dired}, args {@i[name]}] +This function creates the directory with @i[name]. If it already exists, this +signals an error. +@enddefun + +@defun[fun {pathnames-from-pattern}, package {dired}, + args {@i[pattern] @i[files]}] +This function returns a list of pathnames from the list @i[files] whose +@f[file-namestring]'s match @i[pattern]. @i[Pattern] must be a non-empty +string and contain only one asterisk. @i[Files] contains no directories. +@enddefun + +@defvar[var {update-default}, package {dired}] +@defvar1[var {clobber-default}, package {dired}] +@defvar1[var {recursive-default}, package {dired}] +These are the default values for the keyword arguments above with corresponding +names. These default to @nil, @true, and @nil respectively. +@enddefvar + +@defvar[var {report-function}, package {dired}] +@defvar1[var {error-function}, package {dired}] +@defvar1[var {yesp-function}, package {dired}] +These are the function the above routines call to report progress, signal +errors, and prompt for @i[yes] or @i[no]. These all take format strings and +arguments. +@enddefvar + + +@defun[fun {merge-relative-pathnames}, args {@i[pathname] @i[default-directory]}] +This function merges @i[pathname] with @i[default-directory]. If @i[pathname] +is not absolute, this assumes it is relative to @i[default-directory]. The +result is always a directory pathname. +@enddefun + +@defun[fun {directoryp}, args {@i[pathname]}] +This function returns whether @i[pathname] names a directory: it has no name +and no type fields. +@enddefun + + +@section (Beeping) + +@defun[fun {hemlock-beep}] +@Hemlock binds @f[system:*beep-function*] to this function to beep the device. +It is different for different devices. +@enddefun + +@defhvar[var "Bell Style", val {:border-flash}] +@defhvar1[var "Beep Border Width", val {20}] +@hid[Bell Style] determines what @var[hemlock-beep] does in @hemlock under CLX. +Acceptable values are @kwd[border-flash], @kwd[feep], +@kwd[border-flash-and-feep], @kwd[flash], @kwd[flash-and-feep], and @nil (do +nothing). + +@hid[Beep Border Width] is the width in pixels of the border flashed by border +flash beep styles. +@enddefhvar Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/cim.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/cim.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/cim/cim.mss (revision 8058) @@ -0,0 +1,4039 @@ +@make[Manual] @comment{-*- Dictionary: /afs/cs/project/clisp/docs/hem/hem; Mode: spell; Package: Hemlock; Log: /usr/lisp/scribe/hem/hem-docs.log -*-} +@Device[postscript] +@style(FontFamily = TimesRoman) +@Style(Spacing = 1.2 lines) +@Style(StringMax = 5000) +@style(Hyphenation = On) +@style(Date="March 1952") +@use(database "/afs/cs/project/clisp/docs/database/") +@Style [DoubleSided] +@Libraryfile[ArpaCredit] +@Libraryfile[Hem] +@Libraryfile[Spice] +@Libraryfile[Uttir] + +@String(ReportTitle "Hemlock Command Implementor's Manual") + +@comment< +@begin[TitlePage] +@begin[TitleBox] +> +@blankspace(1.3inches) +@heading[Hemlock Command Implementor's Manual] + +@center[ +@b +@b + +@b<@value[date]> + +@b +] +@comment<@end[TitleBox]> +@blankspace(2lines) +@begin[Center] +School of Computer Science +Carnegie Mellon University +Pittsburgh, PA 15213 +@end[Center] + +@blankspace(2lines) +@begin[Center] +This is a revised version of Technical Report CMU-CS-87-159. +@end[Center] +@heading[Abstract] +@begin(Text, indent 0) +This document describes how to write commands for the @Hemlock text editor, as +of version M3.2. @Hemlock is a customizable, extensible text editor whose +initial command set closely resembles that of ITS/TOPS-20 @Emacs. @Hemlock is +written in the CMU Common Lisp and has been ported to other implementations. +@end(Text) + +@blankspace(0.5in) +@begin[ResearchCredit] +@arpacredit[Contract=Basic87-90] +@end[ResearchCredit] +@comment<@end[TitlePage]> + + +@commandstring(dash = "@Y[M]") + + +@Tabclear + +@chapter(Introduction) + + @hemlock is a text editor which follows in the tradition of editors +such as EMACS and the Lisp Machine editor ZWEI. In its basic form, +@hemlock has almost the same command set as EMACS, and similar +features such as multiple buffers and windows, extended commands, +and built in documentation. + +Both user extensions and the original commands are written in Lisp, +therefore a command implementor will have a working knowledge of this +language. Users not familiar with Lisp need not despair however. Many +users of Multics EMACS, another text editor written in Lisp, came to learn +Lisp simply for the purpose of writing their own editor extensions, and +found, to their surprise, that it was really pretty easy to write simple +commands. + +This document describes the Common Lisp functions, macros and data structures +that are used to implement new commands. The basic editor consists of a set of +Lisp utility functions for manipulating buffers and the other data structures +of the editor as well as handling the display. All user level commands are +written in terms of these functions. To find out how to define commands see +chapter @ref[commands]. + +@chapter(Representation of Text) +@index (Lines) +@section(Lines) +In @hemlock all text is in some @i[line]. Text is broken into lines wherever +it contains a newline character; newline characters are never stored, but are +assumed to exist between every pair of lines. The implicit newline character +is treated as a single character by the text primitives. + +@defun[fun {linep}, args {@i[line]}] +This function returns @true if @i[line] is a @f[line] object, otherwise @nil. +@enddefun + +@defun[fun {line-string}, args {@i[line]}] +Given a @i(line), this function returns as a simple string the characters in +the line. This is @f[setf]'able to set the @f[line-string] to any string that +does not contain newline characters. It is an error to destructively modify +the result of @f[line-string] or to destructively modify any string after the +@f[line-string] of some line has been set to that string. +@enddefun + +@defun[fun {line-previous}, args {@i[line]}] +@defun1[fun {line-next}, args {@i[line]}] +Given a @i(line), @f[line-previous] returns the previous line or @nil if there +is no previous line. Similarly, @f[line-next] returns the line following +@i[line] or @nil. +@enddefun + +@defun[fun {line-buffer}, args {@i[line]}] +This function returns the buffer which contains this @i(line). Since a +line may not be associated with any buffer, in which case @f[line-buffer] +returns @nil. +@enddefun + +@defun[fun {line-length}, args {@i[line]}] +This function returns the number of characters in the @i(line). This excludes +the newline character at the end. +@enddefun + +@defun[fun {line-character}, args {@i[line] @i[index]}] +This function returns the character at position @i[index] within @i[line]. It +is an error for @i[index] to be greater than the length of the line or less +than zero. If @i[index] is equal to the length of the line, this returns a +@f[#\newline] character. +@enddefun + +@defun[fun {line-plist}, args {@i[line]}] +This function returns the property-list for @i[line]. @f[setf], @f[getf], +@f[putf] and @f[remf] can be used to change properties. This is typically used +in conjunction with @f[line-signature] to cache information about the line's +contents. +@enddefun + +@defun[fun {line-signature}, args {@i[line]}] +This function returns an object that serves as a signature for a @i[line]'s +contents. It is guaranteed that any modification of text on the line will +result in the signature changing so that it is not @f[eql] to any previous +value. The signature may change even when the text remains unmodified, but +this does not happen often. +@enddefun + + +@section(Marks) +@label[marks] +@index (Marks) +A mark indicates a specific position within the text represented by a line and +a character position within that line. Although a mark is sometimes loosely +referred to as pointing to some character, it in fact points between +characters. If the @f[charpos] is zero, the previous character is the newline +character separating the previous line from the mark's @f[line]. If the +charpos is equal to the number of characters in the line, the next character is +the newline character separating the current line from the next. If the mark's +line has no previous line, a mark with @f[charpos] of zero has no previous +character; if the mark's line has no next line, a mark with @f[charpos] equal +to the length of the line has no next character. + +This section discusses the very basic operations involving marks, but a lot of +@hemlock programming is built on altering some text at a mark. For more +extended uses of marks see chapter @ref[doing-stuff]. + + +@subsection(Kinds of Marks) +@index (Permanent marks) +@index (Temporary marks) +A mark may have one of two lifetimes: @i[temporary] or @i[permanent]. +Permanent marks remain valid after arbitrary operations on the text; temporary +marks do not. Temporary marks are used because less bookkeeping overhead is +involved in their creation and use. If a temporary mark is used after the text +it points to has been modified results will be unpredictable. Permanent marks +continue to point between the same two characters regardless of insertions and +deletions made before or after them. + +There are two different kinds of permanent marks which differ only in their +behavior when text is inserted @i(at the position of the mark); text is +inserted to the left of a @i[left-inserting] mark and to the right of +@i[right-inserting] mark. + + +@subsection(Mark Functions) +@defun[fun {markp}, args {@i[mark]}] +This function returns @true if @i[mark] is a @f[mark] object, otherwise @nil. +@enddefun + +@defun[fun {mark-line}, args {@i[mark]}] +This function returns the line to which @i(mark) points. +@enddefun + +@defun[fun {mark-charpos}, args {@i[mark]}] +This function returns the character position of the character after @i(mark). +If @i[mark]'s line has no next line, this returns the length of the line as +usual; however, there is actually is no character after the mark. +@enddefun + +@defun[fun {mark-kind}, args {@i[mark]}] +This function returns one of @kwd[right-inserting], @kwd[left-inserting] or +@kwd[temporary] depending on the mark's kind. A corresponding @f[setf] form +changes the mark's kind. +@enddefun + +@defun[fun {previous-character}, args {@i[mark]}] +@defun1[fun {next-character}, args {@i[mark]}] +This function returns the character immediately before (after) the position of +the @i[mark], or @nil if there is no previous (next) character. These +characters may be set with @f[setf] when they exist; the @f[setf] methods for +these forms signal errors when there is no previous or next character. +@enddefun + + +@subsection(Making Marks) +@defun[fun {mark}, args {@i[line] @i[charpos] @optional @i[kind]}] +This function returns a mark object that points to the @i(charpos)'th character +of the @i(line). @i(Kind) is the kind of mark to create, one of +@kwd[temporary], @kwd[left-inserting], or @kwd[right-inserting]. The default +is @kwd[temporary]. +@enddefun + +@defun[fun {copy-mark}, args {@i[mark] @optional @i[kind]}] +This function returns a new mark pointing to the same position and of the same +kind, or of kind @i[kind] if it is supplied. +@enddefun + +@defun[fun {delete-mark}, args {@i[mark]}] +This function deletes @i(mark). Delete any permanent marks when you are +finished using it. +@enddefun + +@Defmac[Fun {with-mark}, Args + {(@Mstar<(@i[mark] @i[pos] @mopt[@i(kind)])>) @Mstar<@i[form]>}] + This macro binds to each variable @i[mark] a mark of kind @i[kind], which +defaults to @kwd[temporary], pointing to the same position as the mark @i[pos]. +On exit from the scope the mark is deleted. The value of the last @i[form] is +the value returned. +@enddefmac + + +@subsection(Moving Marks) +@index(Moving marks) +These functions destructively modify marks to point to new positions. Other +sections of this document describe mark moving routines specific to higher +level text forms than characters and lines, such as words, sentences, +paragraphs, Lisp forms, etc. + +@defun[fun {move-to-position}, args {@i[mark] @i[charpos] @optional @i[line]}] +This function changes the @i(mark) to point to the given character position on +the line @i(line). @i(Line) defaults to @i[mark]'s line. +@enddefun + +@defun[fun {move-mark}, args {@i[mark] @i[new-position]}] +This function moves @i[mark] to the same position as the mark @i[new-position] +and returns it. +@enddefun + +@defun[fun {line-start}, args {@i[mark] @optional @i[line]}] +@defun1[fun {line-end}, args {@i[mark] @optional @i[line]}] +This function changes @i[mark] to point to the beginning or the end of @i(line) +and returns it. @i[Line] defaults to @i[mark]'s line. +@enddefun + +@defun[fun {buffer-start}, args {@i[mark] @optional @i[buffer]}] +@defun1[fun {buffer-end}, args {@i[mark] @optional @i[buffer]}] +These functions change @i[mark] to point to the beginning or end of @i[buffer], +which defaults to the buffer @i[mark] currently points into. If @i[buffer] is +unsupplied, then it is an error for @i[mark] to be disassociated from any +buffer. +@enddefun + +@defun[fun {mark-before}, args {@i[mark]}] +@defun1[fun {mark-after}, args {@i[mark]}] +These functions change @i[mark] to point one character before or after the +current position. If there is no character before/after the current position, +then they return @nil and leave @i[mark] unmodified. +@enddefun + +@defun[fun {character-offset}, args {@i[mark] @i[n]}] +This function changes @i[mark] to point @i[n] characters after (@i[n] before if +@i[n] is negative) the current position. If there are less than @i[n] +characters after (before) the @i[mark], then this returns @nil and @i[mark] is +unmodified. +@enddefun + +@defun[fun {line-offset}, args {@i[mark] @i[n] @optional @i[charpos]}] +This function changes @i[mark] to point @i[n] lines after (@i[n] before if +@i[n] is negative) the current position. The character position of the +resulting mark is +@lisp +(min (line-length @i(resulting-line)) (mark-charpos @i(mark))) +@endlisp +if @i[charpos] is unspecified, or +@lisp +(min (line-length @i(resulting-line)) @i(charpos)) +@endlisp +if it is. As with @funref(character-offset), if there are not @i[n] lines then +@nil is returned and @i[mark] is not modified. +@enddefun + + +@section(Regions) +@index (Regions) +A region is simply a pair of marks: a starting mark and an ending mark. +The text in a region consists of the characters following the starting +mark and preceding the ending mark (keep in mind that a mark points between +characters on a line, not at them). + +By modifying the starting or ending mark in a region it is possible to +produce regions with a start and end which are out of order or even in +different buffers. The use of such regions is undefined and may +result in arbitrarily bad behavior. + + +@subsection(Region Functions) +@defun[fun {region}, args {@i[start] @i[end]}] +This function returns a region constructed from the marks @i[start] and +@i[end]. It is an error for the marks to point to non-contiguous lines or for +@i(start) to come after @i(end). +@enddefun + +@defun[fun {regionp}, args {@i[region]}] +This function returns @true if @i[region] is a @f[region] object, otherwise +@nil. +@enddefun + +@defun[fun {make-empty-region}] +This function returns a region with start and end marks pointing to the start +of one empty line. The start mark is a @kwd[right-inserting] mark, and the end +is a @kwd[left-inserting] mark. +@enddefun + +@defun[fun {copy-region}, args {@i[region]}] +This function returns a region containing a copy of the text in the specified +@i[region]. The resulting region is completely disjoint from @i[region] with +respect to data references @dash marks, lines, text, etc. +@enddefun + +@defun[fun {region-to-string}, args {@i[region]}] +@defun1[fun {string-to-region}, args {@i[string]}] +These functions coerce regions to Lisp strings and vice versa. Within the +string, lines are delimited by newline characters. +@enddefun + +@defun[fun {line-to-region}, args {@i[line]}] +This function returns a region containing all the characters on @i[line]. The +first mark is @kwd[right-inserting] and the last is @kwd[left-inserting]. +@enddefun + +@defun[fun {region-start}, args {@i[region]}] +@defun1[fun {region-end}, args {@i[region]}] +This function returns the start or end mark of @i(region). +@enddefun + +@defun[fun {region-bounds}, args {@i[region]}] +This function returns as multiple-values the starting and ending marks of +@i[region]. +@enddefun + +@defun[fun {set-region-bounds}, args {@i[region] @i[start] @i[end]}] +This function sets the start and end of region to @i[start] and @i[end]. It is +an error for @i[start] to be after or in a different buffer from @i[end]. +@enddefun + +@index(Counting lines and characters) +@defun[fun {count-lines}, args {@i[region]}] +This function returns the number of lines in the @i(region), first and last +lines inclusive. A newline is associated with the line it follows, thus a +region containing some number of non-newline characters followed by one newline +is one line, but if a newline were added at the beginning, it would be two +lines. +@enddefun + +@defun[fun {count-characters}, args {@i[region]}] +This function returns the number of characters in a given @i(region). This +counts line breaks as one character. +@enddefun + +@defun[fun {check-region-query-size}, args {@i[region]}] +@defhvar1[var {Region Query Size}, val {30}] +@f[check-region-query-size] counts the lines in @i[region], and if their number +exceeds the @hid[Region Query Size] threshold, it prompts the user for +confirmation. This should be used in commands that perform destructive +operations and are not undoable. If the user responds negatively, then this +signals an editor-error, aborting whatever command was in progress. +@enddefun + + + +@chapter(Buffers) +@index (Buffers) +@label[buffers] +A buffer is an environment within @hemlock consisting of: +@begin(enumerate) +A name. + +A piece of text. + +A current focus of attention, the point. + +An associated file (optional). + +A write protect flag. + +Some variables (page @pageref[variables]). + +Some key bindings (page @pageref[key-bindings]). + +Some collection of modes (page @pageref[modes]). + +Some windows in which it is displayed (page @pageref[windows]). + +A list of modeline fields (optional). +@end(enumerate) + + +@section (The Current Buffer) +@index (Current buffer) +@defun[fun {current-buffer}] +@defhvar1[var {Set Buffer Hook}] +@defhvar1[var {After Set Buffer Hook}] +@f[current-buffer] returns the current buffer object. Usually this is the +buffer that @funref[current-window] is displaying. This value may be changed +with @f[setf], and the @f[setf] method invokes @hid[Set Buffer Hook] before the +change occurs with the new value. After the change occurs, the method invokes +@hid[After Set Buffer Hook] with the old value. +@enddefun + +@defun[fun {current-point}] +This function returns the @f[buffer-point] of the current buffer. +This is such a common idiom in commands that it is defined despite +its trivial implementation. +@enddefun + +@defun[fun {current-mark}] +@defun1[fun {pop-buffer-mark}] +@defun1[fun {push-buffer-mark}, args {@i[mark] @optional @i[activate-region]}] +@index(Buffer mark stack) +@index(Mark stack) +@label(mark-stack) +@f[current-mark] returns the top of the current buffer's mark stack. There +always is at least one mark at the beginning of the buffer's region, and all +marks returned are right-inserting. + +@f[pop-buffer-mark] pops the current buffer's mark stack, returning the mark. +If the stack becomes empty, this pushes a new mark on the stack pointing to the +buffer's start. This always deactivates the current region (see section +@ref[active-regions]). + +@f[push-buffer-mark] pushes @i[mark] into the current buffer's mark stack, +ensuring that the mark is right-inserting. If @i[mark] does not point into the +current buffer, this signals an error. Optionally, the current region is made +active, but this never deactivates the current region (see section +@ref[active-regions]). @i[Mark] is returned. +@enddefun + +@defvar[var {buffer-list}] +This variable holds a list of all the buffer objects made with @f[make-buffer]. +@enddefvar + +@defvar[var {buffer-names}] +This variable holds a @f[string-table] (page @pageref(string-tables)) of all the +names of the buffers in @var[buffer-list]. The values of the entries are the +corresponding buffer objects. +@enddefvar + +@defvar[var {buffer-history}] +This is a list of buffer objects ordered from those most recently selected to +those selected farthest in the past. When someone makes a buffer, an element +of @hid[Make Buffer Hook] adds this buffer to the end of this list. When +someone deletes a buffer, an element of @hid[Delete Buffer Hook] removes the +buffer from this list. Each buffer occurs in this list exactly once, but it +never contains the @var[echo-area-buffer]. +@enddefvar + +@defun[fun {change-to-buffer}, args {@i[buffer]}] +This switches to @i[buffer] in the @f[current-window] maintaining +@f[buffer-history]. +@enddefun + +@defun[fun {previous-buffer}] +This returns the first buffer from @var[buffer-history] that is not the +@f[current-buffer]. If none can be found, then this returns @nil. +@enddefun + + +@section(Buffer Functions) +@defun[fun {make-buffer}, args {@i[name]}, keys {[modes][modeline-fields][delete-hook]}] +@defhvar1[var {Make Buffer Hook}] +@defhvar1[var {Default Modeline Fields}] +@f[make-buffer] creates and returns a buffer with the given @i(name). If a +buffer named @i[name] already exists, @nil is returned. @i[Modes] is a list of +modes which should be in effect in the buffer, major mode first, followed by +any minor modes. If this is omitted then the buffer is created with the list +of modes contained in @hvarref[Default Modes]. @i[Modeline-fields] is a list +of modeline-field objects (see section @ref[modelines]) which may be @nil. +@f[delete-hook] is a list of delete hooks specific to this buffer, and +@f[delete-buffer] invokes these along with @hid[Delete Buffer Hook]. + +Buffers created with @f[make-buffer] are entered into the list +@var[buffer-list], and their names are inserted into the +string-table @var[buffer-names]. When a buffer is created the hook +@hid[Make Buffer Hook] is invoked with the new buffer. +@enddefun + +@defun[fun {bufferp}, args {@i[buffer]}] +Returns @true if @i[buffer] is a @f[buffer] object, otherwise @nil. +@enddefun + +@defun[fun {buffer-name}, args {@i[buffer]}] +@defhvar1[var {Buffer Name Hook}] +@f[buffer-name] returns the name, which is a string, of the given @i(buffer). +The corresponding @f[setf] method invokes @hid[Buffer Name Hook] with +@i[buffer] and the new name and then sets the buffer's name. When the user +supplies a name for which a buffer already exists, the @f[setf] method signals +an error. +@enddefun + +@defun[fun {buffer-region}, args {@i[buffer]}] +Returns the @i[buffer]'s region. This can be set with @f[setf]. Note, this +returns the region that contains all the text in a buffer, not the +@funref[current-region]. +@enddefun + +@defun[fun {buffer-pathname}, args {@i[buffer]}] +@defhvar1[var {Buffer Pathname Hook}] +@f[buffer-pathname] returns the pathname of the file associated with +the given @i(buffer), or nil if it has no associated file. This is +the truename of the file as of the most recent time it was read or +written. There is a @f[setf] form to change the pathname. When the +pathname is changed the hook @hid[Buffer Pathname Hook] is invoked +with the buffer and new value. +@enddefun + +@defun[fun {buffer-write-date}, args {@i[buffer]}] +Returns the write date for the file associated with the buffer in universal +time format. When this the @f[buffer-pathname] is set, use @f[setf] to set +this to the corresponding write date, or to @nil if the date is unknown or +there is no file. +@enddefun + +@defun[fun {buffer-point}, args {@i[buffer]}] +Returns the mark which is the current location within @i[buffer]. To +move the point, use @f[move-mark] or @funref[move-to-position] rather +than setting @f[buffer-point] with @f[setf]. +@enddefun + +@defun[fun {buffer-mark}, args {@i[buffer]}] +@index(Buffer mark stack) +@index(Mark stack) +This function returns the top of @i[buffer]'s mark stack. There always +is at least one mark at the beginning of @i[buffer]'s region, and all marks +returned are right-inserting. +@enddefun + +@defun[fun {buffer-start-mark}, args {@i[buffer]}] +@defun1[fun {buffer-end-mark}, args {@i[buffer]}] +These functions return the start and end marks of @i[buffer]'s region: +@Begin[ProgramExample] +(buffer-start-mark buffer) <==> + (region-start (buffer-region buffer)) +and +(buffer-end-mark buffer) <==> + (region-end (buffer-region buffer)) +@End[ProgramExample] +@enddefun + +@defun[fun {buffer-writable}, args {@i[buffer]}] +@defhvar1[var "Buffer Writable Hook"] +This function returns @true if you can modify the @i(buffer), @nil if you +cannot. If a buffer is not writable, then any attempt to alter text in the +buffer results in an error. There is a @f[setf] method to change this value. + +The @f[setf] method invokes the functions in @hid[Buffer Writable Hook] on the +buffer and new value before storing the new value. +@enddefun + +@defun[fun {buffer-modified}, args {@i[buffer]}] +@defhvar1[var "Buffer Modified Hook"] +@f[buffer-modified] returns @true if the @i[buffer] has been modified, @nil if +it hasn't. This attribute is set whenever a text-altering operation is +performed on a buffer. There is a @f[setf] method to change this value. + +The @f[setf] method invokes the functions in @hid[Buffer Modified Hook] with +the buffer whenever the value of the modified flag changes. +@enddefun + +@defmac[fun {with-writable-buffer}, args {(@i[buffer]) @rest @i[forms]}] +This macro executes @i[forms] with @i[buffer]'s writable status set. After +@i[forms] execute, this resets the @i[buffer]'s writable and modified status. +@enddefmac + +@defun[fun {buffer-signature}, args {@i[buffer]}] +This function returns an arbitrary number which reflects the buffer's current +@i[signature]. The result is @f[eql] to a previous result if and only if the +buffer has not been modified between the calls. +@enddefun + +@defun[fun {buffer-variables}, args {@i[buffer]}] +This function returns a string-table (page @pageref[string-tables]) containing +the names of the buffer's local variables. See chapter @ref[variables]. +@enddefun + +@defun[fun {buffer-modes}, args {@i[buffer]}] +This function returns the list of the names of the modes active in @i[buffer]. +The major mode is first, followed by any minor modes. See chapter @ref[modes]. +@enddefun + +@defun[fun {buffer-windows}, args {@i[buffer]}] +This function returns the list of all the windows in which the buffer may be +displayed. This list may include windows which are not currently visible. See +page @pageref[windows] for a discussion of windows. +@enddefun + +@defun[fun {buffer-delete-hook}, args {@i[buffer]}] +This function returns the list of buffer specific functions @f[delete-buffer] +invokes when deleting a buffer. This is @f[setf]'able. +@enddefun + +@defun[fun {delete-buffer}, args {@i[buffer]}] +@defhvar1[var {Delete Buffer Hook}] +@f[delete-buffer] removes @i[buffer] from @varref[buffer-list] and its name +from @varref[buffer-names]. Before @i[buffer] is deleted, this invokes the +functions on @i[buffer] returned by @f[buffer-delete-hook] and those found in +@hid[Delete Buffer Hook]. If @i[buffer] is the @f[current-buffer], or if it is +displayed in any windows, then this function signals an error. +@enddefun + +@defun[fun {delete-buffer-if-possible}, args {@i[buffer]}] +This uses @f[delete-buffer] to delete @i[buffer] if at all possible. If +@i[buffer] is the @f[current-buffer], then this sets the @f[current-buffer] to +the first distinct buffer in @f[buffer-history]. If @i[buffer] is displayed in +any windows, then this makes each window display the same distinct buffer. +@enddefun + + +@section(Modelines) +@index(Modelines) +@label(modelines) + +A Buffer may specify a modeline, a line of text which is displayed across the +bottom of a window to indicate status information. Modelines are described as +a list of @f[modeline-field] objects which have individual update functions and +are optionally fixed-width. These have an @f[eql] name for convenience in +referencing and updating, but the name must be unique for all created +modeline-field objects. When creating a modeline-field with a specified width, +the result of the update function is either truncated or padded on the right to +meet the constraint. All modeline-field functions must return simple strings +with standard characters, and these take a buffer and a window as arguments. +Modeline-field objects are typically shared amongst, or aliased by, different +buffers' modeline fields lists. These lists are unique allowing fields to +behave the same wherever they occur, but different buffers may display these +fields in different arrangements. + +Whenever one of the following changes occurs, all of a buffer's modeline fields +are updated: +@Begin[Itemize] +A buffer's major mode is set. + +One of a buffer's minor modes is turned on or off. + +A buffer is renamed. + +A buffer's pathname changes. + +A buffer's modified status changes. + +A window's buffer is changed. +@End[Itemize] + +The policy is that whenever one of these changes occurs, it is guaranteed that +the modeline will be updated before the next trip through redisplay. +Furthermore, since the system cannot know what modeline-field objects the +user has added whose update functions rely on these values, or how he has +changed @hid[Default Modeline Fields], we must update all the fields. When any +but the last occurs, the modeline-field update function is invoked once for +each window into the buffer. When a window's buffer changes, each +modeline-field update function is invoked once; other windows' modeline +fields should not be affected due to a given window's buffer changing. + +The user should note that modelines can be updated at any time, so update +functions should be careful to avoid needless delays (for example, waiting for +a local area network to determine information). + +@defun[fun {make-modeline-field}, keys {[name][width][function]}] +@defun1[fun {modeline-field-p}, args @i(modeline-field)] +@defun1[fun {modeline-field-name}, args @i(modeline-field)] +@f[make-modeline-field] returns a modeline-field object with @i[name], +@i[width], and @i[function]. @i[Width] defaults to @nil meaning that the field +is variable width; otherwise, the programmer must supply this as a positive +integer. @i[Function] must take a buffer and window as arguments and return a +@f[simple-string] containing only standard characters. If @i[name] already +names a modeline-field object, then this signals an error. + +@f[modeline-field-name] returns the name field of a modeline-field object. If +this is set with @f[setf], and the new name already names a modeline-field, +then the @f[setf] method signals an error. + +@f[modeline-field-p] returns @true or @nil, depending on whether its argument +is a @f[modeline-field] object. +@enddefun + +@defun[fun {modeline-field}, args {@i[name]}] +This returns the modeline-field object named @i[name]. If none exists, this +returns nil. +@enddefun + +@defun[fun {modeline-field-function}, args {@i[modeline-field]}] +Returns the function called when updating the @i[modeline-field]. When this is +set with @f[setf], the @f[setf] method updates @i[modeline-field] for all +windows on all buffers that contain the given field, so the next trip through +redisplay will reflect the change. All modeline-field functions must return +simple strings with standard characters, and they take a buffer and a window +as arguments. +@enddefun + +@defun[fun {modeline-field-width}, args {@i[modeline-field]}] +Returns the width to which @i[modeline-field] is constrained, or @nil +indicating that it is variable width. When this is set with @f[setf], the +@f[setf] method updates all modeline-fields for all windows on all buffers that +contain the given field, so the next trip through redisplay will reflect the +change. All the fields for any such modeline display must be updated, which is +not the case when setting a modeline-field's function. +@enddefun + +@defun[fun {buffer-modeline-fields}, args {@i[buffer]}] +Returns a copy of the list of @i[buffer]'s modeline-field objects. This list +can be destructively modified without affecting display of @i[buffer]'s +modeline, but modifying any particular field's components (for example, width +or function) causes the changes to be reflected the next trip through redisplay +in every modeline display that uses the modified modeline-field. When this is +set with @f[setf], @f[update-modeline-fields] is called for each window into +@i[buffer]. +@enddefun + +@defun[fun {buffer-modeline-field-p}, args {@i[buffer] @i[field]}] +If @i[field], a modeline-field or the name of one, is in buffer's list of +modeline-field objects, it is returned; otherwise, this returns nil. +@enddefun + +@defun[fun {update-modeline-fields}, args {@i[buffer] @i[window]}] +This invokes each modeline-field object's function from @i[buffer]'s list, +passing @i[buffer] and @i[window]. The results are collected regarding each +modeline-field object's width as appropriate, and the window is marked so +the next trip through redisplay will reflect the changes. If window does not +display modelines, then no computation occurs. +@enddefun + +@defun[fun {update-modeline-field}, args {@i[buffer] @i[window] @i[field-or-name]}] +This invokes the modeline-field object's function for @i[field-or-name], which +is a modeline-field object or the name of one for @i[buffer]. This passes +@i[buffer] and @i[window] to the update function. The result is applied to the +@i[window]'s modeline display using the modeline-field object's width, and the +window is marked so the next trip through redisplay will reflect the changes. +If the window does not display modelines, then no computation occurs. If +@i[field-or-name] is not found in @i[buffer]'s list of modeline-field objects, +then this signals an error. See @f[buffer-modeline-field-p] above. +@enddefun + + + +@chapter(Altering and Searching Text) +@label[doing-stuff] + +@section(Altering Text) +@index(Altering text) +@index(Inserting) +@index(Deleting) +A note on marks and text alteration: @kwd[temporary] marks are invalid +after any change has been made to the text the mark points to; it is an +error to use a temporary mark after such a change has been made. If +text is deleted which has permanent marks pointing into it then they +are left pointing to the position where the text was. + +@defun[fun {insert-character}, args {@i[mark] @i[character]}] +@defun1[fun {insert-string}, args {@i[mark] @i[string]}] +@defun1[fun {insert-region}, args {@i[mark] @i[region]}] +Inserts @i[character], @i[string] or @i[region] at @i[mark]. +@f[insert-character] signals an error if @i[character] is not +@f[string-char-p]. If @i[string] or @i[region] is empty, and @i[mark] is in +some buffer, then @hemlock leaves @f[buffer-modified] of @i[mark]'s buffer +unaffected. +@enddefun + +@defun[fun {ninsert-region}, args {@i[mark] @i[region]}] +Like @f[insert-region], inserts the @i[region] at the @i[mark]'s position, +destroying the source region. This must be used with caution, since if anyone +else can refer to the source region bad things will happen. In particular, one +should make sure the region is not linked into any existing buffer. If +@i[region] is empty, and @i[mark] is in some buffer, then @hemlock leaves +@f[buffer-modified] of @i[mark]'s buffer unaffected. +@enddefun + +@defun[fun {delete-characters}, args {@i[mark] @i[n]}] +This deletes @i[n] characters after the @i[mark] (or -@i[n] before if @i[n] is +negative). If @i[n] characters after (or -@i[n] before) the @i[mark] do not +exist, then this returns @nil; otherwise, it returns @true. If @i[n] is zero, +and @i[mark] is in some buffer, then @hemlock leaves @f[buffer-modified] of +@i[mark]'s buffer unaffected. +@enddefun + +@defun[fun {delete-region}, args {@i[region]}] +This deletes @i[region]. This is faster than @f[delete-and-save-region] +(below) because no lines are copied. If @i[region] is empty and contained in +some buffer's @f[buffer-region], then @hemlock leaves @f[buffer-modified] of +the buffer unaffected. +@enddefun + +@defun[fun {delete-and-save-region}, args {@i[region]}] +This deletes @i[region] and returns a region containing the original +@i[region]'s text. If @i[region] is empty and contained in some buffer's +@f[buffer-region], then @hemlock leaves @f[buffer-modified] of the buffer +unaffected. In this case, this returns a distinct empty region. +@enddefun + +@defun[fun {filter-region}, args {@i[function] @i[region]}] +Destructively modifies @i[region] by replacing the text +of each line with the result of the application of @i[function] to a +string containing that text. @i[Function] must obey the following +restrictions: +@begin[enumerate] +The argument may not be destructively modified. + +The return value may not contain newline characters. + +The return value may not be destructively modified after it is +returned from @i[function]. +@end[enumerate] +The strings are passed in order, and are always simple strings. + +Using this function, a region could be uppercased by doing: +@lisp +(filter-region #'string-upcase region) +@endlisp +@enddefun + + +@section(Text Predicates) +@defun[fun {start-line-p}, args {@i[mark]}] +Returns @true if the @i(mark) points before the first character in a line, +@nil otherwise. +@enddefun + +@defun[fun {end-line-p}, args {@i[mark]}] +Returns @true if the @i(mark) points after the last character in a line and +before the newline, @nil otherwise. +@enddefun + +@defun[fun {empty-line-p}, args {@i[mark]}] +Return @true of the line which @i[mark] points to contains no characters. +@enddefun + +@defun[fun {blank-line-p}, args {@i[line]}] +Returns @true if @i[line] contains only characters with a +@hid[Whitespace] attribute of 1. See chapter @ref[character-attributes] for +discussion of character attributes. +@enddefun + +@defun[fun {blank-before-p}, args {@i[mark]}] +@defun1[fun {blank-after-p}, args {@i[mark]}] +These functions test if all the characters preceding or following +@i[mark] on the line it is on have a @hid[Whitespace] attribute of @f[1]. +@enddefun + +@defun[fun {same-line-p}, args {@i[mark1] @i[mark2]}] +Returns @true if @i(mark1) and @i(mark2) point to the same line, or @nil +otherwise; That is, +@example[(same-line-p a b) <==> (eq (mark-line a) (mark-line b))] +@enddefun + +@defun[fun {mark<}, funlabel {mark-LSS}, args {@i[mark1] @i[mark2]}] +@defun1[fun {mark<=}, funlabel {mark-LEQ}, args {@i[mark1] @i[mark2]}] +@defun1[fun {mark=}, funlabel {mark-EQL}, args {@i[mark1] @i[mark2]}] +@defun1[fun {mark/=}, funlabel {mark-NEQ}, args {@i[mark1] @i[mark2]}] +@defun1[fun {mark>=}, funlabel {mark-GEQ}, args {@i[mark1] @i[mark2]}] +@defun1[fun {mark>}, funlabel {mark-GTR}, args {@i[mark1] @i[mark2]}] +These predicates test the relative ordering of two marks in a piece of +text, that is a mark is @f[mark>] another if it points to a position +after it. If the marks point into different, non-connected pieces of +text, such as different buffers, then it is an error to test their +ordering; for such marks @f[mark=] is always false and @f[mark/=] is +always true. +@enddefun + +@defun[fun {line<}, funlabel {line-LSS}, args {@i[line1] @i[line2]}] +@defun1[fun {line<=}, funlabel {line-LEQ}, args {@i[line1] @i[line2]}] +@defun1[fun {line>=}, funlabel {line-GEQ}, args {@i[line1] @i[line2]}] +@defun1[fun {line>}, funlabel {line-GTR}, args {@i[line1] @i[line2]}] +These predicates test the ordering of @i[line1] and @i[line2]. If the +lines are in unconnected pieces of text it is an error to test their +ordering. +@enddefun + +@defun[fun {lines-related}, args {@i[line1] @i[line2]}] +This function returns @true if @i[line1] and @i[line2] are in the same +piece of text, or @nil otherwise. +@enddefun + +@defun[fun {first-line-p}, args {@i[mark]}] +@defun1[fun {last-line-p}, args {@i[mark]}] +@f[first-line-p] returns @true if there is no line before the line +@i[mark] is on, and @nil otherwise. @i[Last-line-p] similarly tests +tests whether there is no line after @i[mark]. +@enddefun + + +@section(Kill Ring) +@index(Kill ring) +@label(kill-ring) + +@defvar[var {kill-ring}] +This is a ring (see section @ref[rings]) of regions deleted from buffers. +Some commands save affected regions on the kill ring before performing +modifications. You should consider making the command undoable (see section +@ref[undo]), but this is a simple way of achieving a less satisfactory means +for the user to recover. +@enddefvar + +@defun[fun {kill-region}, args {@i[region] @i[current-type]}] +This kills @i[region] saving it in @var[kill-ring]. @i[Current-type] is either +@kwd[kill-forward] or @kwd[kill-backward]. When the @funref[last-command-type] +is one of these, this adds @i[region] to the beginning or end, respectively, of +the top of @var[kill-ring]. The result of calling this is undoable using the +command @hid[Undo] (see the @i[Hemlock User's Manual]). This sets +@f[last-command-type] to @i[current-type], and it interacts with +@f[kill-characters]. +@enddefun + +@defun[fun {kill-characters}, args {@i[mark] @i[count]}] +@defhvar1[var {Character Deletion Threshold}, val {5}] +@f[kill-characters] kills @i[count] characters after @i[mark] if @i[count] is +positive, otherwise before @i[mark] if @i[count] is negative. When @i[count] +is greater than or equal to @hid[Character Deletion Threshold], the killed +characters are saved on @var[kill-ring]. This may be called multiple times +contiguously (that is, without @funref[last-command-type] being set) to +accumulate an effective count for purposes of comparison with the threshold. + +This sets @f[last-command-type], and it interacts with @f[kill-region]. When +this adds a new region to @var[kill-ring], it sets @f[last-command-type] to +@kwd[kill-forward] (if @i[count] is positive) or @kwd[kill-backward] (if +@i[count] is negative). When @f[last-command-type] is @kwd[kill-forward] or +@kwd[kill-backward], this adds the killed characters to the beginning (if +@i[count] is negative) or the end (if @i[count] is positive) of the top of +@var[kill-ring], and it sets @f[last-command-type] as if it added a new region +to @var[kill-ring]. When the kill ring is unaffected, this sets +@f[last-command-type] to @kwd[char-kill-forward] or @kwd[char-kill-backward] +depending on whether @i[count] is positive or negative, respectively. + +This returns mark if it deletes characters. If there are not @i[count] +characters in the appropriate direction, this returns nil. +@enddefun + + +@section(Active Regions) +@index(Active regions) +@label(active-regions) + +Every buffer has a mark stack (page @pageref[mark-stack]) and a mark known as +the point where most text altering nominally occurs. Between the top of the +mark stack, the @f[current-mark], and the @f[current-buffer]'s point, the +@f[current-point], is what is known as the @f[current-region]. Certain +commands signal errors when the user tries to operate on the @f[current-region] +without its having been activated. If the user turns off this feature, then +the @f[current-region] is effectively always active. + +When writing a command that marks a region of text, the programmer should make +sure to activate the region. This typically occurs naturally from the +primitives that you use to mark regions, but sometimes you must explicitly +activate the region. These commands should be written this way, so they do not +require the user to separately mark an area and then activate it. Commands +that modify regions do not have to worry about deactivating the region since +modifying a buffer automatically deactivates the region. Commands that insert +text often activate the region ephemerally; that is, the region is active for +the immediately following command, allowing the user wants to delete the region +inserted, fill it, or whatever. + +Once a marking command makes the region active, it remains active until: +@begin[itemize] +a command uses the region, + +a command modifies the buffer, + +a command changes the current window or buffer, + +a command signals an editor-error, + +or the user types @binding[C-g]. +@end[itemize] + +@defhvar[var "Active Regions Enabled", val {t}] +When this variable is non-@nil, some primitives signal an editor-error if +the region is not active. This may be set to @nil for more traditional @emacs +region semantics. +@enddefhvar + +@defvar[var {ephemerally-active-command-types}] +This is a list of command types (see section @ref[command-types]), and its +initial value is the list of @kwd[ephemerally-active] and @kwd[unkill]. When +the previous command's type is one of these, the @f[current-region] is active +for the currently executing command only, regardless of whether it does +something to deactivate the region. However, the current command may activate +the region for future commands. @kwd[ephemerally-active] is a default command +type that may be used to ephemerally activate the region, and @kwd[unkill] is +the type used by two commands, @hid[Un-kill] and @hid[Rotate Kill Ring] (what +users typically think of as @binding[C-y] and @binding[M-y]). +@enddefvar + +@defun[fun {activate-region}] +This makes the @f[current-region] active. +@enddefun + +@defun[fun {deactivate-region}] +After invoking this the @f[current-region] is no longer active. +@enddefun + +@defun[fun {region-active-p}] +Returns whether the @f[current-region] is active, including ephemerally. This +ignores @hid[Active Regions Enabled]. +@enddefun + +@defun[fun {check-region-active}] +This signals an editor-error when active regions are enabled, and the +@f[current-region] is not active. +@enddefun + +@defun[fun {current-region}, + args {@optional @i[error-if-not-active] @i[deactivate-region]}] +This returns a region formed with @f[current-mark] and @f[current-point], +optionally signaling an editor-error if the current region is not active. +@i[Error-if-not-active] defaults to @true. Each call returns a distinct region +object. Depending on @i[deactivate-region] (defaults to @true), fetching the +current region deactivates it. @hemlock primitives are free to modify text +regardless of whether the region is active, so a command that checks for this +can deactivate the region whenever it is convenient. +@enddefun + + +@section(Searching and Replacing) +@index(Searching) +@index(Replacing) + +Before using any of these functions to do a character search, look at character +attributes (page @pageref[character-attributes]). They provide a facility +similar to the syntax table in real EMACS. Syntax tables are a powerful, +general, and efficient mechanism for assigning meanings to characters in +various modes. + +@defcon[var {search-char-code-limit}] +An exclusive upper limit for the char-code of characters given to the searching +functions. The result of searches for characters with a char-code greater than +or equal to this limit is ill-defined, but it is @i[not] an error to do such +searches. +@enddefcon + +@defun[fun {new-search-pattern}, +args {@i[kind] @i[direction] @i[pattern] @optional @i[result-search-pattern]}] + +Returns a @i[search-pattern] object which can be given to the @f[find-pattern] +and @f[replace-pattern] functions. A search-pattern is a specification of a +particular sort of search to do. @i[direction] is either @kwd[forward] or +@kwd[backward], indicating the direction to search in. @i[kind] specifies the +kind of search pattern to make, and @i[pattern] is a thing which specifies what +to search for. + +The interpretation of @i[pattern] depends on the @i[kind] of pattern being +made. Currently defined kinds of search pattern are: +@begin(description) +@kwd[string-insensitive]@\Does a case-insensitive string search, +@i[pattern] being the string to search for. + +@kwd[string-sensitive]@\Does a case-sensitive string search for +@i[pattern]. + +@kwd[character]@\Finds an occurrence of the character @i[pattern]. +This is case sensitive. + +@kwd[not-character]@\Find a character which is not the character +@i[pattern]. + +@kwd[test]@\Finds a character which satisfies the function @i[pattern]. +This function may not be applied an any particular fashion, so it +should depend only on what its argument is, and should have no +side-effects. + +@kwd[test-not]@\Similar to as @kwd[test], except it finds a character that +fails the test. + +@kwd[any]@\Finds a character that is in the string @i[pattern]. + +@kwd[not-any]@\Finds a character that is not in the string @i[pattern]. +@end(description) + +@i[result-search-pattern], if supplied, is a search-pattern to +destructively modify to produce the new pattern. Where reasonable +this should be supplied, since some kinds of search patterns may +involve large data structures. +@enddefun + +@defun[fun {search-pattern-p}, args {@i[search-pattern]}] +Returns @true if @i[search-pattern] is a @f[search-pattern] object, otherwise +@nil. +@enddefun + +@defun[fun {get-search-pattern}, args {@i[string] @i[direction]}] +@defvar1[var {last-search-pattern}] +@defvar1[var {last-search-string}] +@f[get-search-pattern] interfaces to a default search string and pattern that +search and replacing commands can use. These commands then share a default +when prompting for what to search or replace, and save on consing a search +pattern each time they execute. This uses @hid[Default Search Kind] (see the +@i[Hemlock User's Manual]) when updating the pattern object. This returns the +pattern, so you probably don't need to refer to @var[last-search-pattern], but +@var[last-search-string] is useful when prompting. +@enddefun + +@defun[fun {find-pattern}, args {@i[mark] @i[search-pattern]}] +Find the next match of @i[search-pattern] starting at @i[mark]. If a +match is found then @i[mark] is altered to point before the matched text +and the number of characters matched is returned. If no match is +found then @nil is returned and @i[mark] is not modified. +@enddefun + +@defun[fun {replace-pattern}, args + {@i[mark] @i[search-pattern] @i[replacement] @optional @i[n]}] +Replace @i[n] matches of @i[search-pattern] with the string +@i[replacement] starting at @i[mark]. If @i[n] is @nil (the default) +then replace all matches. A mark pointing before the last replacement +done is returned. +@enddefun + + + +@Chapter(The Current Environment) +@label(current-environment) +@index(Current environment) + +@section(Different Scopes) + In @hemlock the values of @i[variables] (page @pageref[variables]), +@i[key-bindings] (page @pageref(key-bindings)) and +@i[character-attributes] (page @pageref[character-attributes]) may +depend on the @funref(current-buffer) and the modes +active in it. There are three possible scopes for +@hemlock values: +@begin(description) +@i[buffer local]@\The value is present only if the buffer it is local +to is the @f[current-buffer]. + +@i[mode local]@\The value is present only when the mode it is local to +is active in the @f[current-buffer]. + +@i[global]@\The value is always present unless shadowed by a buffer or +mode local value. +@end(description) + + +@section(Shadowing) + It is possible for there to be a conflict between different values +for the same thing in different scopes. For example, there be might a +global binding for a given variable and also a local binding in the +current buffer. Whenever there is a conflict shadowing occurs, +permitting only one of the values to be visible in the current +environment. + + The process of resolving such a conflict can be described as a +search down a list of places where the value might be defined, returning +the first value found. The order for the search is as follows: +@begin(enumerate) +Local values in the current buffer. + +Mode local values in the minor modes of the current buffer, in order +from the highest precedence mode to the lowest precedence mode. The +order of minor modes with equal precedences is undefined. + +Mode local values in the current buffer's major mode. + +Global values. +@end(enumerate) + + + +@chapter(Hemlock Variables) +@index (Hemlock variables) +@label(variables) +@hemlock implements a system of variables separate from normal Lisp variables +for the following reasons: +@begin(enumerate) +@hemlock has different scoping rules which are useful in an editor. @hemlock +variables can be local to a @i(buffer) (page @pageref[buffers]) or a @i(mode) +(page @pageref[modes]). + +@hemlock variables have @i(hooks) (page @pageref[hooks]), lists of functions +called when someone sets the variable. See @f[variable-value] for the +arguments @hemlock passes to these hook functions. + +There is a database of variable names and documentation which makes it easier +to find out what variables exist and what their values mean. +@end(enumerate) + + +@section(Variable Names) +To the user, a variable name is a case insensitive string. This +string is referred to as the @i[string name] of the variable. A +string name is conventionally composed of words separated by spaces. + +In Lisp code a variable name is a symbol. The name of this symbol is +created by replacing any spaces in the string name with hyphens. This +symbol name is always interned in the @hemlock package and referring +to a symbol with the same name in the wrong package is an error. + +@defvar[var {global-variable-names}] +This variable holds a string-table of the names of all the global @hemlock +variables. The value of each entry is the symbol name of the variable. +@enddefvar + +@defun[fun {current-variable-tables}] +This function returns a list of variable tables currently established, +globally, in the @f[current-buffer], and by the modes of the +@f[current-buffer]. This list is suitable for use with +@f[prompt-for-variable]. +@enddefun + + +@section(Variable Functions) +In the following descriptions @i[name] is the symbol name of the variable. + +@defun[fun {defhvar}, args {@i[string-name] @i[documentation]}, + keys {[mode][buffer][hooks][value]}] + This function defines a @hemlock variable. Functions that take a variable +name signal an error when the variable is undefined. +@begin(description) +@i[string-name]@\The string name of the variable to define. + +@i[documentation]@\The documentation string for the variable. + +@multiple{ +@kwd[mode], +@kwd[buffer]}@\ + If @i[buffer] is supplied, the variable is local to that buffer. If @i[mode] +is supplied, it is local to that mode. If neither is supplied, it is global. + +@kwd[value]@\ + This is the initial value for the variable, which defaults to @nil. + +@kwd[hooks]@\ + This is the initial list of functions to call when someone sets the variable's +value. These functions execute before @hemlock establishes the new value. See +@f[variable-value] for the arguments passed to the hook functions. +@end(description) +If a variable with the same name already exists in the same place, then +@f[defhvar] sets its hooks and value from @i[hooks] and @i[value] if the user +supplies these keywords. +@enddefun + +@defun[fun {variable-value}, args {@i[name] @optional @i[kind] @i[where]}] +This function returns the value of a @hemlock variable in some place. +The following values for @i[kind] are defined: +@begin[description] +@kwd[current]@\ + Return the value present in the current environment, taking into consideration +any mode or buffer local variables. This is the default. + +@kwd[global]@\ + Return the global value. + +@kwd[mode]@\ + Return the value in the mode named @i[where]. + +@kwd[buffer]@\ + Return the value in the buffer @i[where]. +@end[description] +When set with @f[setf], @hemlock sets the value of the specified variable and +invokes the functions in its hook list with @i[name], @i[kind], @i[where], and +the new value. +@enddefun + +@defun[fun {variable-documentation}, args + {@i[name] @optional @i[kind] @i[where]}] +@defun1[fun {variable-hooks}, args + {@i[name] @optional @i[kind] @i[where]}] +@defun1[fun {variable-name}, args + {@i[name] @optional @i[kind] @i[where]}] +These function return the documentation, hooks and string name of a +@hemlock variable. The @i[kind] and @i[where] arguments are the same +as for @f[variable-value]. The documentation and hook list may be set +using @f[setf]. +@enddefun + +@defun[fun {string-to-variable}, args {@i[string]}] +This function converts a string into the corresponding variable symbol +name. @i[String] need not be the name of an actual @hemlock variable. +@enddefun + +@defmac[fun {value}, args {@i[name]}] +@defmac1[fun {setv}, args {@i[name] @i[new-value]}] +These macros get and set the current value of the @hemlock variable +@i[name]. @i[Name] is not evaluated. There is a @f[setf] form for +@f[value]. +@enddefmac + +@Defmac[Fun {hlet}, Args {(@Mstar<(@i[var] @i[value])>) @Mstar<@i[form]>}] +This macro is very similar to @f[let] in effect; within its scope each +of the @hemlock variables @i[var] have the respective @i[value]s, but +after the scope is exited by any means the binding is removed. This +does not cause any hooks to be invoked. The value of the last +@i[form] is returned. +@enddefmac + +@defun[fun {hemlock-bound-p}, args {@i[name] @optional @i[kind] @i[where]}] +Returns @true if @i[name] is defined as a @hemlock variable in the +place specified by @i[kind] and @i[where], or @nil otherwise. +@enddefun + +@defun[fun {delete-variable}, args {@i(name) @optional @i[kind] @i[where]}] +@defhvar1[var {Delete Variable Hook}] +@f[delete-variable] makes the @hemlock variable @i[name] no longer +defined in the specified place. @i[Kind] and @i[where] have the same +meanings as they do for @f[variable-value], except that @kwd[current] +is not available, and the default for @i[kind] is @kwd[global] + +An error will be signaled if no such variable exists. The hook, +@hid[Delete Variable Hook] is invoked with the same arguments before the +variable is deleted. +@enddefun + + +@section(Hooks) +@index(Hooks) +@label[hooks] +@hemlock actions such as setting variables, changing buffers, changing windows, +turning modes on and off, etc., often have hooks associated with them. A hook +is a list of functions called before the system performs the action. The +manual describes the object specific hooks with the rest of the operations +defined on these objects. + +Often hooks are stored in @hemlock variables, @hid[Delete Buffer Hook] and +@hid[Set Window Hook] for example. This leads to a minor point of confusion +because these variables have hooks that the system executes when someone +changes their values. These hook functions @hemlock invokes when someone sets +a variable are an example of a hook stored in an object instead of a @hemlock +variable. These are all hooks for editor activity, but @hemlock keeps them in +different kinds of locations. This is why some of the routines in this section +have a special interpretation of the hook @i[place] argument. + +@defmac[fun {add-hook}, args {@i[place] @i[hook-fun]}] +@defmac1[fun {remove-hook}, args {@i[place] @i[hook-fun]}] +These macros add or remove a hook function in some @i[place]. If @i[hook-fun] +already exists in @i[place], this call has no effect. If @i[place] is a +symbol, then it is a @hemlock variable; otherwise, it is a generalized variable +or storage location. Here are two examples: +@Begin[ProgramExample] +(add-hook delete-buffer-hook 'remove-buffer-from-menu) + +(add-hook (variable-hooks 'check-mail-interval) + 'reschedule-mail-check) +@End[ProgramExample] +@enddefmac + +@defmac[fun {invoke-hook}, args {@i[place] @rest @i[args]}] +This macro calls all the functions in @i[place]. If @i[place] is a symbol, +then it is a @hemlock variable; otherwise, it is a generalized variable. +@enddefun + + + +@chapter(Commands) +@index (Commands) +@label[commands] + + +@section(Introduction) +The way that the user tells @hemlock to do something is by invoking a +@i(command). Commands have three attributes: +@begin(description) +@i[name]@\A command's name provides a way to refer to it. Command +names are usually capitalized words separated by spaces, such as +@hid[Forward Word]. + +@i[documentation]@\The documentation for a command is used by +on-line help facilities. + +@i[function]@\A command is implemented by a Lisp function, which is callable +from Lisp. +@end(description) + +@defvar[var {command-names}] +Holds a string-table (page @pageref[string-tables]) associating +command names to command objects. Whenever a new command is defined +it is entered in this table. +@enddefvar + + +@subsection(Defining Commands) + +@defmac[fun {defcommand}, args +{@^@mgroup<@i[command-name] @MOR (@i[command-name] @i[function-name])> @i[lambda-list] +@\@i[command-doc] @i[function-doc] @mstar<@i[form]>}] + +Defines a command named @i[name]. @f[defcommand] creates a function to +implement the command from the @i[lambda-list] and @i[form]'s supplied. The +@i[lambda-list] must specify one required argument, see section +@ref[invoking-commands-as-functions], which by convention is typically named +@f[p]. If the caller does not specify @i[function-name], @f[defcommand] +creates the command name by replacing all spaces with hyphens and appending +"@f[-command]". @i[Function-doc] becomes the documentation for the function +and should primarily describe issues involved in calling the command as a +function, such as what any additional arguments are. @i[Command-doc] becomes +the command documentation for the command. @enddefmac + +@defun[fun {make-command}, args + {@i[name] @i[documentation] @i[function]}] +Defines a new command named @i[name], with command documentation +@I[documentation] and function @i[function]. The command in entered +in the string-table @varref[command-names], with the command object as +its value. Normally command implementors will use the @f[defcommand] +macro, but this permits access to the command definition mechanism at +a lower level, which is occasionally useful. +@enddefun + +@defun[fun {commandp}, args {@i[command]}] +Returns @true if @i[command] is a @f[command] object, otherwise @nil. +@enddefun + +@defun[fun {command-documentation}, args {@i[command]}] +@defun1[fun {command-function}, args {@i[command]}] +@defun1[fun {command-name}, args {@i[command]}] +Returns the documentation, function, or name for @i[command]. These +may be set with @f[setf]. +@enddefun + + +@subsection(Command Documentation) +@i[Command documentation] is a description of what the command does +when it is invoked as an extended command or from a key. Command +documentation may be either a string or a function. If the +documentation is a string then the first line should briefly summarize +the command, with remaining lines filling the details. Example: +@lisp +(defcommand "Forward Character" (p) + "Move the point forward one character. + With prefix argument move that many characters, with negative + argument go backwards." + "Move the point of the current buffer forward p characters." + . . .) +@endlisp + +Command documentation may also be a function of one argument. The +function is called with either @kwd[short] or @kwd[full], indicating +that the function should return a short documentation string or do +something to document the command fully. + + +@section(The Command Interpreter) +@index[Interpreter, command] +@index[Invocation, command] +@index[Command interpreter] + +The @i[command interpreter] is a function which reads key-events (see section +@ref[key-events-intro]) from the keyboard and dispatches to different commands +on the basis of what the user types. When the command interpreter executes a +command, we say it @i[invokes] the command. The command interpreter also +provides facilities for communication between commands contiguously running +commands, such as a last command type register. It also takes care of +resetting communication mechanisms, clearing the echo area, displaying partial +keys typed slowly by the user, etc. + +@defvar[var {invoke-hook}] +This variable contains a function the command interpreter calls when it wants +to invoke a command. The function receives the command and the prefix argument +as arguments. The initial value is a function which simply funcalls the +@f[command-function] of the command with the supplied prefix argument. This is +useful for implementing keyboard macros and similar things. +@enddefhvar + +@defhvar[var "Command Abort Hook"] +The command interpreter invokes the function in this variable whenever someone +aborts a command (for example, if someone called @f[editor-error]). +@enddefhvar + +When @hemlock initially starts the command interpreter is in control, but +commands may read from the keyboard themselves and assign whatever +interpretation they will to the key-events read. Commands may call the command +interpreter recursively using the function @funref[recursive-edit]. + + +@subsection(Editor Input) +@label[key-events-intro] +@index[key-events] + +The canonical representation of editor input is a key-event structure. Users +can bind commands to keys (see section @ref[key-bindings]), which are non-zero +length sequences of key-events. A key-event consists of an identifying token +known as a @i[keysym] and a field of bits representing modifiers. Users define +keysyms, integers between 0 and 65535 inclusively, by supplying names that +reflect the legends on their keyboard's keys. Users define modifier names +similarly, but the system chooses the bit and mask for recognizing the +modifier. You can use keysym and modifier names to textually specify +key-events and Hemlock keys in a @f[#k] syntax. The following are some +examples: +@begin[programexample] + #k"C-u" + #k"Control-u" + #k"c-m-z" + #k"control-x meta-d" + #k"a" + #k"A" + #k"Linefeed" +@end[programexample] +This is convenient for use within code and in init files containing +@f[bind-key] calls. + +The @f[#k] syntax is delimited by double quotes, but the system parses the +contents rather than reading it as a Common Lisp string. Within the double +quotes, spaces separate multiple key-events. A single key-event optionally +starts with modifier names terminated by hyphens. Modifier names are +alphabetic sequences of characters which the system uses case-insensitively. +Following modifiers is a keysym name, which is case-insensitive if it consists +of multiple characters, but if the name consists of only a single character, +then it is case-sensitive. + +You can escape special characters @dash hyphen, double quote, open angle +bracket, close angle bracket, and space @dash with a backslash, and you can +specify a backslash by using two contiguously. You can use angle brackets to +enclose a keysym name with many special characters in it. Between angle +brackets appearing in a keysym name position, there are only two special +characters, the closing angle bracket and backslash. + +For more information on key-events see section @ref[key-events]. + + + +@subsection(Binding Commands to Keys) +@label[Key-Bindings] +@Index[Key Bindings] + +The command interpreter determines which command to invoke on the basis of +@i[key bindings]. A key binding is an association between a command and a +sequence of key-events (see section @ref[key-events-intro]. A sequence of +key-events is called a @i[key] and is represented by a single key-event or a +sequence (list or vector) of key-events. + +Since key bindings may be local to a mode or buffer, the current environment +(page @pageref[current-environment]) determines the set of key bindings in +effect at any given time. When the command interpreter tries to find the +binding for a key, it first checks if there is a local binding in the +@w[@funref[current-buffer]], then if there is a binding in each of the minor +modes and the major mode for the current buffer @w[(page @pageref[modes])], and +finally checks to see if there is a global binding. If no binding is found, +then the command interpreter beeps or flashes the screen to indicate this. + +@defun[fun {bind-key}, args + {@i(name) @i(key) @optional @i[kind] @i[where]}] + This function associates command @i[name] and @i[key] in some environment. +@i[Key] is either a key-event or a sequence of key-events. There are three +possible values of @i[kind]: +@begin(description) +@kwd[global]@\ + The default, make a global key binding. + +@kwd[mode]@\ + Make a mode specific key binding in the mode whose name is @i[where]. + +@kwd[buffer]@\ + Make a binding which is local to buffer @i[where]. +@end(description) + +This processes @i[key] for key translations before establishing the binding. +See section @ref[key-trans]. + +If the key is some prefix of a key binding which already exists in the +specified place, then the new one will override the old one, effectively +deleting it. + +@f[ext:do-alpha-key-events] is useful for setting up bindings in certain new +modes. +@enddefun + +@defun[fun {command-bindings}, args {@i[command]}] +This function returns a list of the places where @i[command] is bound. A place +is specified as a list of the key (always a vector), the kind of binding, and +where (either the mode or buffer to which the binding is local, or @nil if it +is a global). +@enddefun + +@defun[fun {delete-key-binding}, args {@i[key] @optional @i[kind] @i[where]}] +This function removes the binding of @i[key] in some place. @i[Key] is either +a key-event or a sequence of key-events. @i[kind] is the kind of binding to +delete, one of @kwd[global] (the default), @kwd[mode] or @kwd[buffer]. If +@i[kind] is @kwd[mode], @i[where] is the mode name, and if @i[kind] is +@kwd[buffer], then @i[where] is the buffer. + +This function signals an error if @i[key] is unbound. + +This processes @i[key] for key translations before deleting the binding. See +section @ref[key-trans]. +@enddefun + +@defun[fun {get-command}, args {@i[key] @optional @i[kind] @i[where]}] +This function returns the command bound to @i[key], returning @nil if it is +unbound. @i[Key] is either a key-event or a sequence of key-events. If +@i[key] is an initial subsequence of some keys, then this returns the keyword +@kwd[prefix]. There are four cases of @i[kind]: +@begin(description) +@kwd[current]@\ + Return the current binding of @i[key] using the current buffer's search list. +If there are any transparent key bindings for @i[key], then they are returned +in a list as a second value. + +@kwd[global]@\ + Return the global binding of @i[key]. This is the default. + +@kwd[mode]@\ + Return the binding of @i[key] in the mode named @i[where]. + +@kwd[buffer]@\ + Return the binding of @i[key] local to the buffer @i[where]. +@end(description) + +This processes @i[key] for key translations before looking for any binding. +See section @ref[key-trans]. +@enddefun + +@defun[fun {map-bindings}, Args {@i[function] @i[kind] @optional @i[where]}] +This function maps over the key bindings in some place. For each binding, this +passes @i[function] the key and the command bound to it. @i[Kind] and +@i[where] are the same as in @f[bind-key]. The key is not guaranteed to remain +valid after a given iteration. +@enddefmac + + +@subsection[Key Translation] +@index[bit-prefix keys] +@index[key translation] +@index[translating keys] +@label[key-trans] +Key translation is a process that the command interpreter applies to keys +before doing anything else. There are two kinds of key translations: +substitution and bit-prefix. In either case, the command interpreter +translates a key when a specified key-event sequence appears in a key. + +In a substitution translation, the system replaces the matched subsequence with +another key-event sequence. Key translation is not recursively applied to the +substituted key-events. + +In a bit-prefix translation, the system removes the matched subsequence and +effectively sets the specified bits in the next key-event in the key. + +While translating a key, if the system encounters an incomplete final +subsequence of key-events, it aborts the translation process. This happens +when those last key-events form a prefix of some translation. It also happens +when they translate to a bit-prefix, but there is no following key-event to +which the system can apply the indicated modifier. If there is a binding for +this partially untranslated key, then the command interpreter will invoke that +command; otherwise, it will wait for the user to type more key-events. + +@defun[fun {key-translation}, args {@i[key]}] +This form is @f[setf]'able and allows users to register key translations that +the command interpreter will use as users type key-events. + +This function returns the key translation for @i[key], returning @nil if there +is none. @i[Key] is either a key-event or a sequence of key-events. If +@i[key] is a prefix of a translation, then this returns @kwd[prefix]. + +A key translation is either a key or modifier specification. The bits +translations have a list form: @w<@f[(:bits {]@i[bit-name]@f[}*)]>. + +Whenever @i[key] appears as a subsequence of a key argument to the binding +manipulation functions, that portion will be replaced with the translation. +@enddefun + + + +@subsection[Transparent Key Bindings] +@label[transparent-key-bindings] +@index[Transparent key bindings] + +Key bindings local to a mode may be @i[transparent]. A transparent key +binding does not shadow less local key bindings, but rather indicates that +the bound command should be invoked before the first normal key binding. +Transparent key bindings are primarily useful for implementing minor modes +such as auto fill and word abbreviation. There may be several transparent +key bindings for a given key, in which case all of the commands bound are +invoked in the order they were found. If there no normal key binding for a +key typed, then the command interpreter acts as though the key is unbound +even if there are transparent key bindings. + +The @kwd[transparent-p] argument to @funref[defmode] determines whether the +key bindings in a mode are transparent or not. + + +@subsection (Interactive) +@index (Keyboard macro vs. interactive) +@index (Interactive vs. keyboard macro) +@Hemlock supports keyboard macros. A user may enter a mode where the editor +records his actions, and when the user exits this mode, the command @hid[Last +Keyboard Macro] plays back the actions. Some commands behave differently when +invoked as part of the definition of a keyboard macro. For example, when used +in a keyboard macro, a command that @f[message]'s useless user confirmation +will slow down the repeated invocations of @hid[Last Keyboard Macro] because +the command will pause on each execution to make sure the user sees the +message. This can be eliminated with the use of @f[interactive]. As another +example, some commands conditionally signal an editor-error versus simply +beeping the device depending on whether it executes on behalf of the user or a +keyboard macro. + +@defun[fun {interactive}] +This returns @true when the user invoked the command directly. +@enddefun + + +@section(Command Types) +@index(Command types) +@label(command-types) +In many editors the behavior of a command depends on the kind of command +invoked before it. @hemlock provides a mechanism to support this known as +@i(command type). + +@defun[fun {last-command-type}] +This returns the command type of the last command invoked. If this is set with +@f[setf], the supplied value becomes the value of @f[last-command-type] until +the next command completes. If the previous command did not set +@f[last-command-type], then its value is @nil. Normally a command type is a +keyword. The command type is not cleared after a command is invoked due to a +transparent key binding. +@enddefun + + +@section(Command Arguments) +@label[invoking-commands-as-functions] +There are three ways in which a command may be invoked: It may be bound to a +key which has been typed, it may be invoked as an extended command, or it may +be called as a Lisp function. Ideally commands should be written in such a way +that they will behave sensibly no matter which way they are invoked. The +functions which implement commands must obey certain conventions about argument +passing if the command is to function properly. + + +@subsection(The Prefix Argument) +@index(Prefix arguments) +Whenever a command is invoked it is passed as its first argument what +is known as the @i[prefix argument]. The prefix argument is always +either an integer or @nil. When a command uses this value it is +usually as a repeat count, or some conceptually similar function. + +@defun[fun {prefix-argument}] +This function returns the current value of the prefix argument. When +set with @f[setf], the new value becomes the prefix argument for the +next command. +@enddefun + +If the prefix argument is not set by the previous command then the +prefix argument for a command is @nil. The prefix argument is not cleared +after a command is invoked due to a transparent key binding. + + +@subsection(Lisp Arguments) +It is often desirable to call commands from Lisp code, in which case +arguments which would otherwise be prompted for are passed as optional +arguments following the prefix argument. A command should prompt for +any arguments not supplied. + + +@section(Recursive Edits) +@index(Recursive edits) +@defmac[fun {use-buffer}, args {@i[buffer] @mstar<@i[form]>}] +The effect of this is similar to setting the current-buffer to @i[buffer] +during the evaluation of @i[forms]. There are restrictions placed on what the +code can expect about its environment. In particular, the value of any global +binding of a @hemlock variable which is also a mode local variable of some mode +is ill-defined; if the variable has a global binding it will be bound, but the +value may not be the global value. It is also impossible to nest +@f[use-buffer]'s in different buffers. The reason for using @f[use-buffer] is +that it may be significantly faster than changing @f[current-buffer] to +@i[buffer] and back. +@enddefmac + +@defun[fun {recursive-edit}, args {@optional @i[handle-abort]}] +@defhvar1[var {Enter Recursive Edit Hook}] +@index[aborting] +@f[recursive-edit] invokes the command interpreter. The command interpreter +will read from the keyboard and invoke commands until it is terminated with +either @f[exit-recursive-edit] or @f[abort-recursive-edit]. + +Normally, an editor-error or @bf[C-g] aborts the command in progress and +returns control to the top-level command loop. If @f[recursive-edit] is used +with @i[handle-abort] true, then @f[editor-error] or @bf[C-g] will only abort +back to the recursive command loop. + +Before the command interpreter is entered the hook +@hid[Enter Recursive Edit Hook] is invoked. +@enddefun + +@defun[fun {in-recursive-edit}] +This returns whether the calling point is dynamically within a recursive edit +context. +@enddefun + +@defun[fun {exit-recursive-edit}, args {@optional @i[values-list]}] +@defhvar1[var {Exit Recursive Edit Hook}] +@f[exit-recursive-edit] exits a recursive edit returning as multiple values +each element of @i[values-list], which defaults to @nil. This invokes +@hid[Exit Recursive Edit Hook] after exiting the command interpreter. If no +recursive edit is in progress, then this signals an error. +@enddefun + +@defun[fun {abort-recursive-edit}, args {@rest @i[args]}] +@defhvar1[var {Abort Recursive Edit Hook}] +@f[abort-recursive-edit] terminates a recursive edit by applying +@funref[editor-error] to @i[args] after exiting the command interpreter. This +invokes @hid[Abort Recursive Edit Hook] with @i[args] before aborting the +recursive edit . If no recursive edit is in progress, then this signals an +error. +@enddefun + + + +@Chapter(Modes) +@label[modes] +@index (Modes) +A mode is a collection of @hemlock values which may be present in the current +environment @w<(page @pageref(current-environment))> depending on the editing +task at hand. Examples of typical modes are @hid[Lisp], for editing Lisp code, +and @hid[Echo Area], for prompting in the echo area. + + +@section(Mode Hooks) + When a mode is added to or removed from a buffer, its @i[mode hook] +is invoked. The hook functions take two arguments, the buffer +involved and @true if the mode is being added or @nil if it is being +removed. + +Mode hooks are typically used to make a mode do something additional to +what it usually does. One might, for example, make a text mode hook +that turned on auto-fill mode when you entered. + + +@section(Major and Minor Modes) +There are two kinds of modes, @i[major] modes and @i[minor] modes. A buffer +always has exactly one major mode, but it may have any number of minor modes. +Major modes may have mode character attributes while minor modes may not. + +A major mode is usually used to change the environment in some major way, such +as to install special commands for editing some language. Minor modes +generally change some small attribute of the environment, such as whether lines +are automatically broken when they get too long. A minor mode should work +regardless of what major mode and minor modes are in effect. + +@defhvar[var {Default Modes}, val {("Fundamental" "Save")}] +This variable contains a list of mode names which are instantiated in a +buffer when no other information is available. +@enddefhvar + +@defvar[var {mode-names}] +Holds a string-table of the names of all the modes. +@enddefvar + +@defcom[com "Illegal"] +This is a useful command to bind in modes that wish to shadow global bindings +by making them effectively illegal. Also, although less likely, minor modes +may shadow major mode bindings with this. This command calls @f[editor-error]. +@enddefcom + + +@section(Mode Functions) + +@defun[fun {defmode}, args {@i[name]}, + keys {[setup-function][cleanup-function][major-p]}, + morekeys {[precedence][transparent-p][documentation]}] +This function defines a new mode named @i[name], and enters it in +@varref[mode-names]. If @i[major-p] is supplied and is not @nil +then the mode is a major mode; otherwise it is a minor mode. + +@i[Setup-function] and @i[cleanup-function] are functions which are +invoked with the buffer affected, after the mode is turned on, and +before it is turned off, respectively. These functions typically are +used to make buffer-local key or variable bindings and to remove them +when the mode is turned off. + +@i[Precedence] is only meaningful for a minor mode. The precedence of a +minor mode determines the order in which it in a buffer's list of modes. +When searching for values in the current environment, minor modes are +searched in order, so the precedence of a minor mode determines which value +is found when there are several definitions. + +@i[Transparent-p] determines whether key bindings local to the defined mode +are transparent. Transparent key bindings are invoked in addition to the +first normal key binding found rather than shadowing less local key bindings. + +@i[Documentation] is some introductory text about the mode. Commands such as +@hid[Describe Mode] use this. +@enddefun + +@defun[fun {mode-documentation}, args {@i[name]}] +This function returns the documentation for the mode named @i[name]. +@enddefun + +@defun[fun {buffer-major-mode}, args {@i[buffer]}] +@defhvar1[var {Buffer Major Mode Hook}] +@f[buffer-major-mode] returns the name of @i[buffer]'s major mode. +The major mode may be changed with @f[setf]; then + @hid[Buffer Major Mode Hook] is invoked with +@i[buffer] and the new mode. +@enddefun + +@defun[fun {buffer-minor-mode}, args {@i[buffer] @i[name]}] +@defhvar1[var {Buffer Minor Mode Hook}] +@f[buffer-minor-mode] returns @true if the minor mode @i[name] is active +in @i[buffer], @nil otherwise. A minor mode may be turned on or off +by using @f[setf]; then @hid[Buffer Minor Mode Hook] is +invoked with @i[buffer], @i[name] and the new value. +@enddefun + +@defun[fun {mode-variables}, args {@i[name]}] +Returns the string-table of mode local variables. +@enddefun + +@defun[fun {mode-major-p}, args {@i[name]}] +Returns @true if @i[name] is the name of a major mode, or @nil if +it is the name of a minor mode. It is an error for @i[name] not to be +the name of a mode. +@enddefun + + + +@chapter(Character Attributes) +@label(character-attributes) +@index(Character attributes) +@index(Syntax tables) + +@section(Introduction) +Character attributes provide a global database of information about characters. +This facility is similar to, but more general than, the @i[syntax tables] of +other editors such as @f[EMACS]. For example, you should use character +attributes for commands that need information regarding whether a character is +@i[whitespace] or not. Use character attributes for these reasons: +@begin(enumerate) +If this information is all in one place, then it is easy the change the +behavior of the editor by changing the syntax table, much easier than it would +be if character constants were wired into commands. + +This centralization of information avoids needless duplication of effort. + +The syntax table primitives are probably faster than anything that can be +written above the primitive level. +@end(enumerate) + +Note that an essential part of the character attribute scheme is that +@i[character attributes are global and are there for the user to change.] +Information about characters which is internal to some set of commands (and +which the user should not know about) should not be maintained as a character +attribute. For such uses various character searching abilities are provided by +the function @funref[find-pattern]. + +@defcon[var {syntax-char-code-limit}] +The exclusive upper bound on character codes which are significant in +the character attribute functions. Font and bits are always ignored. +@enddefcon + + +@section(Character Attribute Names) + +As for @hemlock variables, character attributes have a user visible +string name, but are referred to in Lisp code as a symbol. The string +name, which is typically composed of capitalized words separated by +spaces, is translated into a keyword by replacing all spaces with +hyphens and interning this string in the keyword package. The +attribute named @hid[Ada Syntax] would thus become @kwd[ada-syntax]. + +@defvar[var {character-attribute-names}] +Whenever a character attribute is defined, its name is entered in +this string table (page @pageref[string-tables]), with the +corresponding keyword as the value. +@enddefvar + + +@section(Character Attribute Functions) + +@defun[fun {defattribute}, args + {@i[name] @i[documentation] @optional @i[type] @i[initial-value]}] + This function defines a new character attribute with @i[name], a +simple-string. Character attribute operations take attribute arguments as a +keyword whose name is @i[name] uppercased with spaces replaced by hyphens. + +@i[Documentation] describes the uses of the character attribute. + +@i[Type], which defaults to @w<@f[(mod 2)]>, specifies what type the values of +the character attribute are. Values of a character attribute may be of any +type which may be specified to @f[make-array]. @i[Initial-value] (default +@f[0]) is the value which all characters will initially have for this +attribute. +@enddefun + +@defun[fun {character-attribute-name}, args {@i[attribute]}] +@defun1[fun {character-attribute-documentation}, args {@i[attribute]}] +These functions return the name or documentation for @i[attribute]. +@enddefun + +@defun[fun {character-attribute}, args {@i[attribute] @i[character]}] +@defhvar1[var {Character Attribute Hook}] +@f[character-attribute] returns the value of @i[attribute] for @i[character]. +This signals an error if @i[attribute] is undefined. + +@f[setf] will set a character's attributes. This @f[setf] method invokes the +functions in @hid[Character Attribute Hook] on the attribute and character +before it makes the change. + +If @i[character] is @nil, then the value of the attribute for the beginning or +end of the buffer can be accessed or set. The buffer beginning and end thus +become a sort of fictitious character, which simplifies the use of character +attributes in many cases. +@enddefun + +@defun[fun {character-attribute-p}, args {@i[symbol]}] +This function returns @true if @i[symbol] is the name of a character attribute, +@nil otherwise. +@enddefun + +@defun[fun {shadow-attribute}, args +{@i[attribute] @i[character] @i[value] @i[mode]}] +@defhvar1[var {Shadow Attribute Hook}] +This function establishes @i[value] as the value of @i[character]'s +@i[attribute] attribute when in the mode @i[mode]. @i[Mode] must be the name +of a major mode. @hid[Shadow Attribute Hook] is invoked with the same +arguments when this function is called. If the value for an attribute is set +while the value is shadowed, then only the shadowed value is affected, not the +global one. +@enddefun + +@defun[fun {unshadow-attribute}, args {@i[attribute] @i[character] @i[mode]}] +@defhvar1[var {Unshadow Attribute Hook}] +Make the value of @i[attribute] for @i[character] no longer be shadowed in +@i[mode]. @hid[Unshadow Attribute Hook] is invoked with the same arguments +when this function is called. +@enddefun + +@defun[fun {find-attribute}, + args {@i[mark] @i[attribute] @optional @i[test]}] +@defun1[fun {reverse-find-attribute}, + args {@i[mark] @i[attribute] @optional @i[test]}] + These functions find the next (or previous) character with some value for the +character attribute @i[attribute] starting at @i[mark]. They pass @i[Test] one +argument, the value of @i[attribute] for the character tested. If the test +succeeds, then these routines modify @i[mark] to point before (after for +@f[reverse-find-attribute]) the character which satisfied the test. If no +characters satisfy the test, then these return @nil, and @i[mark] remains +unmodified. @i[Test] defaults to @f[not zerop]. There is no guarantee that +the test is applied in any particular fashion, so it should have no side +effects and depend only on its argument. +@enddefun + + +@section(Character Attribute Hooks) + +It is often useful to use the character attribute mechanism as an abstract +interface to other information about characters which in fact is stored +elsewhere. For example, some implementation of @hemlock might decide to define +a @hid[Print Representation] attribute which controls how a character is +displayed on the screen. + +To make this easy to do, each attribute has a list of hook functions +which are invoked with the attribute, character and new value whenever +the current value changes for any reason. + +@defun[fun {character-attribute-hooks}, args {@i[attribute]}] +Return the current hook list for @i[attribute]. This may be set with +@f[setf]. The @f[add-hook] and @macref[remove-hook] macros should +be used to manipulate these lists. +@enddefun + + +@section (System Defined Character Attributes) +@label(sys-def-chars) +These are predefined in @hemlock: +@begin[description] +@hid[Whitespace]@\ +A value of @f[1] indicates the character is whitespace. + +@hid[Word Delimiter]@\ +A value of @f[1] indicates the character separates words (see section +@ref[text-functions]). + +@hid[Digit]@\ +A value of @f[1] indicates the character is a base ten digit. This may be +shadowed in modes or buffers to mean something else. + +@hid[Space]@\ +This is like @hid[Whitespace], but it should not include @binding[Newline]. +@hemlock uses this primarily for handling indentation on a line. + +@hid[Sentence Terminator]@\ +A value of @f[1] indicates these characters terminate sentences (see section +@ref[text-functions]). + +@hid[Sentence Closing Char]@\ +A value of @f[1] indicates these delimiting characters, such as @binding["] +or @binding[)], may follow a @hid[Sentence Terminator] (see section +@ref[text-functions]). + +@hid[Paragraph Delimiter]@\ +A value of @f[1] indicates these characters delimit paragraphs when they begin +a line (see section @ref[text-functions]). + +@hid[Page Delimiter]@\ +A value of @f[1] indicates this character separates logical pages (see section +@ref[logical-pages]) when it begins a line. + +@hid[Scribe Syntax]@\ +This uses the following symbol values: +@begin[multiple] +@begin[description] +@nil@\These characters have no interesting properties. + +@kwd[escape]@\This is @binding[@@] for the Scribe formatting language. + +@kwd[open-paren]@\These characters begin delimited text. + +@kwd[close-paren]@\These characters end delimited text. + +@kwd[space]@\These characters can terminate the name of a formatting command. + +@kwd[newline]@\These characters can terminate the name of a formatting command. +@end[description] +@end[multiple] + + +@hid[Lisp Syntax]@\ +This uses symbol values from the following: +@begin[multiple] +@begin[description] +@nil@\These characters have no interesting properties. + +@kwd[space]@\These characters act like whitespace and should not include +@binding[Newline]. + +@kwd[newline]@\This is the @binding[Newline] character. + +@kwd[open-paren]@\This is @binding[(] character. + +@kwd[close-paren]@\This is @binding[)] character. + +@kwd[prefix]@\This is a character that is a part of any form it precedes @dash +for example, the single quote, @binding[']. + +@kwd[string-quote]@\This is the character that quotes a string literal, +@binding["].@comment["] + +@kwd[char-quote]@\This is the character that escapes a single character, +@binding[\]. + +@kwd[comment]@\This is the character that makes a comment with the rest of the +line, @binding[;]. + +@kwd[constituent]@\These characters are constitute symbol names. +@end[description] +@end[multiple] + +@end[description] + + + +@chapter (Controlling the Display) +@section (Windows) +@tag[windows] +@index(Windows) +@index(modelines) + +A window is a mechanism for displaying part of a buffer on some physical +device. A window is a way to view a buffer but is not synonymous with one; a +buffer may be viewed in any number of windows. A window may have a +@i[modeline] which is a line of text displayed across the bottom of a window to +indicate status information, typically related to the buffer displayed. + + +@section (The Current Window) +@index (Current window) +@defun[fun {current-window}, args {}] +@defhvar1[var {Set Window Hook}] +@f[current-window] returns the window in which the cursor is currently +displayed. The cursor always tracks the buffer-point of the corresponding +buffer. If the point is moved to a position which would be off the screen the +recentering process is invoked. Recentering shifts the starting point of the +window so that the point is once again displayed. The current window may be +changed with @f[setf]. Before the current window is changed, the hook @hid[Set +Window Hook] is invoked with the new value. +@enddefun + +@defvar[var {window-list}] +Holds a list of all the window objects made with @funref[make-window]. +@enddefvar + + +@section(Window Functions) + +@defun[fun {make-window}, args {@i[mark]}, + keys {[modelinep][window][ask-user]}, + morekeys {[x][y][width][height]}, + morekeys {[proportion]}] +@defhvar1[var {Default Window Width}] +@defhvar1[var {Default Window Height}] +@defhvar1[var {Make Window Hook}] + +@comment[NOTE, we purposefully do not document the font-family or device + arguments since we don't officially support fonts or devices.] + +@f[make-window] returns a window displaying text starting at @i[mark], which +must point into a buffer. If it could not make a window on the device, it +returns nil. The default action is to make the new window a proportion of the +@f[current-window]'s height to make room for the new window. + +@i[Modelinep] specifies whether the window should display buffer modelines. + +@i[Window] is a device dependent window to be used with the Hemlock window. +The device may not support this argument. @i[Window] becomes the parent window +for a new group of windows that behave in a stack orientation as windows do on +the terminal. + +If @i[ask-user] is non-@nil, @hemlock prompts the user for the missing +dimensions (@i[x], @i[y], @i[width], and @i[height]) to make a new group of +windows, as with the @i[window] argument. The device may not support this +argument. Non-null values other than @f[t] may have device dependent meanings. +@i[X] and @i[y] are in pixel units, but @i[width] and @i[height] are characters +units. @hid[Default Window Width] and @hid[Default Window Height] are the +default values for the @i[width] and @i[height] arguments. + +@i[Proportion] determines what proportion of the @f[current-window]'s height +the new window will use. The @f[current-window] retains whatever space left +after accommodating the new one. The default is to split the window in half. + +This invokes @hid[Make Window Hook] with the new window. +@enddefun + +@defun[fun {windowp}, args {@i[window]}] +This function returns @true if @i[window] is a @f[window] object, otherwise +@nil. +@enddefun + +@defun[fun {delete-window}, args {@i[window]}] +@defhvar1[var {Delete Window Hook}] +@f[delete-window] makes @i[window] go away, first invoking @hid[Delete Window +Hook] with @i[window]. +@enddefun + +@defun[fun {window-buffer}, args {@i[window]}] +@defhvar1[var {Window Buffer Hook}] +@f[window-buffer] returns the buffer from which the window displays +text. This may be changed with @f[setf], in which case the hook +@hid[Window Buffer Hook] is invoked beforehand with the window and the +new buffer. +@enddefun + +@defun[fun {window-display-start}, args {@i[window]}] +@defun1[fun {window-display-end}, args {@i[window]}] +@f[window-display-start] returns the mark that points before the first +character displayed in @i[window]. Note that if @i[window] is the current +window, then moving the start may not prove much, since recentering may move it +back to approximately where it was originally. + +@f[window-display-end] is similar, but points after the last character +displayed. Moving the end is meaningless, since redisplay always moves it to +after the last character. +@enddefun + +@defun[fun {window-display-recentering}, args {@i[window]}] +This function returns whether redisplay will ensure the buffer's point of +@i[window]'s buffer is visible after redisplay. This is @f[setf]'able, and +changing @i[window]'s buffer sets this to @nil via @hid[Window Buffer Hook]. +@enddefun + +@defun[fun {window-point}, args {@i[window]}] +This function returns as a mark the position in the buffer where the cursor is +displayed. This may be set with @f[setf]. If @i[window] is the current +window, then setting the point will have little effect; it is forced to track +the buffer point. When the window is not current, the window point is the +position that the buffer point will be moved to when the window becomes +current. +@enddefun + +@defun[fun {center-window}, args {@i[window] @i[mark]}] +This function attempts to adjust window's display start so the that @i[mark] is +vertically centered within the window. +@enddefun + +@defun[fun {scroll-window}, args {@i[window] @i[n]}] +This function scrolls the window down @i[n] display lines; if @i[n] is negative +scroll up. Leave the cursor at the same text position unless we scroll it off +the screen, in which case the cursor is moved to the end of the window closest +to its old position. +@enddefun + +@defun[fun {displayed-p}, args {@i[mark] @i[window]}] +Returns @true if either the character before or the character after @i[mark] +is being displayed in @i[window], or @nil otherwise. +@enddefun + +@defun[fun {window-height}, args {@i[window]}] +@defun1[fun {window-width}, args {@i[window]}] +Height or width of the area of the window used for displaying the +buffer, in character positions. These values may be changed with +@f[setf], but the setting attempt may fail, in which case nothing is done. +@enddefun + +@defun[fun {next-window}, args {@i[window]}] +@defun1[fun {previous-window}, args {@i[window]}] +Return the next or previous window of @i[window]. The exact meaning of next +and previous depends on the device displaying the window. It should be +possible to cycle through all the windows displayed on a device using either +next or previous (implying that these functions wrap around.) +@enddefun + + +@section(Cursor Positions) +@index(Cursor positions) +A cursor position is an absolute position within a window's coordinate +system. The origin is in the upper-left-hand corner and the unit +is character positions. + +@defun[fun {mark-to-cursorpos}, args {@i[mark] @i[window]}] +Returns as multiple values the @f[X] and @f[Y] position on which +@i[mark] is being displayed in @i[window], or @nil if it is not within the +bounds displayed. +@enddefun + +@defun[fun {cursorpos-to-mark}, args {@i[X] @i[Y] @i[window]}] +Returns as a mark the text position which corresponds to the given +(@i[X], @i[Y]) position within window, or @nil if that +position does not correspond to any text within @i[window]. +@enddefun + +@defun[fun {last-key-event-cursorpos}] +Interprets mouse input. It returns as multiple values the (@i[X], @i[Y]) +position and the window where the pointing device was the last time some key +event happened. If the information is unavailable, this returns @nil. +@enddefun + +@defun[fun {mark-column}, args {@i[mark]}] +This function returns the @i[X] position at which @i[mark] would be displayed, +supposing its line was displayed on an infinitely wide screen. This takes into +consideration strange characters such as tabs. +@enddefun + +@defun[fun {move-to-column}, args {@i[mark] @i[column] @optional @i[line]}] +This function is analogous to @funref[move-to-position], except that +it moves @i[mark] to the position on @i[line] which corresponds to the +specified @i[column]. @i[Line] defaults to the line that @i[mark] is +currently on. If the line would not reach to the specified column, +then @nil is returned and @i[mark] is not modified. Note that since a +character may be displayed on more than one column on the screen, +several different values of @i[column] may cause @i[mark] to be moved +to the same position. +@enddefun + +@defun[fun {show-mark}, args {@i[mark] @i[window] @i[time]}] +This function highlights the position of @i[mark] within @i[window] for +@i[time] seconds, possibly by moving the cursor there. The wait may be aborted +if there is pending input. If @i[mark] is positioned outside the text +displayed by @i[window], then this returns @nil, otherwise @true. +@enddefun + + +@section(Redisplay) +Redisplay translates changes in the internal representation of text into +changes on the screen. Ideally this process finds the minimal transformation +to make the screen correspond to the text in order to maximize the speed of +redisplay. + +@defun[fun {redisplay}] +@defhvar1[var "Redisplay Hook"] +@f[redisplay] executes the redisplay process, and @hemlock typically invokes +this whenever it looks for input. The redisplay process frequently checks for +input, and if it detects any, it aborts. The return value is interpreted as +follows: +@begin[description] +@false@\No update was needed. + +@true@\Update was needed, and completed successfully. + +@kwd[editor-input]@\Update is needed, but was aborted due to pending input. +@end[description] + +This function invokes the functions in @hid[Redisplay Hook] on the current +window after computing screen transformations but before executing them. After +invoking the hook, this recomputes the redisplay and then executes it on the +current window. + +For the current window and any window with @f[window-display-recentering] set, +@f[redisplay] ensures the buffer's point for the window's buffer is visible +after redisplay. +@enddefun + +@defun[fun {redisplay-all}] +This causes all editor windows to be completely redisplayed. For the current +window and any window with @f[window-display-recentering] set, this ensures the +buffer's point for the window's buffer is visible after redisplay. The return +values are the same as for redisplay, except that @false is never returned. +@enddefun + +@defun[fun {editor-finish-output}, args {@i[window]}] +This makes sure the editor is synchronized with respect to redisplay output to +@i[window]. This may do nothing on some devices. +@enddefun + + + +@chapter(Logical Key-Events) +@label[logical-key-events] +@index[Logical key-events] + + +@section[Introduction] +Some primitives such as @funref[prompt-for-key] and commands such as EMACS +query replace read key-events directly from the keyboard instead of using the +command interpreter. To encourage consistency between these commands and to +make them portable and easy to customize, there is a mechanism for defining +@i[logical key-events]. + +A logical key-event is a keyword which stands for some set of key-events. The +system globally interprets these key-events as indicators a particular action. +For example, the @kwd[help] logical key-event represents the set of key-events +that request help in a given @hemlock implementation. This mapping is a +many-to-many mapping, not one-to-one, so a given logical key-event may have +multiple corresponding actual key-events. Also, any key-event may represent +different logical key-events. + + +@section[Logical Key-Event Functions] + +@defvar[var {logical-key-event-names}] +This variable holds a string-table mapping all logical key-event names to the +keyword identifying the logical key-event. +@enddefvar + +@defun[fun {define-logical-key-event}, args {@i[string-name] @i[documentation]}] + This function defines a new logical key-event with name @i[string-name], a +simple-string. Logical key-event operations take logical key-events arguments +as a keyword whose name is @i[string-name] uppercased with spaces replaced by +hyphens. + +@i[Documentation] describes the action indicated by the logical key-event. +@enddefun + +@defun[fun {logical-key-event-key-events}, args {@i[keyword]}] +This function returns the list of key-events representing the logical key-event +@i[keyword]. +@enddefun + +@defun[fun {logical-key-event-name}, args {@i[keyword]}] +@defun1[fun {logical-key-event-documentation}, args {@i[keyword]}] +These functions return the string name and documentation given to +@f[define-logical-key-event] for logical key-event @i[keyword]. +@enddefun + +@defun[fun {logical-key-event-p}, args {@i[key-event] @i[keyword]}] +This function returns @f[t] if @i[key-event] is the logical key-event +@i[keyword]. This is @f[setf]'able establishing or disestablishing key-events +as particular logical key-events. It is a error for @i[keyword] to be an +undefined logical key-event. +@enddefun + + +@section[System Defined Logical Key-Events] +There are many default logical key-events, some of which are used by functions +documented in this manual. If a command wants to read a single key-event +command that fits one of these descriptions then the key-event read should be +compared to the corresponding logical key-event instead of explicitly +mentioning the particular key-event in the code. In many cases you can use the +@macref[command-case] macro. It makes logical key-events easy to use and takes +care of prompting and displaying help messages. + +@begin[description] +@kwd[yes]@\ + Indicates the prompter should take the action under consideration. + +@kwd[no]@\ + Indicates the prompter should NOT take the action under consideration. + +@kwd[do-all]@\ + Indicates the prompter should repeat the action under consideration as many +times as possible. + +@kwd[do-once]@\ + Indicates the prompter should execute the action under consideration once and +then exit. + +@kwd[exit]@\ + Indicates the prompter should terminate its activity in a normal fashion. + +@kwd[abort]@\ + Indicates the prompter should terminate its activity without performing any +closing actions of convenience, for example. + +@kwd[keep]@\ + Indicates the prompter should preserve something. + +@kwd[help]@\ + Indicates the prompter should display some help information. + +@kwd[confirm]@\ + Indicates the prompter should take any input provided or use the default if +the user entered nothing. + +@kwd[quote]@\ + Indicates the prompter should take the following key-event as itself without +any sort of command interpretation. + +@kwd[recursive-edit]@\ + Indicates the prompter should enter a recursive edit in the current context. + +@kwd[cancel]@\ + Indicates the prompter should cancel the effect of a previous key-event input. + +@kwd[forward-search]@\ + Indicates the prompter should search forward in the current context. + +@kwd[backward-search]@\ + Indicates the prompter should search backward in the current context. +@end[description] + +@blankspace(1 line) +Define a new logical key-event whenever: +@begin[enumerate] +The key-event concerned represents a general class of actions, and +several commands may want to take a similar action of this type. + +The exact key-event a command implementor chooses may generate violent taste +disputes among users, and then the users can trivially change the command in +their init files. + +You are using @f[command-case] which prevents implementors from specifying +non-standard characters for dispatching in otherwise possibly portable code, +and you can define and set the logical key-event in a site dependent file where +you can mention implementation dependent characters. +@end[enumerate] + + + +@chapter(The Echo Area) + +@hemlock provides a number of facilities for displaying information and +prompting the user for it. Most of these work through a small window displayed +at the bottom of the screen. This is called the echo area and is supported by +a buffer and a window. This buffer's modeline (see section @ref[modelines]) is +referred to as the status line, which, unlike other buffers' modelines, is used +to show general status about the editor, Lisp, or world. + +@defhvar[var {Default Status Line Fields}] +This is the initial list of modeline-field objects stored in the echo area +buffer. +@enddefhvar + +@defhvar[var "Echo Area Height", val {3}] +This variable determines the initial height in lines of the echo area window. +@enddefhvar + + +@section(Echo Area Functions) +It is considered poor taste to perform text operations on the echo area buffer +to display messages; the @f[message] function should be used instead. A +command must use this function or set @funref[buffer-modified] for the +@hid[Echo Area] buffer to @nil to cause @hemlock to leave text in the echo area +after the command's execution. + +@defun[fun {clear-echo-area}] +Clears the echo area. +@enddefun + +@defun[fun {message}, args {@i[control-string] @rest @i[format-arguments]}] +@defun1[fun {loud-message}, args {@i[control-string] @rest @i[format-arguments]}] +@defhvar1[var {Message Pause}, val {0.5}] +Displays a message in the echo area. The message is always displayed on a +fresh line. @f[message] pauses for @hid[Message Pause] seconds before +returning to assure that messages are not displayed too briefly to be seen. +Because of this, @f[message] is the best way to display text in the echo area. + +@f[loud-message] is like @f[message], but it first clears the echo area and +beeps. +@enddefun + +@defvar[var {echo-area-window}] +@defvar1[var {echo-area-buffer}] +@f[echo-area-buffer] contains the buffer object for the echo area, which is +named @hid[Echo Area]. This buffer is usually in @hid[Echo Area] mode. +@f[echo-area-window] contains a window displaying @f[echo-area-buffer]. Its +modeline is the status line, see the beginning of this chapter. +@enddefvar + +@defvar[var {echo-area-stream}] +@index (Echo area) +This is a buffered @hemlock output stream +(@pageref[make-hemlock-output-stream-fun]) which inserts text written to it at +the point of the echo area buffer. Since this stream is buffered a +@f[force-output] must be done when output is complete to assure that it is +displayed. +@enddefvar + + +@section(Prompting Functions) +@index(Prompting functions) +Most of the prompting functions accept the following keyword arguments: +@begin(description) +@kwd[must-exist] @\If @kwd[must-exist] has a non-@nil value then the +user is prompted until a valid response is obtained. If +@kwd[must-exist] is @nil then return as a string whatever is input. +The default is @true. + +@kwd[default] @\If null input is given when the user is prompted +then this value is returned. If no default is given then +some input must be given before anything interesting will happen. + +@kwd[default-string] @\If a @kwd[default] is given then this is a +string to be printed to indicate what the default is. The default is +some representation of the value for @kwd[default], for example for a +buffer it is the name of the buffer. + +@kwd[prompt] @\This is the prompt string to display. + +@kwd[help] @\@multiple{ +This is similar to @kwd[prompt], except that it is displayed when +the help command is typed during input. @comment{If there is some known number +of options as in keyword parses, then they may be displayed, depending +on the setting of @hvarref[Help Show Options].} + +This may also be a function. When called with no arguments, it should either +return a string which is the help text or perform some action to help the user, +returning @Nil.} +@end(description) + +@defun[fun {prompt-for-buffer}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] +Prompts with completion for a buffer name and returns the corresponding buffer. +If @i[must-exist] is @nil, then it returns the input string if it is not a +buffer name. This refuses to accept the empty string as input when +@kwd[default] and @kwd[default-string] are @nil. @kwd[default-string] may be +used to supply a default buffer name when @kwd[default] is @nil, but when +@kwd[must-exist] is non-@nil, it must name an already existing buffer. +@enddefun + +@defmac[fun {command-case}, Args {(@mstar<@i[key] @i[value]>) @Mstar<(@Mgroup"(@MSTAR'@i[tag]') @MOR @i[tag]" @i[help] @MSTAR'@i[form]')>}] + This macro is analogous to the Common Lisp @f[case] macro. Commands such as +@hid[Query Replace] use this to get a key-event, translate it to a character, +and then to dispatch on the character to some case. In addition to character +dispatching, this supports logical key-events @w<(page +@pageref[logical-key-events])> by using the input key-event directly without +translating it to a character. Since the description of this macro is rather +complex, first consider the following example: +@lisp +(defcommand "Save All Buffers" (p) + "Give the User a chance to save each modified buffer." + "Give the User a chance to save each modified buffer." + (dolist (b *buffer-list*) + (select-buffer-command () b) + (when (buffer-modified b) + (command-case (:prompt "Save this buffer: [Y] " + :help "Save buffer, or do something else:") + ((:yes :confirm) + "Save this buffer and go on to the next." + (save-file-command () b)) + (:no "Skip saving this buffer, and go on to the next.") + (:recursive-edit + "Go into a recursive edit in this buffer." + (do-recursive-edit) (reprompt)) + ((:exit #\p) "Punt this silly loop." + (return nil)))))) +@endlisp + +@f[command-case] prompts for a key-event and then executes the code in the +first branch with a logical key-event or a character (called @i[tags]) matching +the input. Each character must be a standard-character, one that satisfies the +Common Lisp @f[standard-char-p] predicate, and the dispatching mechanism +compares the input key-event to any character tags by mapping the key-event to +a character with @f[ext:key-event-char]. If the tag is a logical key-event, +then the search for an appropriate case compares the key-event read with the +tag using @f[logical-key-event-p]. + +All uses of @f[command-case] have two default cases, @kwd[help] and +@kwd[abort]. You can override these easily by specifying your own branches +that include these logical key-event tags. The @kwd[help] branch displays in a +pop-up window the a description of the valid responses using the variously +specified help strings. The @kwd[abort] branch signals an editor-error. + +The @i[key]/@i[value] arguments control the prompting. The following are valid +values: +@begin[description] +@kwd[help]@\ + The default @kwd[help] case displays this string in a pop-up window. In +addition it formats a description of the valid input including each case's +@i[help] string. + +@kwd[prompt]@\ + This is the prompt used when reading the key-event. + +@kwd[change-window]@\ + If this is non-nil (the default), then the echo area window becomes the +current window while the prompting mechanism reads a key-event. Sometimes it +is desirable to maintain the current window since it may be easier for users to +answer the question if they can see where the current point is. + +@kwd[bind]@\ + This specifies a variable to which the prompting mechanism binds the input +key-event. Any case may reference this variable. If you wish to know what +character corresponds to the key-event, use @f[ext:key-event-char]. +@end(description) + +Instead of specifying a tag or list of tags, you may use @true. This becomes +the default branch, and its forms execute if no other branch is taken, +including the default @kwd[help] and @kwd[abort] cases. This option has no +@i[help] string, and the default @kwd[help] case does not describe the default +branch. Every @f[command-case] has a default branch; if none is specified, the +macro includes one that @f[system:beep]'s and @f[reprompt]'s (see below). + +Within the body of @f[command-case], there is a defined @f[reprompt] macro. +It causes the prompting mechanism and dispatching mechanism to immediately +repeat without further execution in the current branch. +@enddefmac + + +@defun[fun {prompt-for-key-event}, keys {[prompt][change-window]}] +This function prompts for a key-event returning immediately when the user types +the next key-event. @macref[command-case] is more useful for most purposes. +When appropriate, use logical key-events @w<(page +@pageref[logical-key-events])>. +@enddefun + +@defun[fun {prompt-for-key}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This function prompts for a @i[key], a vector of key-events, suitable for +passing to any of the functions that manipulate key bindings @w<(page +@pageref[key-bindings])>. If @i[must-exist] is true, then the key must be +bound in the current environment, and the command currently bound is returned +as the second value. +@enddefun + +@defun[fun {prompt-for-file}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This function prompts for an acceptable filename in some system dependent +fashion. "Acceptable" means that it is a legal filename, and it exists if +@i[must-exist] is non-@nil. @f[prompt-for-file] returns a Common Lisp +pathname. + +If the file exists as entered, then this returns it, otherwise it is merged +with @i[default] as by @f[merge-pathnames]. +@enddefun + +@defun[fun {prompt-for-integer}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This function prompts for a possibly signed integer. If @i[must-exist] is +@nil, then @f[prompt-for-integer] returns the input as a string if it is not a +valid integer. +@enddefun + +@defun[fun {prompt-for-keyword}, args {@i[string-tables]}, + keys {[prompt][help][must-exist]}, + morekeys {[default][default-string]}] + This function prompts for a keyword with completion, using the string tables +in the list @i[string-tables]. If @I[must-exist] is non-@nil, then the result +must be an unambiguous prefix of a string in one of the @i[string-tables], and +the returns the complete string even if only a prefix of the full string was +typed. In addition, this returns the value of the corresponding entry in the +string table as the second value. + +If @i[must-exist] is @nil, then this function returns the string exactly as +entered. The difference between @f[prompt-for-keyword] with @i[must-exist] +@nil, and @f[prompt-for-string], is the user may complete the input using the +@hid and @hid commands. +@enddefun + +@defun[fun {prompt-for-expression}, + keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This function reads a Lisp expression. If @i[must-exist] is @nil, and a read +error occurs, then this returns the string typed. +@enddefun + +@defun[fun {prompt-for-string}, keys +{[prompt][help][default][default-string]}] + This function prompts for a string; this cannot fail. +@enddefun + +@defun[fun {prompt-for-variable}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This function prompts for a variable name. If @i[must-exist] is non-@nil, +then the string must be a variable @i[defined in the current environment], in +which case the symbol name of the variable found is returned as the second +value. +@enddefun + +@defun[fun {prompt-for-y-or-n}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This prompts for @binding[y], @binding[Y], @binding[n], or @binding[N], +returning @true or @nil without waiting for confirmation. When the user types +a confirmation key, this returns @i[default] if it is supplied. If +@i[must-exist] is @nil, this returns whatever key-event the user first types; +however, if the user types one of the above key-events, this returns @true or +@nil. This is analogous to the Common Lisp function @f[y-or-n-p]. +@enddefun + +@defun[fun {prompt-for-yes-or-no}, keys {[prompt][help][must-exist][default]}, + morekeys {[default-string]}] + This function is to @f[prompt-for-y-or-n] as @f[yes-or-no-p] is to +@f[y-or-n-p]. "Yes" or "No" must be typed out in full and +confirmation must be given. +@enddefun + + +@section(Control of Parsing Behavior) + +@defhvar[var {Beep On Ambiguity}, val {@true}] +If this variable is true, then an attempt to complete a parse which is +ambiguous will result in a "beep". +@enddefhvar + + +@begin(comment) +@hemlock provides for limited control of parsing routine behaviour The +character attribute @hid[Parse Field Separator] is a boolean attribute, a value +of @f[1] indicating that the character is a field separator recognized by the +@hid command. +@end(comment) + +@begin(comment) +@defhvar[var {Help Show Options}] +During a keyword or similar parse, typing the help command may cause a +list of options to be displayed. If displaying the help would take up +more lines than the value of this variable then confirmation will be +asked for before they will be displayed. +@enddefhvar +@end(comment) + + + +@section(Defining New Prompting Functions) +Prompting functions are implemented as a recursive edit in the +@hid[Echo Area] buffer. Completion, help, and other parsing features +are implemented by commands which are bound in @hid[Echo Area Mode]. + +A prompting function passes information down into the recursive edit +by binding a collection of special variables. + +@defvar[var {parse-verification-function}] +The system binds this to a function that @comref[Confirm Parse] calls. It does +most of the work when parsing prompted input. @comref[Confirm Parse] passes +one argument, which is the string that was in @var when the +user invokes the command. The function should return a list of values which +are to be the result of the recursive edit, or @nil indicating that the parse +failed. In order to return zero values, a non-@nil second value may be +returned along with a @nil first value. +@enddefvar + +@defvar[var {parse-string-tables}] +This is the list of @f[string-table]s, if any, that pertain to this parse. +@enddefvar + +@defvar[var {parse-value-must-exist}] +This is bound to the value of the @kwd[must-exist] argument, and is +referred to by the verification function, and possibly some of the +commands. +@enddefvar + +@defvar[var {parse-default}] +When prompting the user, this is bound to a string representing the default +object, the value supplied as the @kwd[default] argument. @hid +supplies this to the parse verification function when the +@var is empty. +@enddefvar + +@defvar[var {parse-default-string}] +When prompting the user, if @var[parse-default] is @nil, @hemlock displays this +string as a representation of the default object; for example, when prompting +for a buffer, this variable would be bound to the buffer name. +@enddefvar + +@defvar[var {parse-type}] +The kind of parse in progress, one of @kwd[file], @kwd[keyword] or +@kwd[string]. This tells the completion commands how to do completion, with +@kwd[string] disabling completion. +@enddefvar + +@defvar[var {parse-prompt}] +The prompt being used for the current parse. +@enddefvar + +@defvar[var {parse-help}] +The help string or function being used for the current parse. +@enddefvar + +@defvar[var {parse-starting-mark}] +This variable holds a mark in the @varref[echo-area-buffer] which +is the position at which the parse began. +@enddefvar + +@defvar[var {parse-input-region}] +This variable holds a region with @var[parse-starting-mark] as its +start and the end of the echo-area buffer as its end. When +@hid[Confirm Parse] is called, the text in this region is the text +that will be parsed. +@enddefvar + + +@section(Some Echo Area Commands) + +These are some of the @hid[Echo Area] commands that coordinate with the +prompting routines. @Hemlock binds other commands specific to the @hid[Echo +Area], but they are uninteresting to mention here, such as deleting to the +beginning of the line or deleting backwards a word. + +@defcom[com {Help On Parse}, + stuff (bound to @bf[Home, C-_] in @hid[Echo Area] mode)] +Display the help text for the parse currently in progress. +@enddefcom + +@defcom[com {Complete Keyword}, + stuff (bound to @bf[Escape] in @hid[Echo Area] mode)] +This attempts to complete the current region as a keyword in +@var[string-tables]. It signals an editor-error if the input is ambiguous +or incorrect. +@enddefcom + +@defcom[com {Complete Field}, + stuff (bound to @bf[Space] in @hid[Echo Area] mode)] +Similar to @hid[Complete Keyword], but only attempts to complete up to and +including the first character in the keyword with a non-zero +@kwd[parse-field-separator] attribute. If +there is no field separator then attempt to complete the entire keyword. +If it is not a keyword parse then just self-insert. +@enddefcom + +@defcom[com {Confirm Parse}, + stuff (bound to @bf[Return] in @hid[Echo Area] mode)] +If @var[string-tables] is non-@nil find the string in the region in +them. Call @var[parse-verification-function] with the current input. +If it returns a non-@nil value then that is returned as the value of +the parse. A parse may return a @nil value if the verification +function returns a non-@nil second value. +@enddefcom + + + +@chapter (Files) +@index (Files) +This chapter discusses ways to read and write files at various levels @dash at +marks, into regions, and into buffers. This also treats automatic mechanisms +that affect the state of buffers in which files are read. + +@section (File Options and Type Hooks) +@index (File options) +@index (Type hooks) +@index (File type hooks) +The user specifies file options with a special syntax on the first line of a +file. If the first line contains the string "@f[-*-]", then @hemlock +interprets the text between the first such occurrence and the second, which +must be contained in one line , as a list of @w{"@f<@i[option]: @i[value]>"} +pairs separated by semicolons. The following is a typical example: +@begin[programexample] +;;; -*- Mode: Lisp, Editor; Package: Hemlock -*- +@end[programexample] +See the @i[Hemlock User's Manual] for more details and predefined options. + +File type hooks are executed when @hemlock reads a file into a buffer based on +the type of the pathname. When the user specifies a @hid[Mode] file option +that turns on a major mode, @hemlock ignores type hooks. This mechanism is +mostly used as a simple means for turning on some appropriate default major +mode. + +@defmac[fun {define-file-option}, args +{@i[name] (@i[buffer] @i[value]) @mstar<@i[declaration]> @mstar<@i[form]>}] +This defines a new file option with the string name @i[name]. @i[Buffer] and +@i[value] specify variable names for the buffer and the option value string, +and @i[form]'s are evaluated with these bound. +@enddefmac + +@defmac[fun {define-file-type-hook}, args +{@i[type-list] (@i[buffer] @i[type]) @mstar<@i[declaration]> @mstar<@i[form]>}] + +This defines some code that @f[process-file-options] (below) executes when the +file options fail to set a major mode. This associates each type, a +@f[simple-string], in @i[type-list] with a routine that binds @i[buffer] to the +buffer the file is in and @i[type] to the type of the pathname. +@enddefmac + +@defun[fun {process-file-options}, args {@i[buffer] @optional @i[pathname]}] +This checks for file options in buffer and invokes handlers if there are any. +@i[Pathname] defaults to @i[buffer]'s pathname but may be @nil. If there is no +@hid[Mode] file option that specifies a major mode, and @i[pathname] has a +type, then this tries to invoke the appropriate file type hook. +@f[read-buffer-file] calls this. +@enddefun + + +@section (Pathnames and Buffers) +There is no good way to uniquely identify buffer names and pathnames. However, +@hemlock has one way of mapping pathnames to buffer names that should be used +for consistency among customizations and primitives. Independent of this, +@hemlock provides a means for consistently generating prompting defaults when +asking the user for pathnames. + +@defun[fun {pathname-to-buffer-name}, args {@i[pathname]}] +This function returns a string of the form "@f[file-namestring] +@f[directory-namestring]". +@enddefun + +@defhvar[var "Pathname Defaults", val {(pathname "gazonk.del")}] +@defhvar1[var "Last Resort Pathname Defaults Function"] +@defhvar1[var "Last Resort Pathname Defaults", val {(pathname "gazonk")}] +These variables control the computation of default pathnames when needed for +promting the user. @hid[Pathname Defaults] is a @i[sticky] default. +See the @i[Hemlock User's Manual] for more details. +@enddefhvar + +@defun[fun {buffer-default-pathname}, args {@i[buffer]}] +This returns @hid[Buffer Pathname] if it is bound. If it is not bound, and +@i[buffer]'s name is composed solely of alphnumeric characters, then return a +pathname formed from @i[buffer]'s name. If @i[buffer]'s name has other +characters in it, then return the value of @hid[Last Resort Pathname Defaults +Function] called on @i[buffer]. +@enddefun + +@section (File Groups) +@index (File groups) +File groups provide a simple way of collecting the files that compose a system +and naming that collection. @Hemlock supports commands for searching, +replacing, and compiling groups. + +@defvar[var {active-file-group}] +This is the list of files that constitute the currently selected file group. +If this is @nil, then there is no current group. +@enddefvar + +@defmac[fun {do-active-group}, args {@mstar<@i[form]>}] +@defhvar1[var "Group Find File", val {nil}] +@defhvar1[var "Group Save File Confirm", val {t}] +@f[do-active-group] iterates over @var[active-file-group] executing the forms +once for each file. While the forms are executing, the file is in the current +buffer, and the point is at the beginning. If there is no active group, this +signals an editor-error. + +This reads each file into its own buffer using @f[find-file-buffer]. Since +unwanted buffers may consume large amounts of memory, @hid[Group Find File] +controls whether to delete the buffer after executing the forms. When the +variable is false, this deletes the buffer if it did not previously exist; +however, regardless of this variable, if the user leaves the buffer modified, +the buffer persists after the forms have completed. Whenever this processes a +buffer that already existed, it saves the location of the buffer's point before +and restores it afterwards. + +After processing a buffer, if it is modified, @f[do-active-group] tries to save +it. If @hid[Group Save File Confirm] is non-@nil, it asks for confirmation. +@enddefmac + + +@section (File Reading and Writing) +Common Lisp pathnames are used by the file primitives. For probing, checking +write dates, and so forth, all of the Common Lisp file functions are available. + +@defun[fun {read-file}, args {@i[pathname] @i[mark]}] +This inserts the file named by @i[pathname] at @i[mark]. +@enddefun + +@defun[fun {write-file}, args {@i[region] @i[pathname]}, + keys {[keep-backup][access][append]}] +@defhvar1[var {Keep Backup Files}, val {@nil}] +This function writes the contents of @i[region] to the file named by +@i[pathname]. This writes @i[region] using a stream as if it were opened with +@kwd[if-exists] supplied as @kwd[rename-and-delete]. + +When @i[keep-backup], which defaults to the value of @hid[Keep Backup Files], +is non-@nil, this opens the stream as if @kwd[if-exists] were @kwd[rename]. If +@i[append] is non-@nil, this writes the file as if it were opened with +@kwd[if-exists] supplied as @kwd[append]. + +This signals an error if both @i[append] and @i[keep-backup] are supplied as +non-@nil. + +@i[Access] is an implementation dependent value that is suitable for setting +@i[pathname]'s access or protection bits. +@enddefun + + +@defun[fun {write-buffer-file}, args {@i[buffer] @i[pathname]}] +@defhvar1[var {Write File Hook}] +@defhvar1[var {Add Newline at EOF on Writing File}, val {@kwd[ask-user]}] +@f[write-buffer-file] writes @i[buffer] to the file named by @i[pathname] +including the following: +@begin[itemize] +It assumes pathname is somehow related to @i[buffer]'s pathname: if the +@i[buffer]'s write date is not the same as @i[pathname]'s, then this prompts +the user for confirmation before overwriting the file. + +It consults @hid[Add Newline at EOF on Writing File] (see @i[Hemlock User's +Manual] for possible values) and interacts with the user if necessary. + +It sets @hid[Pathname Defaults], and after using @f[write-file], marks +@i[buffer] unmodified. + +It updates @i[Buffer]'s pathname and write date. + +It renames the buffer according to the new pathname if possible. + +It invokes @hid[Write File Hook]. +@end[itemize] + +@hid[Write File Hook] is a list of functions that take the newly written buffer +as an argument. +@enddefun + + +@defun[fun {read-buffer-file}, args {@i[pathname] @i[buffer]}] +@defhvar1[var {Read File Hook}] +@f[read-buffer-file] deletes @i[buffer]'s region and uses @f[read-file] to read +@i[pathname] into it, including the following: +@begin[itemize] +It sets @i[buffer]'s write date to the file's write date if the file exists; +otherwise, it @f[message]'s that this is a new file and sets @i[buffer]'s write +date to @nil. + +It moves @i[buffer]'s point to the beginning. + +It sets @i[buffer]'s unmodified status. + +It sets @i[buffer]'s pathname to the result of probing @i[pathname] if the file +exists; otherwise, this function sets @i[buffer]'s pathname to the result of +merging @i[pathname] with @f[default-directory]. + +It sets @hid[Pathname Defaults] to the result of the previous item. + +It processes the file options. + +It invokes @hid[Read File Hook]. +@end[itemize] + +@hid[Read File Hook] is a list functions that take two arguments @dash the +buffer read into and whether the file existed, @true if so. +@enddefun + + +@defun[fun {find-file-buffer}, args {@i[pathname]}] +This returns a buffer assoicated with the @i[pathname], reading the file into a +new buffer if necessary. This returns a second value indicating whether a new +buffer was created, @true if so. If the file has already been read, this +checks to see if the file has been modified on disk since it was read, giving +the user various recovery options. This is the basis of the @hid[Find File] +command. +@enddefun + + + +@chapter (Hemlock's Lisp Environment) + +@index (Lisp environment) +This chapter is sort of a catch all for any functions and variables +which concern @hemlock's interaction with the outside world. + +@section(Entering and Leaving the Editor) + +@defun[fun {ed}, args {@optional @i[x]}] +@defhvar1[var "Entry Hook"] +@f[ed] enters the editor. It is basically as specified in Common Lisp. If +@i[x] is supplied and is a symbol, the definition of @i[x] is put into a +buffer, and that buffer is selected. If @i[x] is a pathname, the file +specified by @i[x] is visited in a new buffer. If @i[x] is not supplied or +@nil, the editor is entered in the same state as when last exited. + +The @hid[Entry Hook] is invoked each time the editor is entered. +@enddefhvar + +@defun[fun {exit-hemlock}, args {@optional @i[value]}] +@defhvar1[var {Exit Hook}] +@f[exit-hemlock] leaves @hemlock and return to Lisp; @i[value] is the +value to return, which defaults to @true. The hook +@hvarref[Exit Hook] is invoked before this is done. +@enddefun + +@defun[fun {pause-hemlock}] +@f[pause-hemlock] suspends the editor process and returns control to the shell. +When the process is resumed, it will still be running @hemlock. +@enddefun + + +@section(Keyboard Input) +@index(I/O) +@index[keyboard input] +@index[input, keyboard] + +Keyboard input interacts with a number of other parts of the editor. Since the +command loop works by reading from the keyboard, keyboard input is the initial +cause of everything that happens. Also, @hemlock redisplays in the low-level +input loop when there is no available input from the user. + + +@defvar[var {editor-input}] +@defvar1[var {real-editor-input}] +@defhvar1[var "Input Hook"] +@defhvar1[var "Abort Hook"] +@index[aborting] +@var[editor-input] is an object on which @hemlock's I/O routines operate. You +can get input, clear input, return input, and listen for input. Input appears +as key-events. + +@var[real-editor-input] holds the initial value of @var[editor-input]. This is +useful for reading from the user when @var[editor-input] is rebound (such as +within a keyboard macro.) + +@Hemlock invokes the functions in @hid[Input Hook] each time someone reads a +key-event from @var[real-editor-input]. These take no arguments. +@enddefvar + +@defun[fun {get-key-event}, args {@i[editor-input] @optional @i[ignore-abort-attempts-p]}] +This function returns a key-event as soon as it is available on +@i[editor-input]. @i[Editor-input] is either @var[editor-input] or +@var[real-editor-input]. @i[Ignore-abort-attempts-p] indicates whether +@binding[C-g] and @binding[C-G] throw to the editor's top-level command loop; +when this is non-nil, this function returns those key-events when the user +types them. Otherwise, it aborts the editor's current state, returning to the +command loop. + +When the user aborts, @Hemlock invokes the functions in @hid[Abort Hook]. +These functions take no arguments. When aborting, @Hemlock ignores the +@hid[Input Hook]. +@enddefun + + +@defun[fun {unget-key-event}, args {@i[key-event] @i[editor-input]}] +This function returns @i[key-event] to @i[editor-input], so the next invocation +of @f[get-key-event] will return @i[key-event]. If @i[key-event] is +@f[#k"C-g"] or @f[#k"C-G"], then whether @f[get-key-event] returns it depends +on that function's second argument. @i[Editor-input] is either +@var[editor-input] or @var[real-editor-input]. +@enddefun + +@defun[fun {clear-editor-input}, args {@i[editor-input]}] +This function flushes any pending input on @i[editor-input]. @i[Editor-input] +is either @var[editor-input] or @var[real-editor-input]. +@enddefun + +@defun[fun {listen-editor-input}, args {@i[editor-input]}] +This function returns whether there is any input available on @i[editor-input]. +@i[Editor-input] is either @var[editor-input] or @var[real-editor-input]. +@enddefun + +@defun[fun {editor-sleep}, args {@i[time]}] +Return either after @i[time] seconds have elapsed or when input is available on +@var[editor-input]. +@enddefun + +@defvar[var {key-event-history}] +This is a @hemlock ring buffer (see page @pageref[rings]) that holds the last +60 key-events read from the keyboard. +@enddefvar + +@defvar[var {last-key-event-typed}] +Commands use this variable to realize the last key-event the user typed to +invoke the commands. Before @hemlock ever reads any input, the value is @nil. +This variable usually holds the last key-event read from the keyboard, but it +is also maintained within keyboard macros allowing commands to behave the same +on each repetition as they did in the recording invocation. +@enddefvar + +@defvar[var {input-transcript}] +If this is non-@nil then it should be an adjustable vector with a fill-pointer. +When it is non-@nil, @hemlock pushes all input read onto this vector. +@enddefvar + + + +@section(Hemlock Streams) +It is possible to create streams which output to or get input from a buffer. +This mechanism is quite powerful and permits easy interfacing of @hemlock to +Lisp. + +@defun[fun {make-hemlock-output-stream}, args + {@i[mark] @optional @i[buffered]}] +@defun1[fun {hemlock-output-stream-p}, args {@i[object]}] +@f[make-hemlock-output-stream] returns a stream that inserts at the permanent +mark @i[mark] all output directed to it. @i[Buffered] controls whether the +stream is buffered or not, and its valid values are the following keywords: +@begin[description] +@kwd[none]@\No buffering is done. This is the default. + +@kwd[line]@\The buffer is flushed whenever a newline is written or +when it is explicitly done with @f[force-output]. + +@kwd[full]@\The screen is only brought up to date when it is +explicitly done with @f[force-output] +@end[description] + +@f[hemlock-output-stream-p] returns @true if @i[object] is a +@f[hemlock-output-stream] object. +@enddefun + +@defun[fun {make-hemlock-region-stream}, args {@i[region]}] +@defun1[fun {hemlock-region-stream-p}, args {@i[object]}] +@f[make-hemlock-region-stream] returns a stream from which the text in +@i[region] can be read. @f[hemlock-region-stream-p] returns @true if +@i[object] is a @f[hemlock-region-stream] object. +@enddefun + +@defmac[fun {with-input-from-region}, args +{(@i[var] @i[region]) @mstar<@i[declaration]> @mstar<@i[form]>}] +While evaluating @i[form]s, binds @i[var] to a stream which returns input +from @i[region]. +@enddefmac + +@defmac[fun {with-output-to-mark}, args +{(@i[var] @i[mark] @mopt<@i"buffered">) @mstar<@i[declaration]> @mstar<@i[form]>}] + During the evaluation of the @i[form]s, binds @i[var] to a stream which +inserts output at the permanent @i[mark]. @i[Buffered] has the same meaning as +for @f[make-hemlock-output-stream]. +@enddefmac + +@defmac[fun {with-pop-up-display}, args {(@i[var] @key @i[height name]) @mstar<@i[declaration]> @mstar<@i[form]>}] +@defvar1[var {random-typeout-buffers}] + This macro executes @i[forms] in a context with @i[var] bound to a stream. +@Hemlock collects output to this stream and tries to pop up a display of the +appropriate height containing all the output. When @i[height] is supplied, +@Hemlock creates the pop-up display immediately, forcing output on line breaks. +The system saves the output in a buffer named @i[name], which defaults to +@hid[Random Typeout]. When the window is the incorrect height, the display +mechanism will scroll the window with more-style prompting. This is useful +for displaying information of temporary interest. + +When a buffer with name @i[name] already exists and was not previously created +by @f[with-pop-up-display], @Hemlock signals an error. + +@var[random-typeout-buffers] is an association list mapping random typeout +buffers to the streams that operate on the buffers. +@enddefmac + + +@section (Interface to the Error System) +The error system interface is minimal. There is a simple editor-error +condition which is a subtype of error and a convenient means for signaling +them. @Hemlock also provides a standard handler for error conditions while in +the editor. + +@defun[fun {editor-error-format-string}, args {@i[condition]}] +@defun1[fun {editor-error-format-arguments}, args {@i[condition]}] +Handlers for editor-error conditions can access the condition object with +these. +@enddefun + +@defun[fun {editor-error}, args {@rest @i[args]}] +This function is called to signal minor errors within Hemlock; these are errors +that a normal user could encounter in the course of editing such as a search +failing or an attempt to delete past the end of the buffer. This function +@f[signal]'s an editor-error condition formed from @i[args], which are @nil or +a @f[format] string possibly followed by @f[format] arguments. @Hemlock +invokes commands in a dynamic context with an editor-error condition handler +bound. This default handler beeps or flashes (or both) the display. If the +condition passed to the handler has a non-@nil string slot, the handler also +invokes @f[message] on it. The command in progress is always aborted, and this +function never returns. +@enddefun + +@defmac[fun {handle-lisp-errors}, args {@mstar<@i[form]>}] +Within the body of this macro any Lisp errors that occur are handled in some +fashion more gracefully than simply dumping the user in the debugger. This +macro should be wrapped around code which may get an error due to some action +of the user @dash for example, evaluating code fragments on the behalf of and +supplied by the user. Using this in a command allows the established handler +to shadow the default editor-error handler, so commands should take care to +signal user errors (calls to @f[editor-errors]) outside of this context. +@enddefmac + + +@section (Definition Editing) +@index (Definition editing) +@hemlock provides commands for finding the definition of a function, macro, or +command and placing the user at the definition in a buffer. This, of course, +is implementation dependent, and if an implementation does not associate a +source file with a routine, or if @hemlock cannot get at the information, then +these commands do not work. If the Lisp system does not store an absolute +pathname, independent of the machine on which the maintainer built the system, +then users need a way of translating a source pathname to one that will be able +to locate the source. + +@defun[fun {add-definition-dir-translation}, args {@i[dir1] @i[dir2]}] +This maps directory pathname @i[dir1] to @i[dir2]. Successive invocations +using the same @i[dir1] push into a translation list. When @hemlock seeks a +definition source file, and it has a translation, then it tries the +translations in order. This is useful if your sources are on various machines, +some of which may be down. When @hemlock tries to find a translation, it first +looks for translations of longer directory pathnames, finding more specific +translations before shorter, more general ones. +@enddefun + +@defun[fun {delete-definition-dir-translation}, args {@i[dir]}] +This deletes the mapping of @i[dir] to all directories to which it has been +mapped. +@enddefun + + +@section (Event Scheduling) +@index (Event scheduling) +@index (Scheduling events) +The mechanism described in this chapter is only operative when the Lisp process +is actually running inside of @hemlock, within the @f[ed] function. The +designers intended its use to be associated with the editor, such as with +auto-saving files, reminding the user, etc. + +@defun[fun {schedule-event}, args {@i[time] @i[function] @optional @i[repeat]}] +This causes @hemlock to call @i[function] after @i[time] seconds have passed, +optionally repeating every @i[time] seconds. @i[Repeat] defaults to @true. +This is a rough mechanism since commands can take an arbitrary amount of time +to run; @hemlock invokes @i[function] at the first possible moment after +@i[time] has elapsed. @i[Function] takes the time in seconds that has elapsed +since the last time it was called (or since it was scheduled for the first +invocation). +@enddefun + +@defun[fun {remove-scheduled-event}, args {@i[function]}] +This removes @i[function] from the scheduling queue. @i[Function] does not +have to be in the queue. +@enddefun + + +@section (Miscellaneous) + +@defun[fun {in-lisp}, args {@mstar<@i[form]>}] +@index[Evaluating Lisp code] +This evaluates @i[form]'s inside @f[handle-lisp-errors]. It also binds +@var[package] to the package named by @hid[Current Package] if it is non-@nil. +Use this when evaluating Lisp code on behalf of the user. +@enddefun + +@defmac[fun {do-alpha-chars}, args {(@i[var] @i[kind] [@i[result]]) @mstar<@i[form]>}] +This iterates over alphabetic characters in Common Lisp binding @i[var] to each +character in order as specified under character relations in @i[Common Lisp the +Language]. @i[Kind] is one of @kwd[lower], @kwd[upper], or @kwd[both]. When +the user supplies @kwd[both], lowercase characters are processed first. +@enddefmac + + + +@chapter (High-Level Text Primitives) +This chapter discusses primitives that operate on higher level text forms than +characters and words. For English text, there are functions that know about +sentence and paragraph structures, and for Lisp sources, there are functions +that understand this language. This chapter also describes mechanisms for +organizing file sections into @i[logical pages] and for formatting text forms. + + +@section (Indenting Text) +@index (Indenting) +@label(indenting) + +@defhvar[var "Indent Function", val {tab-to-tab-stop}] +The value of this variable determines how indentation is done, and it is a +function which is passed a mark as its argument. The function should indent +the line that the mark points to. The function may move the mark around on +the line. The mark will be @f[:left-inserting]. The default simply inserts a +@binding[tab] character at the mark. A function for @hid[Lisp] mode probably +moves the mark to the beginning of the line, deletes horizontal whitespace, and +computes some appropriate indentation for Lisp code. +@enddefhvar + +@defhvar[var "Indent with Tabs", val {indent-using-tabs}] +@defhvar1[var "Spaces per Tab", val {8}] +@hid[Indent with Tabs] holds a function that takes a mark and a number of +spaces. The function will insert a maximum number of tabs and a minimum number +of spaces at mark to move the specified number of columns. The default +definition uses @hid[Spaces per Tab] to determine the size of a tab. @i[Note,] +@hid[Spaces per Tab] @i[is not used everywhere in @hemlock yet, so changing +this variable could have unexpected results.] +@enddefhvar + +@defun[fun {indent-region}, args {@i[region]}] +@defun1[fun {indent-region-for-commands}, args {@i[region]}] +@f[indent-region] invokes the value of @hid[Indent Function] on every line of +region. @f[indent-region-for-commands] uses @f[indent-region] but first saves +the region for the @hid[Undo] command. +@enddefun + +@defun[fun {delete-horizontal-space}, args {@i[mark]}] +This deletes all characters with a @hid[Space] attribute (see section +@ref[sys-def-chars]) of @f[1]. +@enddefun + + +@section (Lisp Text Buffers) +@index (Lisp text functions) +@hemlock bases its Lisp primitives on parsing a block of the buffer and +annotating lines as to what kind of Lisp syntax occurs on the line or what kind +of form a mark might be in (for example, string, comment, list, etc.). These +do not work well if the block of parsed forms is exceeded when moving marks +around these forms, but the block that gets parsed is somewhat programmable. + +There is also a notion of a @i[top level form] which this documentation often +uses synonymously with @i[defun], meaning a Lisp form occurring in a source +file delimited by parentheses with the opening parenthesis at the beginning of +some line. The names of the functions include this inconsistency. + +@defun[fun {pre-command-parse-check}, args {@i[mark] @i[for-sure]}] +@defhvar1[var {Parse Start Function}, val {start-of-parse-block}] +@defhvar1[var {Parse End Function}, val {end-of-parse-block}] +@defhvar1[var {Minimum Lines Parsed}, val {50}] +@defhvar1[var {Maximum Lines Parsed}, val {500}] +@defhvar1[var {Defun Parse Goal}, val {2}] +@f[pre-command-parse-check] calls @hid[Parse Start Function] and @hid[Parse End +Function] on @i[mark] to get two marks. It then parses all the lines between +the marks including the complete lines they point into. When @i[for-sure] is +non-@nil, this parses the area regardless of any cached information about the +lines. Every command that uses the following routines calls this before doing +so. + +The default values of the start and end variables use @hid[Minimum Lines +Parsed], @hid[Maximum Lines Parsed], and @hid[Defun Parse Goal] to determine +how big a region to parse. These two functions always include at least the +minimum number of lines before and after the mark passed to them. They try to +include @hid[Defun Parse Goal] number of top level forms before and after the +mark passed them, but these functions never return marks that include more than +the maximum number of lines before or after the mark passed to them. +@enddefun + +@defun[fun {form-offset}, args {@i[mark] @i[count]}] +This tries to move @i[mark] @i[count] forms forward if positive or -@i[count] +forms backwards if negative. @i[Mark] is always moved. If there were enough +forms in the appropriate direction, this returns @i[mark], otherwise nil. +@enddefun + +@defun[fun {top-level-offset}, args {@i[mark] @i[count]}] +This tries to move @i[mark] @i[count] top level forms forward if positive or +-@i[count] top level forms backwards if negative. If there were enough top +level forms in the appropriate direction, this returns @i[mark], otherwise nil. +@i[Mark] is moved only if this is successful. +@enddefun + +@defun[fun {mark-top-level-form}, args {@i[mark1] @i[mark2]}] +This moves @i[mark1] and @i[mark2] to the beginning and end, respectively, of +the current or next top level form. @i[Mark1] is used as a reference to start +looking. The marks may be altered even if unsuccessful. If successful, return +@i[mark2], else nil. @i[Mark2] is left at the beginning of the line following +the top level form if possible, but if the last line has text after the closing +parenthesis, this leaves the mark immediately after the form. +@enddefun + +@defun[fun {defun-region}, args {@i[mark]}] +This returns a region around the current or next defun with respect to +@i[mark]. @i[Mark] is not used to form the region. If there is no appropriate +top level form, this signals an editor-error. This calls +@f[pre-command-parse-check] first. +@enddefun + +@defun[fun {inside-defun-p}, args {@i[mark]}] +@defun1[fun {start-defun-p}, args {@i[mark]}] +These return, respectively, whether @i[mark] is inside a top level form or at +the beginning of a line immediately before a character whose @hid[Lisp Syntax] +(see section @ref[sys-def-chars]) value is @kwd[opening-paren]. +@enddefun + +@defun[fun {forward-up-list}, args {@i[mark]}] +@defun1[fun {backward-up-list}, args {@i[mark]}] +Respectively, these move @i[mark] immediately past a character whose @hid[Lisp +Syntax] (see section @ref[sys-def-chars]) value is @kwd[closing-paren] or +immediately before a character whose @hid[Lisp Syntax] value is +@kwd[opening-paren]. +@enddefun + +@defun[fun {valid-spot}, args {@i[mark] @i[forwardp]}] +This returns @true or @nil depending on whether the character indicated by +@i[mark] is a valid spot. When @i[forwardp] is set, use the character after +mark and vice versa. Valid spots exclude commented text, inside strings, and +character quoting. +@enddefun + +@defun[fun {defindent}, args {@i[name] @i[count]}] +This defines the function with @i[name] to have @i[count] special arguments. +@f[indent-for-lisp], the value of @hid[Indent Function] (see section +@ref[indenting]) in @hid[Lisp] mode, uses this to specially indent these +arguments. For example, @f[do] has two, @f[with-open-file] has one, etc. +There are many of these defined by the system including definitions for special +@hemlock forms. @i[Name] is a simple-string, case insensitive and purely +textual (that is, not read by the Lisp reader); therefore, @f["with-a-mumble"] +is distinct from @f["mumble:with-a-mumble"]. +@enddefun + + +@section (English Text Buffers) +@index (English text functions) +@label(text-functions) +This section describes some routines that understand basic English language +forms. + +@defun[fun {word-offset}, args {@i[mark] @i[count]}] +This moves @i[mark] @i[count] words forward (if positive) or backwards (if +negative). If @i[mark] is in the middle of a word, that counts as one. If +there were @i[count] (-@i[count] if negative) words in the appropriate +direction, this returns @i[mark], otherwise nil. This always moves @i[mark]. +A word lies between two characters whose @hid[Word Delimiter] attribute value +is @f[1] (see section @ref[sys-def-chars]). +@enddefun + +@defun[fun {sentence-offset}, args {@i[mark] @i[count]}] +This moves @i[mark] @i[count] sentences forward (if positive) or backwards (if +negative). If @i[mark] is in the middle of a sentence, that counts as one. If +there were @i[count] (-@i[count] if negative) sentences in the appropriate +direction, this returns @i[mark], otherwise nil. This always moves @i[mark]. + +A sentence ends with a character whose @hid[Sentence Terminator] attribute is +@f[1] followed by two spaces, a newline, or the end of the buffer. The +terminating character is optionally followed by any number of characters whose +@hid[Sentence Closing Char] attribute is @f[1]. A sentence begins after a +previous sentence ends, at the beginning of a paragraph, or at the beginning of +the buffer. +@enddefun + +@defun[fun {paragraph-offset}, args {@i[mark] @i[count] @optional @i[prefix]}] +@defhvar1[var {Paragraph Delimiter Function}, var {default-para-delim-function}] +This moves @i[mark] @i[count] paragraphs forward (if positive) or backwards (if +negative). If @i[mark] is in the middle of a paragraph, that counts as one. +If there were @i[count] (-@i[count] if negative) paragraphs in the appropriate +direction, this returns @i[mark], otherwise nil. This only moves @i[mark] if +there were enough paragraphs. + +@hid[Paragraph Delimiter Function] holds a function that takes a mark, +typically at the beginning of a line, and returns whether or not the current +line should break the paragraph. @f[default-para-delim-function] returns @true +if the next character, the first on the line, has a @hid[Paragraph Delimiter] +attribute value of @f[1]. This is typically a space, for an indented +paragraph, or a newline, for a block style. Some modes require a more +complicated determinant; for example, @hid[Scribe] modes adds some characters +to the set and special cases certain formatting commands. + +@i[Prefix] defaults to @hid[Fill Prefix] (see section @ref[filling]), and the +right prefix is necessary to correctly skip paragraphs. If @i[prefix] is +non-@nil, and a line begins with @i[prefix], then the scanning process skips +the prefix before invoking the @hid[Paragraph Delimiter Function]. +Note, when scanning for paragraph bounds, and @i[prefix] is non-@nil, lines are +potentially part of the paragraph regardless of whether they contain the prefix; +only the result of invoking the delimiter function matters. + +The programmer should be aware of an idiom for finding the end of the current +paragraph. Assume @f[paragraphp] is the result of moving @f[mark] one +paragraph, then the following correctly determines whether there actually is a +current paragraph: +@begin[programexample] +(or paragraphp + (and (last-line-p mark) + (end-line-p mark) + (not (blank-line-p (mark-line mark))))) +@end[programexample] +In this example @f[mark] is at the end of the last paragraph in the buffer, and +there is no last newline character in the buffer. @f[paragraph-offset] would +have returned @nil since it could not skip any paragraphs since @f[mark] was at +the end of the current and last paragraph. However, you still have found a +current paragraph on which to operate. @f[mark-paragraph] understands this +problem. +@enddefun + +@defun[fun {mark-paragraph}, args {@f[mark1] @f[mark2]}] +This marks the next or current paragraph, setting @i[mark1] to the beginning +and @i[mark2] to the end. This uses @hid[Fill Prefix] (see section +@ref[filling]). @i[Mark1] is always on the first line of the paragraph, +regardless of whether the previous line is blank. @i[Mark2] is typically at +the beginning of the line after the line the paragraph ends on, this returns +@i[mark2] on success. If this cannot find a paragraph, then the marks are left +unmoved, and @nil is returned. +@enddefun + + +@section (Logical Pages) +@index (Logical pages) +@index (Page functions) +@label(logical-pages) +Logical pages are a way of dividing a file into coarse divisions. This is +analogous to dividing a paper into sections, and @hemlock provides primitives +for moving between the pages of a file and listing a directory of the page +titles. Pages are separated by @hid[Page Delimiter] characters (see section +@ref[sys-def-chars]) that appear at the beginning of a line. + +@defun[fun {goto-page}, args {@i[mark] @i[n]}] +This moves @i[mark] to the absolute page numbered @i[n]. If there are less +than @i[n] pages, it signals an editor-error. If it returns, it returns +@i[mark]. @hemlock numbers pages starting with one for the page delimited by +the beginning of the buffer and the first @hid[Page Delimiter] (or the end of +the buffer). +@enddefun + +@defun[fun {page-offset}, args {@i[mark] @i[n]}] +This moves mark forward @i[n] (-@i[n] backwards, if @i[n] is negative) +@hid[Page Delimiter] characters that are in the zero'th line position. If a +@hid[Page Delimiter] is the immediately next character after mark (or before +mark, if @i[n] is negative), then skip it before starting. This always moves +@i[mark], and if there were enough pages to move over, it returns @i[mark]; +otherwise, it returns @nil. +@enddefun + +@defun[fun {page-directory}, args {@i[buffer]}] +This returns a list of each first non-blank line in @i[buffer] that follows a +@hid[Page Delimiter] character that is in the zero'th line position. This +includes the first line of the @i[buffer] as the first page title. If a page +is empty, then its title is the empty string. +@enddefun + +@defun[fun {display-page-directory}, args {@i[stream] @i[directory]}] +This writes the list of strings, @i[directory], to @i[stream], enumerating them +in a field three wide. The number and string are separated by two spaces, and +the first line contains headings for the page numbers and title strings. +@enddefun + + +@section (Filling) +@index (filling) +@label(filling) +Filling is an operation on text that breaks long lines at word boundaries +before a given column and merges shorter lines together in an attempt to make +each line roughly the specified length. This is different from justification +which tries to add whitespace in awkward places to make each line exactly the +same length. @Hemlock's filling optionally inserts a specified string at the +beginning of each line. Also, it eliminates extra whitespace between lines and +words, but it knows two spaces follow sentences (see section +@ref[text-functions]). + +@defhvar[var "Fill Column", val {75}] +@defhvar1[var "Fill Prefix", val {nil}] +These variables hold the default values of the prefix and column arguments to +@hemlock's filling primitives. If @hid[Fill Prefix] is @nil, then there is no +fill prefix. +@enddefhvar + +@defun[fun {fill-region}, args {@i[region] @optional @i[prefix] @i[column]}] +This deletes any blank lines in region and fills it according to prefix and +column. @i[Prefix] and @i[column] default to @hid[Fill Prefix] and @hid[Fill +Column]. +@enddefun + +@defun[fun {fill-region-by-paragraphs}, + args {@i[region] @optional @i[prefix] @i[column]}] +This finds paragraphs (see section @ref[text-functions]) within region and +fills them with @f[fill-region]. This ignores blank lines between paragraphs. +@i[Prefix] and @i[column] default to @hid[Fill Prefix] and @hid[Fill Column]. +@enddefun + + + +@chapter (Utilities) +@index (Utilities) +This chapter describes a number of utilities for manipulating some types of +objects @hemlock uses to record information. String-tables are used to store +names of variables, commands, modes, and buffers. Ring lists can be used to +provide a kill ring, recent command history, or other user-visible features. + + +@section(String-table Functions) +@index (String-tables) +@label(string-tables) + +String tables are similar to Common Lisp hash tables in that they associate a +value with an object. There are a few useful differences: in a string table +the key is always a case insensitive string, and primitives are provided to +facilitate keyword completion and recognition. Any type of string may be added +to a string table, but the string table functions always return +@f[simple-string]'s. + +A string entry in one of these tables may be thought of as being separated into +fields or keywords. The interface provides keyword completion and recognition +which is primarily used to implement some @hid[Echo Area] commands. These +routines perform a prefix match on a field-by-field basis allowing the +ambiguous specification of earlier fields while going on to enter later fields. +While string tables may use any @f[string-char] as a separator, the use of +characters other than @binding[space] may make the @hid[Echo Area] commands +fail or work unexpectedly. + +@defun[fun {make-string-table}, keys {[separator][initial-contents]}] +This function creates an empty string table that uses @i[separator] as the +character, which must be a @f[string-char], that distinguishes fields. +@i[Initial-contents] specifies an initial set of strings and their values in +the form of a dotted @f[a-list], for example: +@Begin[ProgramExample] +'(("Global" . t) ("Mode" . t) ("Buffer" . t)) +@End[ProgramExample] +@enddefun + +@defun[fun {string-table-p}, args {@i[string-table]}] +This function returns @true if @i[string-table] is a @f[string-table] object, +otherwise @nil. +@enddefun + +@defun[fun {string-table-separator}, args {@i[string-table]}] +This function returns the separator character given to @f[make-string-table]. +@enddefun + +@defun[fun {delete-string}, args {@i[string] @i[table]}] +@defun1[fun {clrstring}, args {@i[table]}] +@f[delete-string] removes any entry for @i[string] from the @f[string-table] +@i[table], returning @true if there was an entry. @f[clrstring] removes all +entries from @i[table]. +@enddefun + +@defun[fun {getstring}, args {@i[string] @i[table]}] +This function returns as multiple values, first the value corresponding to the +string if it is found and @nil if it isn't, and second @true if it is found and +@nil if it isn't. + +This may be set with @f[setf] to add a new entry or to store a new value for a +string. It is an error to try to insert a string with more than one +field separator character occurring contiguously. +@enddefun + +@defun[fun {complete-string}, args {@i[string] @i[tables]}] +This function completes @i[string] as far as possible over the list of +@i[tables], returning five values. It is an error for @i[tables] to have +different separator characters. The five return values are as follows: +@begin[itemize] +The maximal completion of the string or @nil if there is none. + +An indication of the usefulness of the returned string: +@begin[description] +@kwd[none]@\ +There is no completion of @i[string]. + +@kwd[complete]@\ +The completion is a valid entry, but other valid completions exist too. This +occurs when the supplied string is an entry as well as initial substring of +another entry. + +@kwd[unique]@\ +The completion is a valid entry and unique. + +@kwd[ambiguous]@\ +The completion is invalid; @f[get-string] would return @nil and @nil if given +the returned string. +@end[description] + +The value of the string when the completion is @kwd[unique] or @kwd[complete], +otherwise @nil. + +An index, or nil, into the completion returned, indicating where the addition +of a single field to @i[string] ends. The command @hid[Complete Field] uses +this when the completion contains the addition to @i[string] of more than one +field. + +An index to the separator following the first ambiguous field when the +completion is @kwd[ambiguous] or @kwd[complete], otherwise @nil. +@end[itemize] +@enddefun + +@defun[fun {find-ambiguous}, args {@i[string] @i[table]}] +@defun1[fun {find-containing}, args {@i[string] @i[table]}] +@f[find-ambiguous] returns a list in alphabetical order of all the +strings in @i[table] matching @i[string]. This considers an entry as matching +if each field in @i[string], taken in order, is an initial substring of the +entry's fields; entry may have fields remaining. + +@f[find-containing] is similar, but it ignores the order of the fields in +@i[string], returning all strings in @i[table] matching any permutation of the +fields in @i[string]. +@enddefun + +@defmac[fun {do-strings}, args {(@i[string-var] @i[value-var] @i[table] @MOPT<@i[result]>) @mstar<@i[declaration]> @mstar<@i[tag] @MOR @i[statement]>}] +This macro iterates over the strings in @i[table] in alphabetical order. On +each iteration, it binds @i[string-var] to an entry's string and @i[value-var] +to an entry's value. +@enddefmac + + +@section (Ring Functions) +@index (Rings) +@label[rings] +There are various purposes in an editor for which a ring of values can be used, +so @hemlock provides a general ring buffer type. It is used for maintaining a +ring of killed regions (see section @ref[kill-ring]), a ring of marks (see +section @ref[mark-stack]), or a ring of command strings which various modes and +commands maintain as a history mechanism. + +@defun[fun {make-ring}, args {@i[length] @optional @i[delete-function]}] +Makes an empty ring object capable of holding up to @i[length] Lisp objects. +@i[Delete-function] is a function that each object is passed to before it falls +off the end. @i[Length] must be greater than zero. +@enddefun + +@defun[fun {ringp}, args {@i[ring]}] +Returns @true if @i[ring] is a @f[ring] object, otherwise @nil. +@enddefun + +@defun[fun {ring-length}, args {@i[ring]}] +Returns as multiple-values the number of elements which @i[ring] +currently holds and the maximum number of elements which it may hold. +@enddefun + +@defun[fun {ring-ref}, args {@i[ring] @i[index]}] +Returns the @i[index]'th item in the @i[ring], where zero is the index +of the most recently pushed. This may be set with @f[setf]. +@enddefun + +@defun[fun {ring-push}, args {@i[object] @i[ring]}] +Pushes @i[object] into @i[ring], possibly causing the oldest item to +go away. +@enddefun + +@defun[fun {ring-pop}, args {@i[ring]}] +Removes the most recently pushed object from @i[ring] and returns it. +If the ring contains no elements then an error is signalled. +@enddefun + +@defun[fun {rotate-ring}, args {@i[ring] @i[offset]}] +With a positive @i[offset], rotates @i[ring] forward that many times. +In a forward rotation the index of each element is reduced by one, +except the one which initially had a zero index, which is made the +last element. A negative offset rotates the ring the other way. +@enddefun + + +@section (Undoing commands) +@index (Undo functions) +@label(undo) + +@defun[fun {save-for-undo}, args {@i[name] @i[method] @optional @i[cleanup] @i[method-undo] @i[buffer]}] +This saves information to undo a command. @i[Name] is a string to display when +prompting the user for confirmation when he invokes the @hid[Undo] command (for +example, @f["kill"] or @f["Fill Paragraph"]). @i[Method] is the function to +invoke to undo the effect of the command. @i[Method-undo] is a function that +undoes the undo function, or effectively re-establishes the state immediately +after invoking the command. If there is any existing undo information, this +invokes the @i[cleanup] function; typically @i[method] closes over or uses +permanent marks into a buffer, and the @i[cleanup] function should delete such +references. @i[Buffer] defaults to the @f[current-buffer], and the @hid[Undo] +command only invokes undo methods when they were saved for the buffer that is +current when the user invokes @hid[Undo]. +@enddefun + +@defun[fun {make-region-undo}, args {@i[kind] @i[name] @i[region] @optional @i[mark-or-region]}] +This handles three common cases that commands fall into when setting up undo +methods, including cleanup and method-undo functions (see @f[save-for-undo]). +These cases are indicated by the @i[kind] argument: +@begin[description] +@kwd[twiddle]@\ +Use this kind when a command modifies a region, and the undo information +indicates how to swap between two regions @dash the one before any modification +occurs and the resulting region. @i[Region] is the resulting region, and it +has permanent marks into the buffer. @i[Mark-or-region] is a region without +marks into the buffer (for example, the result of @f[copy-region]). As a +result of calling this, a first invocation of @hid[Undo] deletes @i[region], +saving it, and inserts @i[mark-or-region] where @i[region] used to be. The +undo method sets up for a second invocation of @hid[Undo] that will undo the +effect of the undo; that is, after two calls, the buffer is exactly as it was +after invoking the command. This activity is repeatable any number of times. +This establishes a cleanup method that deletes the two permanent marks into the +buffer used to locate the modified region. + +@kwd[insert]@\ +Use this kind when a command has deleted a region, and the undo information +indicates how to re-insert the region. @i[Region] is the deleted and saved +region, and it does not contain marks into any buffer. @i[Mark-or-region] is a +permanent mark into the buffer where the undo method should insert @i[region]. +As a result of calling this, a first invocation of @hid[Undo] inserts +@i[region] at @i[mark-or-region] and forms a region around the inserted text +with permanent marks into the buffer. This allows a second invocation of +@hid[Undo] to undo the effect of the undo; that is, after two calls, the buffer +is exactly as it was after invoking the command. This activity is repeatable +any number of times. This establishes a cleanup method that deletes either the +permanent mark into the buffer or the two permanent marks of the region, +depending on how many times the user used @hid[Undo]. + +@kwd[delete]@\ +Use this kind when a command has inserted a block of text, and the undo +information indicates how to delete the region. @i[Region] has permanent marks +into the buffer and surrounds the inserted text. Leave @i[Mark-or-region] +unspecified. As a result of calling this, a first invocation of @hid[Undo] +deletes @i[region], saving it, and establishes a permanent mark into the buffer +to remember where the @i[region] was. This allows a second invocation of +@hid[Undo] to undo the effect of the undo; that is, after two calls, the buffer +is exactly as it was after invoking the command. This activity is repeatable +any number of times. This establishes a cleanup method that deletes either the +permanent mark into the buffer or the two permanent marks of the region, +depending on how many times the user used @hid[Undo]. +@end[description] + +@blankspace(1 line) +@i[Name] in all cases is an appropriate string indicating what the command did. +This is used by @hid[Undo] when prompting the user for confirmation before +calling the undo method. The string used by @hid[Undo] alternates between this +argument and something to indicate that the user is undoing an undo. +@enddefun + + + +@chapter (Miscellaneous) +This chapter is somewhat of a catch-all for comments and features that don't +fit well anywhere else. + + +@section (Generic Pointer Up) +@hid[Generic Pointer Up] is a @hemlock command bound to mouse up-clicks. It +invokes a function supplied with the interface described in this section. This +command allows different commands to be bound to the same down-click in various +modes with one command bound to the corresponding up-click. + +@defun[fun {supply-generic-pointer-up-function}, args {@i[function]}] +@index[Generic Pointer Up] +This function supplies a function that @hid[Generic Pointer Up] invokes the +next time it executes. +@enddefun + + +@section (Using View Mode) +@hid[View] mode supports scrolling through files automatically terminating the +buffer at end-of-file as well as commands for quitting the mode and popping +back to the buffer that spawned the @hid[View] mode buffer. Modes such as +@hid[Dired] and @hid[Lisp-Lib] use this to view files and description of +library entries. + +Modes that want similar commands should use @f[view-file-command] to view a +file and get a handle on the view buffer. To allow the @hid[View Return] and +@hid[View Quit] commands to return to the originating buffer, you must set the +variable @hid[View Return Function] in the viewing buffer to a function that +knows how to do this. Furthermore, since you now have a reference to the +originating buffer, you must add a buffer local delete hook to it that will +clear the view return function's reference. This needs to happen for two +reasons in case the user deletes the originating buffer: +@Begin[Enumerate] +You don't want the return function to go to a non-existing, invalid buffer. + +Since the viewing buffer still exists, its @hid[View Return Function] buffer +local variable still exists. This means the function still references the +deleted originating buffer, and garbage collection cannot reclaim the memory +locked down by the deleted buffer. +@End[Enumerate] + +The following is a piece of code that could implement part of @hid[Dired View +File] that uses two closures to accomplish that described above: +@Begin[ProgramExample] +(let* ((dired-buf (current-buffer)) + (buffer (view-file-command nil pathname))) + (push #'(lambda (buffer) + (declare (ignore buffer)) + (setf dired-buf nil)) + (buffer-delete-hook dired-buf)) + (setf (variable-value 'view-return-function :buffer buffer) + #'(lambda () + (if dired-buf + (change-to-buffer dired-buf) + (dired-from-buffer-pathname-command nil))))) +@End[ProgramExample] + +The @hid[Dired] buffer's delete hook clears the return function's reference to +the @hid[Dired] buffer. The return function tests the variable to see if it +still holds a buffer when the function executes. + + + +@comment[@chapter (Auxiliary Systems)] +@include(aux-sys) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/compilation.order =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/compilation.order (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/compilation.order (revision 8058) @@ -0,0 +1,250 @@ +; Definitions of structures intended for use within the HEMLOCK-INTERNALS +; package. +Struct +; Definitions of structures intended for use within the HEMLOCK package. +Struct-ed +; Code specific to CMU Common Lisp on the IBM RT/PC under Mach. +rompsite +; Implementation dependant character hacking macros. +Charmacs +; This is implementation dependent code for canonical input event +; representation. It also provides a interface for converting X11 codes +; and bits to an input event. +Key-event +Keysym-defs +; Implementation independent code to support input to Hemlock, based on +; keytran.lisp and keytrandefs.lisp. +Input +; Random macros needed in the compiler. +Macros +; Implementation dependant line structure definition. +Line + +; Ring-Buffer data-type primitives. +Ring +; String-Table primitives. +Table + +; Text manipulation primitives. +Htext1 +Htext2 +Htext3 +Htext4 + +; Searching and replacing primitives. +Search1 ;String searches. +Search2 ;Character searches, uses %sp-[reverse-]find-character-with-attribute. + +; Stuff that depends on the current line-image building scheme, and +; thus %SP-Find-Character-With-Attribute. +; Build line images. +Linimage +; Cursor-positioning and recentering stuff. +Cursor + +; Uses %SP-Find-Character-With-Attribute, but is independent of line-image +; stuff. +; Syntax table primitives. +Syntax + +; Window image building stuff. +Winimage + +; Implementation dependent redisplay code for running under X. +Hunk-Draw + +; Implementation independent interface to Unix style termcap files. +Termcap + +; Implementation independent redisplay entry points. +Display + +; Implementation dependent redisplay. +Bit-display ;for bitmap displays under X. + +; Implementation dependent redisplay code for running with a terminal. +Tty-disp-rt + +; Implementation independent redisplay code for running with a terminal. +Tty-display + +; Implementation dependent code for random typeout/pop-up displays on the +; bitmap and tty. +pop-up-stream + +; Implementation independent screen management. +Screen + +; Implementation dependent screen management. +Bit-screen ;for bitmap display under X. + +; Implementation independent screen management code for running with a terminal. +Tty-screen + +; Implementation independent code for Hemlock window primitives and +; some other redisplay stuff. +Window + +; Implementation independent interface to fonts. +Font + +; The command interpreter. +Interp + +; Hemlock variable access functions. +Vars + +; Buffer and mode manipulation functions +Buffer + +; Implementation dependent file primitives. +Files + +; Implemention dependent stream primitives. +Streams + +; echo-area prompting functions. +Echo + +; Random top-level user functions and implementation independant initilization +; stuff. +Main + +; Echo-Area commands. +EchoComs + +; Some character attribute definitions. +Defsyn + +; Basic commands +Command +MoreComs + +; Stuff for undoing stuff. +Undo + +; Killing and un-killing commands. Mark ring primitives and commands. +KillComs + +; Searching and replacing commands. +SearchComs + +; File and buffer manipulating commands. +Filecoms + +; Indentation commands +Indent + +; Commands for lisp mode. +Lispmode + +; Comment-hacking commands. +Comments + +; Auto Fill Mode and filling commands. +Fill + +; Text primitives and commands (paragraphs, sentences, etc.) +Text + +; Documentation commands. +Doccoms + +; Commands for buffer comparison and stuff. +Srccom + +; Commands for manipulating groups of files. +Group + +; Implementation dependent spell code. +Spell-RT +; Spelling correction interface implementation. +Spell-Corr +; Spell interface to incrementally add to the dictionary. +Spell-Aug +; Nearly implementation independent code to build binary dictionary. +Spell-Build +; User interface commands. +Spellcoms + +; Word abbreviation commands. +Abbrev + +; Overwrite mode, for making text pictures and stuff. +Overwrite + +; Gosling Emacs bindings and twiddle chars command. Lots of other +;differences. +gosmacs + +; a typescript server in Hemlock. Client Lisp's *terminal-io* streams are +; set to typescript streams which send message requests to typescript servers +; for input and output, so this is how client Lisps can do full I/O inside +; a Hemlock buffer. +Ts-buf +Ts-stream + +; commands for interacting with client Lisp environments and REP loops. +eval-server +Lispeval + +; commands for evaling and running a REP loop in a buffer. +Lispbuf + +; Keyboard macros and stuff. +Kbdmac + +; Hackish thing to italicize comments. +Icom + +; Stuff to check buffer integrity. +Integrity + +; Scribe Mode +Scribe + +; Definition editing/function definition finding +Edit-Defs + +; auto-save mode. +auto-save + +; register code. stuff for stashing marks and regions in "registers". +register + +; commands pertinent only to the X windowing system. +xcoms + +; implements Unix specific commands for Hemlock. +unixcoms + +; mail interface to MH. +mh + +; highlighting parens and active regions. +highlight + +; directory editing; implementation dependent. +dired +diredcoms + +; buffer hacking mode. +bufed + +; lisp library browser mode; implementation dependent. +lisp-lib + +; completion mode to save key strokes for long Lisp identifiers. +completion + +; "Process" mode, primarily implements Unix shells in Hemlock buffers. +shell + +; stuff for talking to slave Lisps to do debugging. +debug + +; site dependent NNTP interface for reading Netnews. +netnews + +; File that sets up all the default key bindings; implementation dependant. +Bindings Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/hemlock.log =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/hemlock.log (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/hemlock.log (revision 8058) @@ -0,0 +1,4514 @@ +.../systems-work/hemlock/mh.lisp, 18-Oct-90 13:41:38, Edit by Chiles. + MAYBE-DELETE-EXTRA-DRAFT-WINDOW modified to correctly delete another window + if one exists when a draft is a split window draft. This had to be modified + to handle separate, unstacked windows correctly. + +.../systems-work/hemlock/bindings.lisp, 06-Sep-90 16:59:32, Edit by Chiles. + We failed to avoid binding "Auto Check Word Spelling" to #k"'" when we added + the new key-event stuff. Actually, Blaine did. + +.../systems-work/hemlock/bindings.lisp, 24-Aug-90 14:04:34, Edit by Chiles. + Bound C-M-s (typically "Shell") to "Illegal" in the echo area. + +.../systems-work/hemlock/bit-screen.lisp, 06-Aug-90 13:48:10, Edit by Chiles. + I modified CREATE-WINDOW-FROM-CURRENT to correctly determin if there is + enough room to split the current window to make the new window. + +.../systems-work/hemlock/bit-screen.lisp, 06-Aug-90 12:59:40, Edit by Chiles. + Made SET-WINDOW-HOOK-RAISE-FUN frob the windows group X window, instead of + the child X window. + +.../systems-work/hemlock/hunk-draw.lisp, 05-Aug-90 12:57:21, Edit by Chiles. + Fixed DROP-CURSOR to beat on the parent borders instead of the non-existent + child borders. + +.../systems-work/hemlock/bit-screen.lisp, 05-Aug-90 11:58:46, Edit by Chiles. + Removed exports for MAKE-WINDOW, DELETE-WINDOW, NEXT-WINDOW, and + PREVIOUS-WINDOW since they're in screen.lisp. + + Modified HUNK-RECONFIGURED to realize it object arg is either a hunk (for a + child changing) or a window-group (for a group/parent window changing). + + Modified HUNK-MOUSE-ENTERED and HUNK-MOUSE-LEFT to frob the group window's + border instead of the child's border. + + Totally redefined *create-window-hook* and *delete-window-hook*. This + affected most of the arrangement of creation and deletion functionality. + + Made the random-typeout window made from keeping a pop-up display, adhere to + the minimum resizing parameters Hemlock windows like to try to keep users + from screwing themselves. + + Made MAYBE-MAKE-X-WINDOW-AND-PARENT set window manager hints for supplied + parents as if Hemlock had made the parent window. + + Made code correctly handle font-family parameters instead of dropping into + lower-level code that incorrectly assumed *default-font-family*. + + Consolidated some code, notably MODIFY-PARENT-PROPERTIES. + + +.../systems-work/hemlock/xcoms.lisp, 01-Aug-90 14:00:43, Edit by Chiles. + Blew away "Stack Window". + +.../systems-work/hemlock/input.lisp, 01-Aug-90 13:49:27, Edit by Chiles. + Blaine modified MAYBE-KEEP-RANDOM-TYPEOUT-WINDOW in accordance with the new + bitmap window group stuff. + +.../systems-work/hemlock/filecoms.lisp, 01-Aug-90 11:23:07, Edit by Chiles. + Blaine modified "Delete Window" and "Delete Next Window" in accordance with + the new bitmap window group stuff. They now test the length of *window-list* + to determine if they can delete the window instead of using next and previous + window commands and primitives and testing against the CURRENT-WINDOW. + +.../systems-work/hemlock/screen.lisp, 01-Aug-90 10:15:53, Edit by Chiles. + Blaine modified DELETE-WINDOW to test for *window-list* having length two or + less, signalling an error if so. This allows the bitmap window deletion + method to delete the current window by changing to another group. The + "Delete Window" command cannot tell there are other windows, and it already + tries to make the previous window the current one before calling the + DELETE-WINDOW primitive. With the new bitmap window groups, this doesn't + work. We still have a problem if a programmer calls DELETE-WINDOW on the + current window which will break Hemlock. + +.../systems-work/hemlock/rompsite.lisp, 01-Aug-90 09:33:02, Edit by Chiles. + Blaine modified the X events masks and the raising and lowering of Hemlock + windows upon entering and leaving in accordance with the new bitmap window + groups. + +.../systems-work/hemlock/struct.lisp, 01-Aug-90 09:07:25, Edit by Chiles. + Blaine added window-group structure and the window-group slot to + bitmap-hunks for the new bitmap window groups. + +.../systems-work/hemlock/keysym-defs.lisp, 04-Jul-90 12:14:09, Edit by Chiles. + Added a few key-event to character translations at the end of the file to + make quoting characters work better when running under X. + +/usr2/mbb/lisp/work/diredcoms.lisp, 02-Jul-90 10:12:28, Edit by Mbb. + Fixed a bug in "Dired" where it was incorrectly assuming that the current + buffer was a DIRED buffer. + +.../systems-work/hemlock/searchcoms.lisp, 27-Jun-90 18:27:38, Edit by Chiles. +.../systems-work/hemlock/kbdmac.lisp, 27-Jun-90 18:19:09, Edit by Chiles. + Fixed "Keyboard Macro Query" to realize the :bind arg to COMMAND-CASE is a + key-event, not a charcter. + +.../systems-work/hemlock/macros.lisp, 27-Jun-90 18:04:12, Edit by Chiles. + Fixed COMMAND-CASE to bind key-events, not characters. It also doesn't make + N calls to mapping functions everytime someone was to map one way or the + other. It also no longer makes erroneous assumptions about characters and + key-events having a one-to-one mapping. + +.../systems-work/hemlock/key-event.lisp, 27-Jun-90 17:34:57, Edit by Chiles. + Fixed bugs in character/key-event mapping that allowed bogus typed objects to + fall through as if they mapped to meaningful values. + +.../systems-work/hemlock/interp.lisp, 26-Jun-90 09:54:52, Edit by Chiles. + Fixed some documentation. + + Fixed a bug in KEY-TRANSLATION. Someone changed a type-spec from '(or + simple-vector null) to '(simple-vector null). + + Fixed a bug in TRANSLATE-KEY. It returned the wrong thing and by accident + didn't go into an infinite loop if there were any key translations to + multiple key-event keys. + + +.../systems-work/hemlock/echo.lisp, 25-Jun-90 11:44:05, Edit by Chiles. + Fixed default prompt of PROMPT-FOR-KEY-EVENT to be "Key-event: ", not + "Character: ". + +.../systems-work/hemlock/interp.lisp, 24-Jun-90 12:28:02, Edit by Chiles. + Removed silly KEYIFY definition, and I put Blaine's name on the file since he + modified half of the contents to get the new key tables stuff to work. + +.../systems-work/hemlock/input.lisp, 21-Jun-90 19:52:01, Edit by Chiles. + Added doc strings to public routines. Documented some code. Moved some + silly things around. + +.../systems-work/hemlock/srccom.lisp, 21-Jun-90 18:53:46, Edit by Chiles. +.../systems-work/hemlock/spellcoms.lisp, 21-Jun-90 18:52:56, Edit by Chiles. +.../systems-work/hemlock/macros.lisp, 21-Jun-90 18:51:19, Edit by Chiles. +.../systems-work/hemlock/filecoms.lisp, 21-Jun-90 18:49:14, Edit by Chiles. +.../systems-work/hemlock/doccoms.lisp, 21-Jun-90 18:45:55, Edit by Chiles. + Made COMMAND-CASE specify lowercase letters. + +.../systems-work/hemlock/key-event.lisp, 20-Jun-90 23:11:18, Edit by Chiles. + Fixed a bug in TRANSLATE-KEY-EVENT. + +.../systems-work/hemlock/bindings.lisp, 20-Jun-90 23:03:22, Edit by Chiles. + Bound #k"H-t" to "Illegal" in the echo area. This is normally bound to a + command that makes the current window display the most recently used + random-typeout buffer. + +.../systems-work/hemlock/macros.lisp, 20-Jun-90 20:45:07, Edit by Chiles. + Fixed an extra paren bug that prevented successful compilation. That's what + I get for Blaine's failure to use "Extract Form". + +.../systems-work/hemlock/lispmode.lisp, 20-Jun-90 20:47:57, Edit by Chiles. + Added "Extract Form", a more useful and intuitive and consistent command to + use instead of "Extract List" which is archaic, confusing, erroneously bound + by default, and bound to old Lisp ideals that lists are something to focus + on. + +.../hemlock/ts-buf.lisp, 20-Jun-90 17:40:51, Edit by Wlott. + Made typescript commands more robust in light of the possibility of being + executed while in a buffer other than the slave buffer. + +.../systems-work/hemlock/key-event.lisp, 20-Jun-90 17:00:33, Edit by Chiles. + Totally rewrote mouse translation code. Fixed multiple bugs MAKE-KEY-EVENT. + +.../systems-work/hemlock/macros.lisp, 20-Jun-90 13:55:48, Edit by Chiles. + Removed :character argument to COMMAND-CASE. Stopped case-folding and + eliminated variables used for that. + +.../systems-work/hemlock/fill.lisp, 16-Jun-90 14:07:48, Edit by Chiles. + Fixed "Auto Fill Linefeed" and "Auto Fill Return" to use #k syntax instead of + characters for keys. + +.../systems-work/hemlock/key-event.lisp, 16-Jun-90 13:59:23, Edit by Chiles. + Added missing exports. + + Fixed a couple bugs with DEFINE-KEY-EVENT-MODIFIER. It was using EQL to + compare strings. Stuck an UNWIND-PROTECT in there to keep things consistent. + Added restart for already defined modifiers allowing the user to go on + blowing it off; this helps reloading the file. + + +.../systems-work/hemlock/echo.lisp, 16-Jun-90 11:11:17, Edit by Chiles. + Fixed two GET-KEY-EVENT calls to ignore abort attempts in PROMPT-FOR-KEY + and PROMPT-FOR-KEY-EVENT. + +.../systems-work/hemlock/keysym-defs.lisp, 15-Jun-90 18:17:38, Edit by Chiles. + This file used to be called keytrandefs.lisp. + +.../systems-work/hemlock/key-event.lisp, 15-Jun-90 18:34:10, Edit by Chiles. + This file used to be called keytran.lisp. It now implements key-events in + the "EXTENSIONS" package. + +.../systems-work/hemlock/bit-screen.lisp, 14-Jun-90 14:28:58, Edit by Chiles. + Replaced calls to EXT:TRANSLATE-CHARACTER and EXT:TRANSLATE-MOUSE-CHARACTER + with EXT:TRANSLATE-KEY-EVENT and EXT:TRANSLATE-MOUSE-KEY-EVENT. + +.../systems-work/hemlock/shell.lisp, 15-Jun-90 16:27:42, Edit by Chiles. + Picked up Blaine's new shell hacks and documented them. Added "Current + Shell" and "Ask about Old Shells" variables. Changed "Shell" to be more like + "Select Slave" and wrote "Shell Command Line in Buffer". + +/usr2/mbb/lisp/work/doccoms.lisp, 14-Jun-90 21:19:46, Edit by Mbb. + Made a quoted list of #k mouse-keys be a call to LIST on the mouse-keys + instead so they would get evaluated. + +/usr2/mbb/lisp/work/input.lisp, 12-Jun-90 21:00:12, Edit by Mbb. + input.lisp is a new file. It contains code to implement input to + hemlock. Similar code previously resided in rompsite.lisp + +/usr2/mbb/lisp/work/icom.lisp, 12-Jun-90 16:15:00, Edit by Mbb. +/usr2/mbb/lisp/work/gosmacs.lisp, 12-Jun-90 16:15:00, Edit by Mbb. + Changed BIND-KEY calls to use #k format instead of characters. + +.../systems-work/hemlock/filecoms.lisp, 13-Jun-90 15:17:06, Edit by Chiles. + Wrote "Go to One Window" which makes a default initial window and deletes all + other windows. This is useful with losing window managers like twm, and it + is useful in case you ever resize or move the main Hemlock window which + happens by accident to some people. + +/usr2/mbb/lisp/work/keytran.lisp, 13-Jun-90 14:01:58, Edit by Mbb. + Changed all the BIND-KEY forms in this file to use #k format. + +/usr2/mbb/lisp/work/files.lisp, 12-Jun-90 10:26:58, Edit by Mbb. + Inserted the form (proclaim '(special vm_page_size)) so the compiler + wouldn't whine about vm_page_size not being declared or bound. + +/usr2/mbb/lisp/work/buffer.lisp, 11-Jun-90 11:58:39, Edit by Mbb. + Modified DEFMODE -- The default mode-bindings slot is now a hash-table + whereas it used to be a key-table. Did the same for buffer-bindings in + MAKE-BUFFER. + +/usr2/mbb/lisp/work/keytrandefs.lisp, 11-Jun-90 13:17:59, Edit by Mbb. + Made all calls to "EXTENSIONS" use an ext: prefix. + +/usr2/mbb/lisp/work/scribe.lisp, 08-Jun-90 17:33:31, Edit by Mbb. +/usr2/mbb/lisp/work/register.lisp, 08-Jun-90 17:29:23, Edit by Mbb. +/usr2/mbb/lisp/work/interp.lisp, 08-Jun-90 17:27:44, Edit by Mbb. + Changed all calls to PRINT-PRETTY-CHARACTER to calls to + PRINT-PRETTY-KEY-EVENT. + +/usr2/mbb/lisp/work/kbdmac.lisp, 08-Jun-90 17:25:50, Edit by Mbb. + Made all calls to SUB-PRINT-KEY be calls to PRINT-PRETTY-KEY. + +/usr2/mbb/lisp/work/doccoms.lisp, 08-Jun-90 17:15:46, Edit by Mbb. + Removed SUB-PRINT-KEY in favor of PRINT-PRETTY-KEY. + +/usr2/mbb/lisp/work/searchcoms.lisp, 08-Jun-90 14:38:55, Edit by Mbb. +/usr2/mbb/lisp/work/overwrite.lisp, 08-Jun-90 14:38:38, Edit by Mbb. +/usr2/mbb/lisp/work/morecoms.lisp, 08-Jun-90 14:37:43, Edit by Mbb. +/usr2/mbb/lisp/work/completion.lisp, 08-Jun-90 14:37:10, Edit by Mbb. +/usr2/mbb/lisp/work/command.lisp, 08-Jun-90 14:36:12, Edit by Mbb. + Changed all calls to TEXT-CHARACTER to calls to KEY-EVENT-CHAR. + +/usr2/mbb/lisp/work/rompsite.lisp, 08-Jun-90 12:15:17, Edit by Mbb. +/usr2/mbb/lisp/work/termcap.lisp, 08-Jun-90 12:15:17, Edit by Mbb. + Commented out CL-TERMCAP-CHAR as it is no longer needed. + GET-TERMCAP-STRING-CHAR does the conversion to a character now. + +/usr2/mbb/lisp/work/doccoms.lisp, 08-Jun-90 11:08:09, Edit by Mbb. + Removed from GET-MOUSE-COMMANDS a call to MAKE-CHAR in favor of + MAKE-KEY-EVENT and also fixed a list to use the new #k"foo" format. + +/usr2/mbb/lisp/work/bindings.lisp, 08-Jun-90 10:44:49, Edit by Mbb. + Chnaged all bindings to #k"foo" format. + +/usr2/mbb/lisp/work/charmacs.lisp, 07-Jun-90 14:44:36, Edit by Mbb. + Removed the declaration of the constant all-bit-names, as bit names are + no longer supported in Common Lisp. + +/usr2/mbb/lisp/work/charmacs.lisp, 07-Jun-90 14:41:23, Edit by Mbb. + Changed ALPHA-CHAR-LOOP and DO-ALPHA-CHARS to ALPHA-KEY-EVENTS-LOOP and + DO-ALPHA-KEY-EVENTS respectively. + +/usr2/mbb/lisp/work/tty-display.lisp, 06-Jun-90 10:38:07, Edit by Mbb. +/usr2/mbb/lisp/work/searchcoms.lisp, 06-Jun-90 10:36:39, Edit by Mbb. +/usr2/mbb/lisp/work/searchcoms.lisp, 06-Jun-90 10:21:58, Edit by Mbb. +/usr2/mbb/lisp/work/rompsite.lisp, 06-Jun-90 10:09:11, Edit by Mbb. +/usr2/mbb/lisp/work/morecoms.lisp, 06-Jun-90 10:16:52, Edit by Mbb. +/usr2/mbb/lisp/work/mh.lisp, 06-Jun-90 10:14:12, Edit by Mbb. +/usr2/mbb/lisp/work/doccoms.lisp, 06-Jun-90 10:04:45, Edit by Mbb. +/usr2/mbb/lisp/work/macros.lisp, 05-Jun-90 15:11:03, Edit by Mbb. +/usr2/mbb/lisp/work/kbdmac.lisp, 05-Jun-90 15:08:37, Edit by Mbb. +/usr2/mbb/lisp/work/interp.lisp, 05-Jun-90 11:02:59, Edit by Mbb. +/usr2/mbb/lisp/work/echo.lisp, 05-Jun-90 10:58:55, Edit by Mbb. +/usr2/mbb/lisp/work/doccoms.lisp, 05-Jun-90 15:05:40, Edit by Mbb. +/usr2/mbb/lisp/work/command.lisp, 05-Jun-90 15:02:21, Edit by Mbb. + Fixed all references to *editor-input*. + +/usr2/mbb/lisp/work/main.lisp, 06-Jun-90 10:07:41, Edit by Mbb. + *editor-input* used to be exported from this file, event though it is + also exported in input.lisp. Removed export from main.lisp. + +/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 14:31:55, Edit by Mbb. + Changed reference to *character-history* in SITE-INIT to + *key-event-history*. + +/usr2/mbb/lisp/work/mh.lisp, 05-Jun-90 14:30:28, Edit by Mbb. + Changed a reference to *character-history* to *key-event-history*. + +/usr2/mbb/lisp/work/main.lisp, 05-Jun-90 14:27:23, Edit by Mbb. + Removed export of *character-history* from this file in favor of putting + it in input.lisp and changing the name to *key-event-history*. + +/usr2/mbb/lisp/work/doccoms.lisp, 05-Jun-90 14:19:41, Edit by Mbb. + Made "What Lossage" command reference *key-event-history* instead of + *character-history*. + +/usr2/mbb/lisp/work/streams.lisp, 05-Jun-90 14:10:43, Edit by Mbb. + Made KBDMAC-GET use *last-key-event-typed* instead of + *last-character-typed*. Also changed stream definition of kbdmac-stream + to coincide with the new editor-input like streams. + +/usr2/mbb/lisp/work/spellcoms.lisp, 05-Jun-90 14:08:57, Edit by Mbb. + Made SUB-CORRECT-LAST-MISSPELLED-WORD work with *last-key-event-typed*. + +/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 14:07:23, Edit by Mbb. + Fixed "Scribe Insert bracket" to work with *last-key-event-typed*. + +/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 13:59:46, Edit by Mbb. + Removed all Input queue management and Random Typeout input routines and + put them in a input.lisp, a new hemlock file. + +/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 13:45:23, Edit by Mbb. + Changed DEFVAR of *last-character-typed* to *last-key-event-typed*. Also + fixed setting of *last-character-typed* in DQ-EVENT. For some reason, + *last-character-typed* was exported from both main.lisp and + rompsite.lisp. This remains under the new name. + +/usr2/mbb/lisp/work/overwrite.lisp, 05-Jun-90 13:43:23, Edit by Mbb. + Made "Self Overwrite" use *last-key-event-typed* instead of + *last-character-typed*. + +/usr2/mbb/lisp/work/morecoms.lisp, 05-Jun-90 13:41:58, Edit by Mbb. + Made "Self Insert Caps Lock" deal with *last-key-event-typed* instead of + *last-character-typed*. + +/usr2/mbb/lisp/work/main.lisp, 05-Jun-90 13:40:48, Edit by Mbb. + Changed export of *last-character-typed* to *last-key-event-typed*. + +/usr2/mbb/lisp/work/kbdmac.lisp, 05-Jun-90 13:37:38, Edit by Mbb. + Made DEFAULT-KBDMAC-TRANSFORM and SELF-INSERT-KBDMAC-TRANSFORM use + *last-key-event-typed* instead of *last-character-typed*. + +/usr2/mbb/lisp/work/echocoms.lisp, 05-Jun-90 13:34:52, Edit by Mbb. + Made "Complete Field" work with *last-key-event-typed*. +/usr2/mbb/lisp/work/completion.lisp, 05-Jun-90 13:28:07, Edit by Mbb. + Made "Completion Self Insert" deal with *last-key-event-typed* instead of + *last-character-typed*. + +/usr2/mbb/lisp/work/command.lisp, 05-Jun-90 13:24:55, Edit by Mbb. + Changed UNIVERSAL-ARGUMENT-LOOP to deal with *last-key-event-typed* + instead of *last-character-typed*. Also made "Self Insert" do the same. + +/usr2/mbb/lisp/work/spellcoms.lisp, 05-Jun-90 12:58:02, Edit by Mbb. + Changed calls to PROMPT-FOR-CHARACTER to calls to PROMPT-FOR-KEY-EVENT. + Since what we wanted was the number of the correction choice, simply wrap + a call to KEY-EVENT-CHAR around the PROMPT-FOR-KEY-EVENT. + +/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 11:59:46, Edit by Mbb. + Made ADD-SCRIBE-DIRECTIVE and INSERT-SCRIBE-DIRECTIVE use PROMPT-FOR-KEY + instead of PROMPT-FOR-CHARACTER. They used to HASH on the result of + PROMPT-FOR-CHARACTER, so key-events will work just as well. + +/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 11:59:46, Edit by Mbb. + Changed all top-level ADD-SCRIBE-DIRECTIVE-COMMAND calls to use #k syntax + when binding dispatches. + +/usr2/mbb/lisp/work/struct.lisp, 05-Jun-90 11:08:20, Edit by Mbb. + Changed DEFSETF for %SET-LOGICAL-CHAR= to %SET-LOGICAL-KEY-EVENT-P in + order to maintain consistency. + +/usr2/mbb/lisp/work/macros.lisp, 05-Jun-90 09:23:41, Edit by Mbb. + Fixed COMMAND-CASE to bind key-events instead of characters. + +/usr2/mbb/lisp/work/register.lisp, 05-Jun-90 09:31:41, Edit by Mbb. + Made PROMPT-FOR-REGISTER return a key-event instead of a character. The + rest of the code code just hashes on what PROMPT-FOR-REGISTER returns, so + since key-events are unique, nothing else had to be changed. + +/usr2/mbb/lisp/work/keytrandefs.lisp, 04-Jun-90 13:16:13, Edit by Mbb. + Completely changed this file to conform to new key syntax. + +/usr2/mbb/lisp/work/charmacs.lisp, 04-Jun-90 13:10:55, Edit by Mbb. + Removed all pushes into lisp::char-name-alist. + +.../systems-work/hemlock/completion.lisp, 29-May-90 13:54:48, Edit by Chiles. + Changed test in DO-COMPLETION to explicitly test for uppercase characters. + Testing for lowercase characters caused ID's to be uppercased when they began + with non-alphabetic characters (such as digit-chars). + +.../systems-work/hemlock/bindings.lisp, 21-May-90 10:22:28, Edit by Chiles. +.../systems-work/hemlock/morecoms.lisp, 21-May-90 10:19:13, Edit by Chiles. + Added "CAPS-LOCK" mode, "Caps Lock Mode" and "Caps Lock Self Insert". + + Added bindings for lowercase letters. + + +.../systems-work/hemlock/bindings.lisp, 21-May-90 10:14:10, Edit by Chiles. +.../systems-work/hemlock/diredcoms.lisp, 21-May-90 10:03:16, Edit by Chiles. + Wrote "Dired Up Directory" and added binding to #\^ in "Dired" mode. + +.../systems-work/hemlock/diredcoms.lisp, 08-May-90 15:38:28, Edit by Chiles. + Fixed :help string in file prompt for "Delete File". + +.../hemlock/ts-stream.lisp, 26-Apr-90 17:14:10, Edit by Wlott. + Make %ts-stream-listen try calling server before finally saying that + there is no more input available. + +.../hemlock/files.lisp, 26-Apr-90 18:43:29, Edit by Wlott. + Fixed a bug in write-file in which the first line was being extended with + garbage if it didn't start at the first character. + +.../systems-work/hemlock/lispeval.lisp, 16-Apr-90 14:03:10, Edit by Chiles. + Modified OPERATION-STARTED, OPERATION-COMPLETED, and "List Operations" to + preserve the case of context strings when MESSAGE'ing. I added "The"'s to + sentences which previously capitalized the first word of the context and + lowered the remaining parts of the string. I added periods to sentences in + all these routines. I stopped operation listing from forcing the entire + string to lowercase. The user should get his context as he supplied it. + Many users complained about file names reporting as incorrect due to the old + state of the code. + +.../systems-work/hemlock/lispbuf.lisp, 16-Apr-90 13:41:05, Edit by Chiles. + Fixed doc string for "Current Package" in "package" file option handler. + +/usr2/ch/lisp/lispeval.lisp, 15-Apr-90 19:14:38, Edit by Christopher Hoover. + Sometimes the defined "Current Package" does not exist in the slave, and + sometimes "Current Package" is defined as nil. "Describe Function Call" + points out which reason led to using the default package in the slave. + +.../systems-work/hemlock/shell.lisp, 24-Mar-90 11:58:10, Edit by Chiles. + New file. + +.../systems-work/hemlock/bindings.lisp, 24-Mar-90 11:57:31, Edit by Chiles. + Added bindings for new "Process" mode. + +.../systems-work/hemlock/main.lisp, 22-Mar-90 16:03:27, Edit by Blaine. + Added new hook "Buffer Writable Hook". + +.../systems-work/hemlock/buffer.lisp, 22-Mar-90 15:45:51, Edit by Blaine. + Write BUFFER-WRITABLE and %SET-BUFFER-WRITABLE. + +.../systems-work/hemlock/struct.lisp, 22-Mar-90 15:40:31, Edit by Blaine. + Renamed the writable slot to %writable. Added DEFSETF for BUFFER-WRITABLE. + +.../systems-work/hemlock/completion.lisp, 22-Mar-90 14:51:00, Edit by Chiles. + Picked up Blaine's "Save Completions", "Read Completions", and "Parse Buffer + for Completions". + + I added documentation to "Completion" mode and made the parameter + completion-bucket-size-limit be a Hemlock variable "Completion Bucket Size". + + +.../systems-work/hemlock/buffer.lisp, 19-Mar-90 16:45:01, Edit by Chiles. + Made the BUFFER-MODIFIED SETF'er return the value stored. + +.../systems-work/hemlock/table.lisp, 12-Mar-90 12:43:13, Edit by Chiles. + Made BI-SVPOSITION stop calling IDENTITY on every element. There already was + a test for the key argument being nil, but the author allowed the argument to + default to IDENTITY. Also, it is never called without a key argument anyway + -- gratuitous generality maladjusted. + +.../systems-work/hemlock/mh.lisp, 09-Mar-90 09:03:28, Edit by Chiles. + Fixed bug in REMAIL-MESSAGE resulting from recent changes to the environment + code that made my MH env vars become capitalized when they should have been + lowercase. + +.../systems-work/hemlock/lispeval.lisp, 27-Feb-90 15:03:31, Edit by Chiles. + Modified EVAL-FORM-IN-SERVER to optionally take a package name. It uses the + value of "Current Package" as a default, which it previously always supplied. + EVAL-FORM-IN-SERVER-1 accordingly takes a package argument now. "Describe + Function Call" now first asks the server if the value of "Current Package" + names a package, and if it does not, then this command describes the function + call by reading the name into *package* in the slave. This reasonably + handles the problem of describing a function call with a buffer package that + does not exist in the slave. + +.../systems-work/hemlock/screen.lisp, 27-Feb-90 13:18:16, Edit by Mbb. + Made pop-up displays better count lines when fully buffered. + +.../systems-work/hemlock/lispeval.lisp, 22-Feb-90 11:20:03, Edit by Chiles. + Picked up Williams change to "Lisp Operations", and I documented his peculiar + queue implementation. + +.../systems-work/hemlock/srccom.lisp, 21-Feb-90 13:52:45, Edit by Chiles. + Added "Source Compare Ignore Indentation" and wrote a macro to generate the + line comparison routines that *srccom-line-=* holds. + +.../systems-work/hemlock/searchcoms.lisp, 15-Feb-90 10:17:40, Edit by Chiles. + Fixed a bug in undo'ing replacements. IF two were immediately adjacent, the + second would not be undone. + +.../systems-work/hemlock/command.lisp, 14-Feb-90 14:15:38, Edit by Chiles. + Fixed "Forward Character". + +.../systems-work/hemlock/eval-server.lisp, 10-Feb-90 12:07:29, Edit by Chiles. + Made editor MESSAGE what slave is GC'ing when dumping GC messages behind the + prompt. Also, moved the global frobbing into the two routines that setup and + cleanup stream variables. + +.../systems-work/hemlock/mh.lisp, 09-Feb-90 17:02:43, Edit by Chiles. + Finally fixed bug in PICK-MESSAGES that allowed MH pick to screw us. MH pick + would output "0" when no messages matched a specification, so PICK-MESSAGES + now tests the result of calling MH to invoke "pick". It returns nil whenever + MH returns other than t for correct completion. + +.../systems-work/hemlock/termcap.lisp, 08-Feb-90 20:07:01, Edit by Chiles. + The new fd-streams, which correctly implement unreading characters, pointed + out that this code relied on multiply unreading characters. It no longer + does. + +.../systems-work/hemlock/lisp-lib.lisp, 07-Feb-90 15:50:50, Edit by Chiles. + Modified MERGE-PATHNAMES calls that used strings with dots to merge in types. + This no longer works with the new NAMESTRING/PARSE-NAMESTRING stuff. + +.../systems-work/hemlock/command.lisp, 07-Feb-90 13:52:10, Edit by Chiles. + "Next Line" was opening newlines in the middle of the buffer's last line of + text when the buffer wasn't newline terminated. + +/usr2/mbb/lisp/work/macros.lisp, 07-Feb-90 12:22:54, Edit by Mbb. + Changed how WITH-POP-UP-DISPLAY determines whether to cleanup. It + shouldn't have been cleaning up unless something had really happened, but + it was. + +.../systems-work/hemlock/files.lisp, 31-Jan-90 11:58:15, Edit by Chiles. + Modifed all occurrances of "fdstream" to "fd-stream" to be consistent with + new interface. + +.../systems-work/hemlock/mh.lisp, 26-Jan-90 12:41:47, Edit by Chiles. + Fixed bug leaving a file open every time I called MH-PROFILE-COMPONENT, and + closed the process in MH. + +.../systems-work/hemlock/command.lisp, 24-Jan-90 11:06:13, Edit by Chiles. + Changed "Next Line", "Previous Line", "Next Word", "Previous Word", + "Forward Character", "Backward Character", "Delete Next Character", and + "Delete Previous Character" to work with correctly negative arguments. + +.../systems-work/hemlock/macros.lisp, 24-Jan-90 10:40:00, Edit by Chiles. + Modified WITH-POP-UP-DISPLAY to have a doc string other than "Do Some Shit." + +.../systems-work/hemlock/lispbuf.lisp, 22-Jan-90 15:17:49, Edit by Chiles. + Modified code around *prompt* to adhere to new semantics of its values. + +.../hemlock/mh.lisp, 19-Jan-90 21:00:28, Edit by Wlott. + Changed to use new RUN-PROGRAM return values. + +.../systems-work/hemlock/eval-server.lisp, 19-Jan-90 12:07:06, Edit by Chiles. + Modified DO-OPERATION and the thing that aborts operations to handshake on + whether we were in the debugger when we aborted. If we were, output a + message trying to inform the user that the output in his typescript can be + ignored; he is no longer really in the debugger. + +.../systems-work/hemlock/lispeval.lisp, 18-Jan-90 23:21:55, Edit by Chiles. + Fixed "Abort Operations" to really abort the operations (one more time). + +.../systems-work/hemlock/eval-server.lisp, 18-Jan-90 16:45:24, Edit by Chiles. + Made the -slave switch handler setup *gc-notify-before* and *gc-notify-after* + to do gratuitous output to the editor. + +.../systems-work/hemlock/ts-stream.lisp, 18-Jan-90 16:08:00, Edit by Chiles. + Fixed a bug in WAIT-FOR-TYPESCRIPT-INPUT that incorrectly reported input when + the function was re-entered by handling an event in SERVE-EVENT. + +.../systems-work/hemlock/ts-buf.lisp, 18-Jan-90 12:14:40, Edit by Chiles. + Modified TS-BUFFER-OUTPUT-STRING to take a gratuitous-p optional indicating + output should go behind the prompt. + +.../systems-work/hemlock/morecoms.lisp, 17-Jan-90 21:21:53, Edit by Chiles. + Modified DO-RECURSIVE-EDIT to update the modeline field before possibly + signalling an error in the cleanup forms of the UNWIND-PROTECT. + +.../systems-work/hemlock/ts-buf.lisp, 17-Jan-90 15:25:18, Edit by Chiles. + Removed weird disappearing prompt stuff. Added stuff to help users unwedge + themselves when they get behind the prompt. + +.../systems-work/hemlock/streams.lisp, 16-Jan-90 13:42:19, Edit by William. + Made Hemlock output streams make sure the mark is :left-inserting, but only + when actually doing the output. + +.../systems-work/hemlock/morecoms.lisp, 15-Jan-90 09:07:31, Edit by Chiles. + Modified "Count Lines" and "Count Words" to report lines counted as being in + the active region or after the point. + +.../systems-work/hemlock/eval-server.lisp, 15-Jan-90 13:09:19, Edit by Wlott. + Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT. + + Added tweeking of *standard-output* and friends in addition to + *terminal-io* when connecting to a slave. + + +.../systems-work/hemlock/lispeval.lisp, 15-Jan-90 14:13:56, Edit by Wlott. + Made FILE-COMPILE pay attention to "Remote Compile File". (I must have been + brain-dead the first time through that code...) + +.../systems-work/hemlock/files.lisp, 15-Jan-90 15:21:36, Edit by Wlott. + Changed write-file to be faster. + +.../systems-work/hemlock/srccom.lisp, 13-Jan-90 14:42:07, Edit by Chiles. + Made "Merge Buffers" have an (A)lign window with start of difference display + option in the command loop. I often had to use recursive edit to be able to + position the window to see the difference that was otherwise not visible due + to normal scrolling and redisplay centering the mark. + +.../systems-work/hemlock/srccom.lisp, 13-Jan-90 14:00:25, Edit by Chiles. + Fixed "Compare Buffers" and "Merge Buffers" to test for a nil result when + calling LINE-OFFSET. When buffers weren't terminated with newlines, the old + code would infinitely loop. + +.../systems-work/hemlock/lispmode.lisp, 12-Jan-90 18:29:20, Edit by Chiles. + Modified SCAN-DIRECTION-VALID to check for the ignore region falling off the + end of the line which caused %FORM-OFFSET to infinitely loop. + +.../systems-work/hemlock/ts-stream.lisp, 12-Jan-90 12:47:37, Edit by Wlott. + Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT. + +.../systems-work/hemlock/tty-disp-rt.lisp, 11-Jan-90 19:31:46, Edit by Wlott. + Changed to work with fdstreams. + +.../systems-work/hemlock/rompsite.lisp, 11-Jan-90 16:42:02, Edit by Wlott. + Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT. + +.../systems-work/hemlock/tty-screen.lisp, 09-Jan-90 14:27:17, Edit by Chiles. + When we make a random typeout window, we no longer say the screen image is + trashed. Some uses of pop up displays do output and then prompt inside the + form, and this prompting was causing the main window to be redisplayed since + we said the screen image was trashed. This drew over our pop up display. + +.../systems-work/hemlock/indent.lisp, 08-Jan-90 10:20:48, Edit by Mbb. + Made "Center Line" use the active region. + +.../systems-work/hemlock/bit-screen.lisp, 05-Jan-90 17:07:23, Edit by Mbb. + REVERSE-VIDEO-HOOK-FUN was calling the wrong function. + +.../systems-work/hemlock/eval-server.lisp, 01-Dec-89 17:58:53, Edit by Chiles. + Fixed a bug in SERVER-DIED that prevented it from deleting variables + referencing dead server-infos. + +.../systems-work/hemlock/ts-buf.lisp, 01-Dec-89 17:06:22, Edit by Chiles. + Modified and documented TYPESCRIPTIFY-BUFFER to make a local "Current Eval + Server" variable. + +.../systems-work/hemlock/eval-server.lisp, 01-Dec-89 16:29:25, Edit by Chiles. + GET-CURRENT-EVAL-SERVER cleaned up. "Select Slave" rewritten to no longer + set current eval server. + +.../systems-work/hemlock/eval-server.lisp, 22-Nov-89 15:51:42, Edit by Mbb. + Just someone forgetting the result argument to THROW. The old defmacro + compiler stuff didn't catch this, so it used to pass (and amazingly, work). + +.../systems-work/hemlock/morecoms.lisp, 22-Nov-89 15:31:29, Edit by Mbb. + Somehow, the old "Count Lines" worked. How, I don't know. It had an IF + without a THEN clause, which is required by ClTM. The new DEFMACRO stuff + caught it. + +.../systems-work/hemlock/mh.lisp, 27-Oct-89 11:49:25, Edit by Chiles. + After recently eliminating recursive folder support, "List Folders" continued + to claim it would list all folders recursively. Removed useless code and + bogus doc string. + +.../systems-work/hemlock/diredcoms.lisp, 25-Oct-89 16:15:29, Edit by Chiles. + Picked up Blaine's changes to make "Dired" and "Dired with Pattern" do dot + files with an argument. This propagates to subdirectories. + +.../systems-work/hemlock/lisp-lib.lisp, 25-Oct-89 15:59:19, Edit by Chiles. + Made browser look in new library location. + +.../systems-work/hemlock/lispeval.lisp, 29-Sep-89 15:52:50, Edit by Chiles. + Fixed a bug in "Abort Operations" and documented how it works. + +.../systems-work/hemlock/mh.lisp, 28-Sep-89 15:37:39, Edit by Chiles. + Modified "Headers Delete Message" to be prepared to deal with a list of + message ID's when in a message buffer. + +.../systems-work/hemlock/eval-server.lisp, 22-Sep-89 11:28:02, Edit by Chiles. + Made SERVER-COMPILE-TEXT do a TERPRI on error-output since the background + buffer was incredibly hard to read when compiling single defuns. + +.../systems-work/hemlock/rompsite.lisp, 20-Sep-89 00:39:06, Edit by Chiles. + Installed WITHOUT-HEMLOCK from code:lispinit.lisp. This had to be part of + Hemlock, as it should have been, so expansions of it during compilation of + Hemlock would no longer cause hardwired references to bogus "OLD-HI" symbols. + +.../systems-work/hemlock/doccoms.lisp, 19-Sep-89 20:15:26, Edit by Chiles. +.../clisp-1/systems-work/hemlock/echo.lisp, 19-Sep-89 20:06:56, Edit by Chiles. + Replaced ~C FORMAT directives with ~:C to adhere to new standard. + +/usr2/ch/lisp/echocoms.lisp, 11-Sep-89 21:21:46, Edit by Christopher Hoover. + Made "Complete Field" and "Complete Keyword" do the same thing for + parse types of :file. + +/usr1/lisp/hemlock/searchcoms.lisp, 18-Sep-89 12:56:33, Edit by Chiles. + When we fixed QUERY-REPLACE-LOOP to use a permanent marker for the end mark, + we destroyed the current region effect when the current mark was before the + current point. I fixed this to be a permanent mark that is a copy of the end + mark of the region within which we replace things. + +/usr1/lisp/hemlock/mh.lisp, 15-Sep-89 11:30:56, Edit by Chiles. + Blew away "-recurse" from CHECK-FOLDER-NAME-TABLE. + +/usr1/lisp/hemlock/macros.lisp, 14-Sep-89 12:18:47, Edit by Chiles. + Fixed bug in DO-STRINGS introduced with the new string table stuff a few + months ago. It spliced the result form after a DOTIMES instead inside it, so + RETURN's inside the DO-STRING's returned the result form instead of the + returned values. + +/usr/lisp/hemlock/ts-stream.lisp, 13-Sep-89 19:07:27, Edit by Wlott. + Fixed bug in %TS-STREAM-SOUT that caused the character position to become + confused. + +/usr1/lisp/hemlock/lispeval.lisp, 08-Sep-89 11:59:16, Edit by Chiles. + Changed "Forget Compiler ..." to "Flush ...". + +/usr1/lisp/hemlock/diredcoms.lisp, 03-Sep-89 17:39:07, Edit by Chiles. + Stopped DIRED-DOWN-LINE from moving the mark to the beginning of the line. + +/usr1/lisp/hemlock/macros.lisp, 01-Sep-89 10:50:03, Edit by Chiles. + Proclaimed *buffer-names* special. + +/usr1/lisp/hemlock/rompsite.lisp, 27-Aug-89 12:26:44, Edit by Chiles. + Removed BUILD-HEMLOCK. Created load-hem.lisp. + +/usr1/lisp/nhem/rompsite.lisp, 25-Aug-89 11:17:01, Edit by Chiles. + Added LOAD's for new TCP/eval server files. + + Removed old eval server stuff. + + +/usr1/lisp/nhem/eval-server.lisp, 25-Aug-89 11:16:29, Edit by Chiles. + This is a new file. + +/usr1/lisp/nhem/ts-stream.lisp, 25-Aug-89 09:56:46, Edit by Chiles. + This is a new file. + +/usr1/lisp/nhem/ts.lisp, 24-Aug-89 16:35:30, Edit by Chiles. + Basically a new file for interfacing to the new typescript streams. + +/usr1/lisp/nhem/lispeval.lisp, 24-Aug-89 16:16:25, Edit by Chiles. + This is effectively a new file for use with TCP eval servers. + +/usr1/lisp/nhem/lispbuf.lisp, 24-Aug-89 16:07:34, Edit by Chiles. + Added "Editor" mode to this file. + +/usr1/lisp/nhem/edit-defs.lisp, 24-Aug-89 15:57:28, Edit by Chiles. + Updated definition fetching code to use DO-EVAL-FORM instead of + EVAL_FORM-IN-CLIENT. + +/usr1/lisp/nhem/echo.lisp, 24-Aug-89 15:54:00, Edit by Chiles. + Moved LOUD-MESSAGE here from lispeval.lisp and exported it. + +/usr1/lisp/nhem/bindings.lisp, 24-Aug-89 15:51:31, Edit by Chiles. + Commented out binding for "Abort Typescript Input". + + Added bindings for "Next Compiler Error" and "Previous Compiler Error". + + Changed some names "Process Control ..." to "Typescript Slave ...". + + +/usr1/lisp/hemlock/struct.lisp, 16-Aug-89 15:09:14, Edit by Chiles. + Removed + (:print-function ...) + forms for structures that included another structure and explicitly + specified the included functions print fucntion. It is now in the standard + and our system that these should automatically be inherited. + +/usr1/lisp/nhem/bit-screen.lisp, 28-Jul-89 14:42:20, Edit by Chiles. + Blaine fixed his fix to the "Reverse Video" hook for the new pop-up displays. + +/usr1/lisp/nhem/morecoms.lisp, 28-Jul-89 13:45:33, Edit by Chiles. + Restored old definition of "Capitalize Word" and made it loop until it finds + the first alphabetic character in the word instead of assuming the first + character is capitalizable. + +/usr1/lisp/nhem/filecoms.lisp, 27-Jul-89 10:09:56, Edit by Chiles. + Blaine made "Log Change" check that the initial buffer still exists before + going to it. + +/usr1/lisp/nhem/command.lisp, 26-Jul-89 17:49:32, Edit by Chiles. + Rewrote "Universal Argument", "Argument Digit", "Negative Argument". This + fixes the bug M-- M-1 M-2 yielding -8 instead of -12. Now "Universal + Argument" strips bits off every character it reads, and it no longer goes + through the command loop on repeated C-U input. The other two commands + basically setup to jump into "Universal Argument". This means to things: + 1] You no longer can type minus signs after every C-u. + 2] When typing digits, you cannot invoke any commands bound to + a first digit with modifier bits. This should be no big deal. + +/usr1/lisp/hemlock/syntax.lisp, 14-Jul-89 15:26:51, Edit by Chiles. +/usr1/lisp/hemlock/buffer.lisp, 14-Jul-89 15:17:25, Edit by Chiles. +/usr1/lisp/hemlock/vars.lisp, 14-Jul-89 14:31:34, Edit by Chiles. +/usr1/lisp/hemlock/main.lisp, 14-Jul-89 14:33:27, Edit by Chiles. + Moved *global-variable-names* back to main.lisp from vars.lisp since vars is + loaded before table.lisp which defines MAKE-STRING-TABLE. + + Moved *buffer-names* and *mode-names* back to main.lisp for above reason. + + *command-names* from interp. + + *character-attribute-names from syntax. + + +/usr1/lisp/nhem/font.lisp, 11-Jul-89 15:49:59, Edit by Chiles. + Modified NEW-FONT-MARK to terminate a loop correctly and to stop calling + DIS-LINE-LINE on nil. + +/../victoria/usr2/lisp/hemlock/bit-screen.lisp, 09-Jul-89 15:51:46, Edit by Mbb. + Made REVERSE-VIDEO-HOOK-FUN do the right thing for random typeout + windows. I, uhhhh.., kind of missed this. + + Removed an extraneaous variable binding that was causing a "Bound but not + referenced error." + + +/usr1/lisp/nhem/completion.lisp, 07-Jul-89 13:00:47, Edit by Chiles. + #\' is no longer a completion-wordchar in "Lisp" mode. Just an oversight. + +/usr/lisp/hemlock/rompsite.lisp, 07-Jul-89 16:18:51, Edit by Mbb. + Replaced call to INVOKE-HOOK with DOLIST since this is compiled before + macros.lisp, analogous to using VARIABLE-VALUE instead of VALUE. + +/usr/lisp/hemlock/htext1.lisp, 07-Jul-89 16:06:08, Edit by Mbb. +/usr/lisp/hemlock/htext4.lisp, 07-Jul-89 16:06:08, Edit by Mbb. + Frobbed MOVE-SOME-MARKS in htext1.lisp to allow declarations within the + body. Added declarations using this macro in htext4. Also gratuitously + changed the indentation in htext4 of MOVE-SOME-MARKS (To screw file + comparison.) + +/usr/lisp/hemlock/tty-screen.lisp, 07-Jul-89 14:29:53, Edit by Mbb. + Renamed MAKE-DEVICE to MAKE-TTY-DEVICE. + +/usr/lisp/hemlock/struct.lisp, 07-Jul-89 14:19:16, Edit by Mbb. +/usr/lisp/hemlock/bit-display.lisp, 07-Jul-89 14:15:42, Edit by Mbb. +/usr/lisp/hemlock/tty-display.lisp, 07-Jul-89 14:20:47, Edit by Mbb. + Moved device and hunk stuff into struct.lisp. + +/usr/lisp/hemlock/echo.lisp, 07-Jul-89 11:19:23, Edit by Mbb. + Made PROMPTING-MERGE-PATHNAMES work. It used to choke if + pathname-defaults was NIL. + + Moved definition of hemlock-eof from main.lisp to echo.lisp, where it + belongs. + + +/usr/lisp/hemlock/rompsite.lisp, 06-Jul-89 16:20:13, Edit by Mbb. + Moved constant definition of font-map-size from font.lisp to + rompsite.lisp because SETUP-FONT-FAMILY assumed that it was a special. + +/usr/lisp/hemlock/rompsite.lisp, 06-Jul-89 13:21:21, Edit by Mbb. + Moved definitions of *editor-input*, *last-character-typed*, and + *character-history* from main.lisp to rompsite.lisp, where they belong, + and exported them. + +/usr/lisp/hemlock/window.lisp, 06-Jul-89 13:16:55, Edit by Mbb. + Moved definitions of *current-window* and *window-list* from main.lisp to + window.lisp, exporting *window-list*. + +/usr/lisp/hemlock/interp.lisp, 06-Jul-89 13:09:29, Edit by Mbb. + Moved definitions of *command-names*, *prefix-argument-supplied*, and + *prefix-argument* from main.lisp to interp.lisp, exporting *command-names*. + +/usr/lisp/hemlock/buffer.lisp, 06-Jul-89 12:59:36, Edit by Mbb. + Moved definitions of *buffer-names*, *buffer-list*, *current-buffer*, and + *mode-names* from main.lisp to buffer.lisp, exporting all but + *current-buffer*. + +/usr/lisp/hemlock/vars.lisp, 06-Jul-89 12:09:46, Edit by Mbb. + Moved definition of *global-variable-names* from main.lisp to vars.lisp, + where it belongs, and exported it. + +/usr/lisp/hemlock/syntax.lisp, 06-Jul-89 11:57:48, Edit by Mbb. + Moved *last-character-attibute-requested*, *character-attribute-names*, + *value-of-last-character-attribute-requested*, and *character-attributes* + from main.lisp to syntax.lisp, exporting *character-attribute-names*. + + Proclaimed the following variables special: + (*mode-names* *current-buffer* *last-character-attribute-requested* + *value-of-last-character-attribute-requested*). + + +/usr/lisp/hemlock/struct.lisp, 06-Jul-89 11:48:59, Edit by Mbb. + Removed definitions of now-tick and TICK and put them in htext1.lisp, + exporting now-tick. + +/usr/lisp/hemlock/killcoms.lisp, 06-Jul-89 09:40:29, Edit by Mbb. + Proclaimed the following variable special: *delete-char-region*. + +/usr/lisp/hemlock/echocoms.lisp, 06-Jul-89 09:33:57, Edit by Mbb. + Proclaimed the following variable special: *kill-ring*. + +/usr/lisp/hemlock/window.lisp, 05-Jul-89 16:39:31, Edit by Mbb. + Proclaimed the following variable special: *buffer-list*. + +/usr/lisp/hemlock/tty-screen.lisp, 05-Jul-89 16:37:06, Edit by Mbb. + Proclaimed the following variable special: *parse-starting-mark*. + +/usr/lisp/hemlock/screen.lisp, 05-Jul-89 16:30:31, Edit by Mbb. + Proclaimed the following variable special: *echo-area-buffer*. + +/usr/lisp/hemlock/display.lisp, 05-Jul-89 16:28:18, Edit by Mbb. + Proclaimed the following variable special: *window-list*. + + Moved device and hunk structure definitions to struct.lisp. + + +/usr/lisp/hemlock/hunk-draw.lisp, 05-Jul-89 16:24:18, Edit by Mbb. + Proclaimed the following variables special: + (*default-border-pixmap* *highlight-border-pixmap*). + +/usr/lisp/hemlock/cursor.lisp, 05-Jul-89 16:15:50, Edit by Mbb. + Proclaimed the following variable special: the-sentinel. + +/usr/lisp/hemlock/linimage.lisp, 05-Jul-89 16:12:41, Edit by Mbb. + Proclaimed the following variable special: *character-attributes*. + +/usr/lisp/hemlock/macros.lisp, 05-Jul-89 16:10:00, Edit by Mbb. + Proclaimed the following variable special: *echo-area-stream*. + +/usr/lisp/hemlock/rompsite.lisp, 05-Jul-89 16:02:53, Edit by Mbb. + Proclaimed the following variables special: + (FONT-MAP-SIZE *DEFAULT-FONT-FAMILY* *CURRENT-WINDOW* *INPUT-TRANSCRIPT* + *FOREGROUND-BACKGROUND-XOR* *ECHO-AREA-WINDOW* *BUFFER-NAMES* + HEMLOCK::*CREATED-SLAVE-CONNECTED* *CHARACTER-HISTORY* + *SCREEN-IMAGE-TRASHED*). + +/usr/lisp/hemlock/struct-ed.lisp, 05-Jul-89 15:42:36, Edit by Mbb. +/usr/lisp/hemlock/lispeval.lisp, 05-Jul-89 15:42:36, Edit by Mbb. + Created this file for structures that are only used in the HEMLOCK + package. Moved SERVER-INFO structure from lispeval.lisp to this file. + +/usr/lisp/hemlock/rompsite.lisp, 05-Jul-89 15:34:21, Edit by Mbb. + Moved the package initialization stuff from rompsite.lisp to ctw.lisp, as + this is where it should be. + +/usr2/lisp/hemlock/pop-up-stream.lisp, 05-Jul-89 14:07:55, Edit by Mbb. +/usr2/lisp/hemlock/struct.lisp, 05-Jul-89 14:07:55, Edit by Mbb. + Moved the POP-UP-STREAM structure to struct.lisp. + +/usr1/mbb/lisp/work/screen.lisp, 03-Jul-89 17:05:58, Edit by Mbb. + Made RANDOM-TYPEOUT-CLEANUP clean up the modeline field instead of doing + it in both the tty and bitmap cleanup methods. + +/usr1/mbb/lisp/work/pop-up-stream.lisp, 03-Jul-89 15:53:13, Edit by Mbb. + Made misc methods for line-buffered and full-buffered streams distinct. + FORCE-OUTPUT and FINISH-OUTPUT are now no-ops for full-buffered streams. + +/usr1/mbb/lisp/work/macros.lisp, 03-Jul-89 15:43:19, Edit by Mbb. + Made GET-RANDOM-TYPEOUT-INFO assign distinct misc methods to + full-buffered and line-buffered random-typeout streams. + +/usr1/lisp/nhem/window.lisp, 02-Jul-89 15:54:40, Edit by Chiles. + Added "Maximum Modeline Pathname Length" which defaults to nil. Wrote + BUFFER-PATHNAME-ML-FIELD-FUN. + +/usr1/lisp/nhem/morecoms.lisp, 02-Jul-89 16:09:45, Edit by Chiles. + Made "Defhvar" propagate any existing hooks as well. + +/usr1/lisp/nhem/vars.lisp, 02-Jul-89 15:04:33, Edit by Chiles. +/usr1/lisp/nhem/syntax.lisp, 02-Jul-89 15:02:25, Edit by Chiles. +/usr1/lisp/nhem/main.lisp, 02-Jul-89 14:55:14, Edit by Chiles. +/usr1/lisp/nhem/display.lisp, 02-Jul-89 14:43:59, Edit by Chiles. +/usr1/lisp/nhem/buffer.lisp, 02-Jul-89 14:38:55, Edit by Chiles. + Replaced occurrences of DOLIST used to invoke hook functions with the new + INVOKE-HOOK. + +/usr1/lisp/nhem/window.lisp, 02-Jul-89 15:06:35, Edit by Chiles. +/usr1/lisp/nhem/vars.lisp, 02-Jul-89 15:04:33, Edit by Chiles. +/usr1/lisp/nhem/syntax.lisp, 02-Jul-89 15:02:25, Edit by Chiles. +/usr1/lisp/nhem/searchcoms.lisp, 02-Jul-89 14:59:43, Edit by Chiles. +/usr1/lisp/nhem/screen.lisp, 02-Jul-89 14:58:52, Edit by Chiles. +/usr1/lisp/nhem/rompsite.lisp, 02-Jul-89 14:57:44, Edit by Chiles. +/usr1/lisp/nhem/mh.lisp, 02-Jul-89 14:56:23, Edit by Chiles. +/usr1/lisp/nhem/main.lisp, 02-Jul-89 14:55:14, Edit by Chiles. +/usr1/lisp/nhem/interp.lisp, 02-Jul-89 14:52:04, Edit by Chiles. +/usr1/lisp/nhem/htext1.lisp, 02-Jul-89 14:49:28, Edit by Chiles. +/usr1/lisp/nhem/filecoms.lisp, 02-Jul-89 14:41:23, Edit by Chiles. +/usr1/lisp/nhem/buffer.lisp, 02-Jul-89 14:36:54, Edit by Chiles. +/usr1/lisp/nhem/bit-screen.lisp, 02-Jul-89 14:33:21, Edit by Chiles. + Replaced occurrences of + "invoke-hook* '" + with + "invoke-hook ". + + Replaced occurrences of + "invoke-hook '" + with + "invoke-hook ". + + +/usr1/lisp/nhem/vars.lisp, 02-Jul-89 14:30:55, Edit by Chiles. + Deleted function definition for INVOKE-HOOK. + +/usr1/lisp/nhem/macros.lisp, 02-Jul-89 13:45:37, Edit by Chiles. + Wrote macro INVOKE-HOOK that replaces INVOKE-HOOK* and is exported. + +/usr1/lisp/nhem/bit-screen.lisp, 29-Jun-89 11:26:19, Edit by Chiles. + Fixed INIT-BITMAP-DEVICE to drop any pending events on the floor, so + accidental input while not in Hemlock is ignored. + +/usr1/lisp/nhem/lispeval.lisp, 29-Jun-89 10:54:17, Edit by Chiles. + Made default value for "Remote Compile File" be nil. + +/usr1/lisp/nhem/window.lisp, 29-Jun-89 10:43:26, Edit by Chiles. + Moved the :modifiedp modeline-field to be between the modes and buffer name. + Modified the :modifiedp and :buffer-pathname update functions accordingly. + +/usr1/lisp/nhem/macros.lisp, 29-Jun-89 10:12:25, Edit by Chiles. + Fixed GET-RANDOM-TYPEOUT-INFO: it now supplies "Fundamental" only for the + random typeout buffer's modes, and the delete hook is now a compiled function + instead of interpreted. + +/usr1/lisp/nhem/pop-up-stream.lisp, 28-Jun-89 16:41:56, Edit by Chiles. + Fixed a bug in RANDOM-TYPEOUT-MISC that called redisplay on the pop-up window + when it didn't exist. When the stream is full-buffered, and no previous + random typeout has occurred for a given buffer, the window slot in the stream + is nil. This should be fixed better than I have done. + +/usr1/lisp/nhem/lispmode.lisp, 28-Jun-89 16:38:40, Edit by Chiles. + Added DEFINDENT for WITH-POP-UP-DISPLAY. + +/usr1/mbb/lisp/work/bit-screen.lisp, 22-Jun-89 20:11:59, Edit by Mbb. + The device dependant random-typeout-cleanup methods were fixing up the + modeline, but this is device independant, so I moved it to screen.lisp. + +/usr1/mbb/lisp/work/screen.lisp, 22-Jun-89 19:58:08, Edit by Mbb. + RANDOM-TYPEOUT-CLEANUP now sets the Random Typeout buffer's modeline + field to :normal. Before it lost on a Keep character in a more. + +/usr1/mbb/lisp/work/pop-up-stream.lisp, 22-Jun-89 19:48:12, Edit by Mbb. + Fixed NO-TEXT-PAST-BOTTOM-P to work. It previously choked when there + were no newlines in the buffer. + +/usr1/mbb/lisp/work/rompsite.lisp, 22-Jun-89 19:45:54, Edit by Mbb. + Made END-RANDOM-TYPEOUT do a more-prompt, in case the user didn't give us + a newline on his last line of output. This was previously a bug. + +/usr1/mbb/lisp/work/morecoms.lisp, 22-Jun-89 16:21:43, Edit by Mbb. + Made "Capitalize Word" consistent with "Uppercase Word" and "Lowercase + Word". Someone failed to see how easy this was. + +/usr1/mbb/lisp/work/diredcoms.lisp, 22-Jun-89 13:15:07, Edit by Mbb. +/usr1/mbb/lisp/work/rompsite.lisp, 22-Jun-89 13:18:00, Edit by Mbb. + Moved DIRECTORYP from diredcoms.lisp to rompsite.lisp. This is a + generally useful function. + +/usr1/lisp/nhem/searchcoms.lisp, 22-Jun-89 16:29:05, Edit by Chiles. + Fixed a bug in the termination test of the replacement loop. It used to use + a temporary mark to hold onto the end of the region which lost with multiple + replacements on the last line with the end of the region at the end of the + line. + +/usr1/lisp/nhem/bufed.lisp, 22-Jun-89 16:26:59, Edit by Chiles. + Made DELETE-BUFED-BUFFERS a buffer local hook for the bufed buffer. + +/usr1/mbb/lisp/work/filecoms.lisp, 22-Jun-89 10:43:51, Edit by Mbb. + PATHNAME-TO-BUFFER-NAME now returns a string in the form of + pathname. + + Deleted *name/type-separator-character*. + + +/usr1/mbb/lisp/work/echocoms.lisp, 21-Jun-89 17:05:36, Edit by Mbb. + "Complete Keyword" now only merges with the directory of the default, as + opposed to the whole thing. This makes completion look more like the new + confirmation. + +/usr1/mbb/lisp/work/morecoms.lisp, 21-Jun-89 21:45:05, Edit by Mbb. + Made "List Buffers" tabulate it's output. It looks better that way. + +/usr1/mbb/lisp/work/echo.lisp, 21-Jun-89 15:50:43, Edit by Mbb. + Made FILE-VERIFICATION-FUNCTION allow merging of relative pathnames and + nearly honest-to-goodness UNIX pathnames. Eliminated all file-name and + file-type merging, only merging with default directory. However, if the user + only inputs a directory spec, then he could only mean to pick up the + file-namestring from the defaults. + +/usr1/mbb/lisp/work/mh.lisp, 21-Jun-89 11:36:24, Edit by Mbb. +/usr1/mbb/lisp/work/rompsite.lisp, 21-Jun-89 11:41:52, Edit by Mbb. + I moved MERGE-RELATIVE-PATHNAMES from mh.lisp to rompsite.lisp and + exported it for its general usefulness. + +/usr1/lisp/hemlock/bindings.lisp, 21-Jun-89 13:44:07, Edit by Chiles. + Added bindings for "Completion" mode. + +/usr1/lisp/nhem/mh.lisp, 19-Jun-89 18:58:03, Edit by Chiles. + Modified MH once again to supply nil and nil for the group and account + information to RFS-AUTHENTICATE. + +/usr1/lisp/nhem/bindings.lisp, 19-Jun-89 16:28:48, Edit by Chiles. + Changed binding of "Select Random Typeout Buffer". + +/usr1/lisp/nhem/morecoms.lisp, 19-Jun-89 16:26:21, Edit by Chiles. + "List Buffers" no longer shows random typeout buffers. + +/usr1/mbb/lisp/work/pop-up-stream.lisp, 19-Jun-89 14:02:04, Edit by Mbb. + Made line-buffered-moreing work. A last minute fix before I it went into + the last core broke this. + +/usr1/mbb/lisp/work/pop-up-stream.lisp, 18-Jun-89 13:26:12, Edit by Mbb. + Added :charpos feature to the RANDOM-TYPEOUT-MISC method because format + uses it to implement tabbing. + +/usr1/mbb/lisp/work/lispbuf.lisp, 18-Jun-89 12:19:52, Edit by Mbb. + Made "Editor Describe Function Call" not supply a height to + WITH-POP-UP-DISPLAY. + +/usr1/mbb/lisp/work/spellcoms.lisp, 16-Jun-89 17:47:30, Edit by Mbb. + Added a height specification to the WITH-POP-UP-DISPLAY call in + GET-WORD-CORRECTION so the stream would be line-buffered, and thus visible. + +/usr1/mbb/lisp/work/macros.lisp, 16-Jun-89 17:27:38, Edit by Mbb. +/usr1/mbb/lisp/work/pop-up-stream.lisp, 16-Jun-89 17:27:08, Edit by Mbb. + Added FORCE-OUTPUT and FINISH-OUTPUT functionality to Random Typeout + Streams. + +/usr1/mbb/lisp/work/morecoms.lisp, 16-Jun-89 17:24:15, Edit by Mbb. + Made "Point to here" issue the traditional "I'm afraid I can't let you do + that Dave." message when the usere tries to make the special Random + Typeout window current. + +/usr1/lisp/hemlock/diredcoms.lisp, 16-Jun-89 01:20:44, Edit by Chiles. + Fixed "Copy File" and "Rename File" to no longer think they run in dired + buffers. + +/usr1/lisp/hemlock/bindings.lisp, 16-Jun-89 01:07:54, Edit by Chiles. + Added binding for "Select Random Typeout Buffer". + +/usr1/lisp/hemlock/bindings.lisp, 15-Jun-89 16:59:15, Edit by Chiles. + Defined #\K to be a :keep logical character. + +/usr1/lisp/hemlock/echo.lisp, 15-Jun-89 16:43:16, Edit by Chiles. + Added definition for "Keep" logical character. + +/usr1/lisp/nhem/mh.lisp, 15-Jun-89 13:14:00, Edit by Chiles. + Modified INCORPORATE-NEW-MAIL to better detect mistyped passwords with new MH + error messages. + +/usr/lisp/hemlock/lisp-lib.lisp, 12-Jun-89 14:55:16, Edit by Mbb. + Made "Lisp Library Help" consistent with "Bufed" and other modes that now + use the mode-description mechanism. + +/usr/lisp/hemlock/window.lisp, 07-Jun-89 16:56:02, Edit by Mbb. + Fixed a bug in WINDOW-FOR-HUNK that prevented anyone from making a window + 1 character high. + +/usr/lisp/hemlock/pop-up-stream.lisp, 07-Jun-89 19:10:17, Edit by Mbb. + This file replaces tty-stream.lisp and bit-stream.lisp and does essentially + the same thing, but in a completely different way. + +/usr/lisp/hemlock/display.lisp, 07-Jun-89 18:32:56, Edit by Mbb. + Added two slots to the device structure: random-typeout-full-more and + random-typeout-line-more. These are called from the random typeout + stream output methods to give users a neat scrolling effect on a bitmap, and + on the tty they just clear the window and draw some more lines from the top. + +/usr/lisp/hemlock/display.lisp, 07-Jun-89 18:32:56, Edit by Mbb. + Made %PRINT-DEVICE-HUNK not choke when the hunk has no associated window. + +/usr/lisp/hemlock/mh.lisp, 07-Jun-89 18:30:05, Edit by Mbb. + Made the NEW-MAIL-BUF-DELETE-HOOK ignore buffer so the compiler doesn't + warn that it was "bound but not referenced". + +/usr/lisp/hemlock/bit-screen.lisp, 07-Jun-89 14:52:45, Edit by Mbb. + Made BITMAP-RANDOM-TYPEOUT-SETUP create a psuedo-window to display a random + typeout buffer. Also made BITMAP-RANDOM-TYPEOUT-CLEANUP do the right + thing. Two functions were added to deal with the pseudo-window: + MAKE-TTY-RANDOM-TYPEOUT-WINDOW and CHANGE-TTY-RANDOM-TYPEOUT-WINDOW. + +/usr/lisp/hemlock/tty-screen.lisp, 07-Jun-89 14:26:48, Edit by Mbb. + Made TTY-RANDOM-TYPEOUT-SETUP create a psuedo-window to display a random + typeout-buffer. Also made TTY-RANDOM-TYPEOUT-CLEANUP do the right thing. + Two functions were added to deal with the psuedo-window : + MAKE-BITMAP-RANDOM-TYPEOUT-WINDOW and CHANGE-BITMAP-RANDOM-TYPEOUT-WINDOW. + +/usr/lisp/hemlock/screen.lisp, 07-Jun-89 15:07:50, Edit by Mbb. + Modified PREPARE-FOR-RANDOM-TYPEOUT and RANDOM-TYPEOUT-CLEANUP to + implement the new mechanism. Also added the modeline field definitions + for random typeout buffers. + +/usr1/lisp/nhem/keytran.lisp, 05-Jun-89 12:53:12, Edit by Chiles. + Fixed a bugt in DEFINE-KEYSYM that alwyas ignores shifted characters. + +/usr1/lisp/nhem/rompsite.lisp, 02-Jun-89 11:54:20, Edit by Chiles. + Made FUN-DEFINED-FROM-PATHNAME not string-downcase the file. + +/usr/lisp/hemlock/spellcoms.lisp, 31-May-89 20:46:54, Edit by Mbb. +/usr/lisp/hemlock/searchcoms.lisp, 31-May-89 20:44:59, Edit by Mbb. +/usr/lisp/hemlock/scribe.lisp, 31-May-89 20:44:14, Edit by Mbb. +/usr/lisp/hemlock/register.lisp, 31-May-89 20:42:46, Edit by Mbb. +/usr/lisp/hemlock/morecoms.lisp, 31-May-89 20:41:30, Edit by Mbb. +/usr/lisp/hemlock/mh.lisp, 07-Jun-89 18:30:05, Edit by Mbb. +/usr/lisp/hemlock/lispeval.lisp, 31-May-89 20:36:12, Edit by Mbb. +/usr/lisp/hemlock/lispbuf.lisp, 31-May-89 20:30:34, Edit by Mbb. +/usr/lisp/hemlock/lisp-lib.lisp, 12-Jun-89 14:55:16, Edit by Mbb. +/usr/lisp/hemlock/filecoms.lisp, 31-May-89 20:21:59, Edit by Mbb. +/usr/lisp/hemlock/echocoms.lisp, 31-May-89 20:19:14, Edit by Mbb. +/usr/lisp/hemlock/echo.lisp, 05-Jun-89 15:58:14, Edit by Mbb. +/usr/lisp/hemlock/doccoms.lisp, 31-May-89 20:13:38, Edit by Mbb. +/usr/lisp/hemlock/abbrev.lisp, 31-May-89 19:55:20, Edit by Mbb. + Changed occurences of WITH-RANDOM-TYPEOUT to WITH-POP-UP-DISPLAY. + +/usr1/lisp/nhem/bit-screen.lisp, 31-May-89 21:41:02, Edit by Chiles. + The following functions were modified to accomodate using the extra space at + the bottom of a window when there is no thumb bar: + WRITE-N-EXPOSED-REGIONS + WRITE-ONE-EXPOSED-REGION + HUNK-PROCESS-INPUT + MAYBE-PROMPT-USER-FOR-WINDOW + BITMAP-RANDOM-TYPEOUT-SETUP *** Merge with Blaine. + DEFAULT-CREATE-WINDOW-HOOK + DEFAULT-CREATE-INITIAL-WINDOWS-HOOK + BITMAP-MAKE-WINDOW + SET-HUNK-SIZE + +/usr/lisp/hemlock/macros.lisp, 31-May-89 19:29:21, Edit by Mbb. + Defined the macro WITH-POP-UP-DISPLAY that replaces WITH-RANDOM-TYPEOUT. + The new machanism stuffs output into a real hemlock buffer and a pseudo + window so users can get to it if they need to. + +/usr/lisp/hemlock/rompsite.lisp, 31-May-89 15:35:11, Edit by Mbb. + Rewrote WAIT-FOR-MORE and END-RANDOM-TYPEOUT, and added + MAYBE-KEEP-RANDOM-TYPEOUT-WINDOW, that will finish output and keep the + random typeout window if we're on a bitmap-device. + + Added random-typeout-xevents-mask constant. + + +/usr1/lisp/nhem/hunk-draw.lisp, 31-May-89 14:19:46, Edit by Chiles. + Introduced hunk-thumb-bar-bottom-border, 10, and set hunk-bottom-border to 3. + Modified hunk-draw-bottom-border accordingly. + +/usr1/lisp/nhem/bit-screen.lisp, 31-May-89 10:00:56, Edit by Chiles. + Modified HUNK-PROCESS-INPUT to use extra bits below bottom line and above + thumb bar as part of the bottom line. This should eliminate problems with + mouse scrolling and point-to-here functionality which otherwise would beep + causing the user to move the mouse up a tiny bit. + +/usr1/lisp/nhem/lispbuf.lisp, 26-May-89 14:21:11, Edit by Chiles. + Made "Select Eval Buffer" supply a buffer local delete hook that sets the + special to nil, so Hemlock doesn't hold onto that memory. + +/usr1/lisp/nhem/buffer.lisp, 26-May-89 14:18:50, Edit by Chiles. + Modified MAKE-BUFFER to check the type of the :delete-hook arg. + +/usr1/ch/lisp/complete/table.lisp, 17-Apr-89 18:41:11, Edit by Hoover. + Exported STRING-TABLE-SEPARATOR. + + Fixed a bug in FIND-LONGEST-COMPLETION which made COMPLETE-STRING + think some :COMPLETE completions were :UNIQUE. + + +/usr1/lisp/nhem/mh.lisp, 19-May-89 17:36:03, Edit by Chiles. +/usr1/lisp/nhem/dired.lisp, 19-May-89 17:34:35, Edit by Chiles. + Replaced all %SES-NAMESTRING uses with NAMESTRING. + +/usr1/lisp/nhem/unixcoms.lisp, 17-May-89 11:53:05, Edit by Chiles. + Made SCRIBE-FILE move the buffer's point to the end of the buffer. This + still does not do everything you want: + Queue multiple scribe requests. + Leave a stream around all the time that gets cleaned up when the + buffer is deleted, so it can have a disjoint mark from the buffer's + point. The stream is made whenever the buffer is made. + +/usr1/lisp/nhem/diredcoms.lisp, 15-May-89 17:04:50, Edit by Chiles and MBB. + Added "Dired Information" variable and structure instead of N buffer local + variables. Fixed a couple bugs. Modified "Dired" to correctly handle + file-namestring patterns ... prompts separately with argument. Must prompt + separately because cannot know user's intent and must canonicalize names for + uniqueness when looking up dired buffers. + +/usr1/lisp/nhem/xcoms.lisp, 12-May-89 11:35:24, Edit by Chiles. + Fixed bug in "Stack Window", paren mismatched. + +/usr1/lisp/nhem/struct.lisp, 11-May-89 13:41:38, Edit by Chiles. + Modified font-mark printing to use double quotes instead of ``''. + +/usr1/lisp/nhem/interp.lisp, 11-May-89 13:40:05, Edit by Chiles. + Modified command printing to use double quotes instead of ``''. + +/usr1/lisp/nhem/htext2.lisp, 11-May-89 13:37:22, Edit by Chiles. + Modified line, mark, region, and buffer print functions to use double quotes + instead of Scribe ligatures, ``''. Fixed a bug in mark printing that wrote + its last string to *standard-output* instead of the given stream. + +/usr1/lisp/hemlock/mh.lisp, 05-May-89 17:01:39, Edit by DBM. + Wrote "Message Help", "Headers Help", and "Draft Help". + +/usr1/lisp/hemlock/bindings.lisp, 05-May-89 17:03:56, Edit by Chiles. + Added bindings for "Message Help", "Headers Help", and "Draft Help". + +/usr1/lisp/nhem/dired.lisp, 02-May-89 14:20:43, Edit by Chiles. + Fixed a bug in RENAME-FILE not handling a pattern and directory spec + combination correctly. + +/usr1/lisp/nhem/mh.lisp, 26-Apr-89 14:48:45, Edit by Chiles. + Modified doc strings to work better with "Describe Mode". + +/usr1/lisp/nhem/echo.lisp, 25-Apr-89 15:21:21, Edit by Chiles. + Modified PROMPT-FOR-VAR to call CURRENT-VARIABLE-TABLES. Modified + PROMPT-FOR-FILE to look for the typein in the default directory before + merging with the defaults and taking that potentially non-existent file. + Re-order a bunch of stuff and cleaned up page titles. + +/usr1/lisp/nhem/bindings.lisp, 25-Apr-89 13:18:42, Edit by Chiles. + Removed binding (bind-key "Do Nothing" #\super-leftup :mode "Bufed"). + +/usr1/lisp/nhem/bindings.lisp, 24-Apr-89 15:44:17, Edit by Chiles. + Added "View" mode bindings similar to "Message" mode bindings. + +/usr1/lisp/nhem/morecoms.lisp, 24-Apr-89 14:46:36, Edit by Chiles. + Modified "Generic Pointer Up" and "Point to Here". + +/usr1/lisp/nhem/bufed.lisp, 24-Apr-89 14:41:51, Edit by Chiles. + Modified "Bufed Goto and Quit". + +/usr1/lisp/nhem/interp.lisp, 24-Apr-89 14:09:41, Edit by Chiles. + Modified BIND-KEY to provide a restart before signalling an non-existent + command error. + +/usr1/lisp/nhem/searchcoms.lisp, 20-Apr-89 18:35:53, Edit by Chiles. + Rewrote QUERY-REPLACE-FUNCTION, modifying REPLACE-THAT-CASE and creating + QUERY-REPLACE-LOOP, to clean things up. Fixed bug in return values that + broke "Group Query Replace". + +/usr1/lisp/nhem/spellcoms.lisp, 19-Apr-89 14:40:36, Edit by Chiles. + Modified CORRECT-BUFFER-WORD-END to return values other than nil when end and + start were only one character apart. + +/usr1/lisp/hemlock/diredcoms.lisp, 18-Apr-89 14:23:38, Edit by Chiles. + Modified ARRAY-ELEMENT-FROM-MARK to no longer move the mark argument + since it can correctly count the number of lines in the region anyway. + +/usr1/lisp/nhem/diredcoms.lisp, 18-Apr-89 11:11:21, Edit by Chiles. + Rewrote "View Return" and "View Quit" since they didn't interact correctly. + +/usr1/lisp/nhem/xcoms.lisp, 17-Apr-89 15:48:58, Edit by Chiles. + Fixed bug in "Stack Window". It now signals an editor-error unless the + device is a hi::bitmap-device. This command probably should be deleted since + it is somewhat silly and written only for one person. + +/usr1/lisp/nhem/filecoms.lisp, 12-Apr-89 15:19:52, Edit by Chiles. + Made "Revert File" keep buffer's pathname when reverting to checkpoint file. + +/usr1/lisp/nhem/bindings.lisp, 12-Apr-89 14:48:52, Edit by Chiles. + Added binding for "Select Scribe Warnings". + + Deleted bindings of "Goto Dired Buffer" and "Goto Dired Buffer Quitting". + Added "View" mode bindings for "View Return" and "View Quit". + + +/usr1/lisp/nhem/struct.lisp, 12-Apr-89 14:14:12, Edit by Chiles. + Exported and provided a doc string for BUFFER-DELETE-HOOK. + +/usr1/mbb/lisp/nhem/searchcoms.lisp, 11-Apr-89 13:44:13, Edit by Blaine. + Made "Query Replace" and "Replace String" echo how many occurrences are + replaced. + +/usr1/mbb/lisp/nhem/searchcoms.lisp, 11-Apr-89 13:44:13, Edit by Blaine. + Made the doc-strings for "List Matching Lines", "Delete Matcing Lines", + "Delete Non-matching Lines", "Count Occurrences", "Replace String", and + "Query Replace" indicate that they are sensitive to the active-region. + +/usr1/mbb/lisp/nhem/scribe.lisp, 10-Apr-89 22:30:25, Edit by Blaine. + Wrote the "Select Scribe Warnings", which goes to the buffer named "Scribe + Warnings" if it exists. + +/usr1/mbb/lisp/nhem/lisp-lib.lisp, 10-Apr-89 21:39:51, Edit by Blaine. + Made "Describe Library Entry" and "Desribe Pointer Library Entry" put the + user in view mode instead of normal editing mode. Also added the command + ARRAY-ELEMENT-FROM-POINTER-Y-POS which returns an array element whose index + is determined by the y position, in lines, of the pointer. + +/usr1/mbb/lisp/nhem/bufed.lisp, 10-Apr-89 21:29:20, Edit by Blaine. + Fixed a few bugs in Bufed. Made "Bufed Undelete" replace #\D with #\space. + Made "Bufed Goto and Quit" use the pointer location instead of the + current-point. Also made bufed not move the current-point. + +/usr1/mbb/lisp/nhem/diredcoms.lisp, 11-Apr-89 13:22:44, Edit by Blaine. + Fixed bug in UPDATE-DIRED-BUFFER. I was setting "Dired Buffer Files" inside + of a dotimes when it should have been outside. + + Deleted commands "Goto Dired Buffer" and "Goto Dired Buffer Quitting" in lieu + of "View REturn" and "View Quit". + + Wrote "Dired from Buffer Pathname". + + +/usr1/lisp/nhem/mh.lisp, 10-Apr-89 10:20:42, Edit by Chiles. + Modified SUB-WRITE-MH-SEQUENCE to bind *print-base* to 10 when writing + message ID's. + +/usr1/ch/lisp/spell/spell-build.lisp, 08-Apr-89 16:55:52, Edit by Hoover. + Increased max-entry-count-estimate to 15600 in order to build the new + dictionary. Updated filenames in comments and added a line specifying + compilation dependencies. + + Picked up the latest ispell dictionary and merged in local favorites. + This dictionary is available via anonymous ftp from celray.cs.yale.edu + (128.36.0.25) and locally as /../m/usr/misc/.ispell/src/dict.191. + +/usr1/lisp/nhem/lispmode.lisp, 07-Apr-89 16:25:51, Edit by Chiles. + Added DEFINDENT for WITH-WRITABLE-BUFFER. + +/usr1/lisp/nhem/diredcoms.lisp, 07-Apr-89 16:22:05, Edit by Chiles. + Modifed INITIALIZE-DIRED-BUFFER and "Dired" to beep and blow off the dired + when no entries satisfy the spec. + +/usr1/lisp/nhem/echocoms.lisp, 07-Apr-89 10:49:09, Edit by Chiles. + Added "ps" to "Ignore File Types". + +/usr1/lisp/nhem/mh.lisp, 04-Apr-89 00:16:54, Edit by Chiles. + Wrote GET-STORABLE-MSG-BUF-NAME and used it inside SHOW-HEADERS-MESSAGE and + SHOW-MESSAGE-OFFSET-MSG-BUF. + + Removed variable "Deliver Message Deleting Buffers". I modified + DELIVER-DRAFT-BUFFER-MESSAGE to ignore it. This now also always deletes the + draft buffer, regardless of whether this variable is re-installed. Now the + message buffer is always deleted unless it is kept. "Delete Draft and + Buffer" now also always deletes the message buffer unless it is kept. IF the + variable is re-installed this deletion will be guarded by it as well. + + +/usr1/lisp/nhem/bindings.lisp, 03-Apr-89 12:21:51, Edit by Chiles. + Changed binding of "Define Keyboard Macro Key" to C-x M-(. + +/usr1/lisp/nhem/bindings.lisp, 02-Apr-89 16:44:54, Edit by Chiles. + Fixed mail bindings that got switched up or something, "Next Message", "Next + Undeleted Message", "Previous Message", "Previous Undeleted Message". + +/usr1/lisp/nhem/bindings.lisp, 01-Apr-89 16:38:10, Edit by Chiles. + Bound "Bufed" to C-x C-M-b, and changed some c-'s to control-'s. + +/usr1/lisp/nhem/morecoms.lisp, 31-Mar-89 18:24:30, Edit by Chiles. + Wrote "Generic Pointer Up" to replace "Push Mark/Point to Here" and added + ADD-GENERIC-POINTER-UP-FUNCTION. Modified "Point to Here" in accordance. + +/usr1/lisp/nhem/bufed.lisp, 31-Mar-89 18:34:40, Edit by Chiles. + Fixed "Bufed Goto and Quit". Modified "Bufed" to move point to the beginning + of the buffer. + +/usr1/lisp/nhem/bindings.lisp, 31-Mar-89 18:27:02, Edit by Chiles. + Changed bindings of "Push Mark/Point to Here" to "Generic Pointer Up". + +/usr1/lisp/nhem/mh.lisp, 31-Mar-89 13:40:46, Edit by Chiles. + Fixed a bug in SETUP-REMAIL-DRAFT-BUFFER recently introduced by tweaking + cleanup hooks. THis now makes a dummy "Draft Information" variable. + +/usr1/lisp/nhem/macros.lisp, 29-Mar-89 22:19:57, Edit by Chiles. + Changed error handler to take r and R for restarts instead of P. + +/usr1/lisp/nhem/dired.lisp, 29-Mar-89 21:41:04, Edit by Chiles. + Renamed MAKEDIR to MAKE-DIRECTORY. + +/usr1/lisp/nhem/diredcoms.lisp, 29-Mar-89 17:04:51, Edit by Chiles. + Modified some doc strings and rewrote "Dired Help" to use "Describe Mode". + +/usr1/lisp/nhem/bufed.lisp, 29-Mar-89 16:53:06, Edit by Chiles. + Fixed some documentation and rewrote "Bufed Help" to use "Describe Mode". + +/usr1/lisp/nhem/bindings.lisp, 29-Mar-89 16:45:08, Edit by Chiles. + Added binding for "Bufed Help". + +/usr1/lisp/nhem/bufed.lisp, 29-Mar-89 16:36:53, Edit by Chiles. + Added documentation to mode "Bufed". + +/usr1/lisp/nhem/doccoms.lisp, 29-Mar-89 15:52:11, Edit by Chiles. + Wrote "Describe Mode" and hooked it into "Help". + +/usr1/lisp/nhem/buffer.lisp, 29-Mar-89 11:24:19, Edit by Chiles. + Wrote MODE-DOCUMENTATION and exported it. + +/usr1/lisp/nhem/filecoms.lisp, 28-Mar-89 17:24:47, Edit by Chiles. + Removed "Rename File" and "Delete File". + +/usr1/lisp/nhem/dired.lisp, 28-Mar-89 16:42:27, Edit by Chiles. + Removed "[Yes]" from DELETE-FILE-2 + +/usr1/lisp/nhem/diredcoms.lisp, 28-Mar-89 16:03:16, Edit by Chiles. + Moved "Delete File" here and made it consistent with the new "Copy File" and + "Rename File" in that it calls out to the dired package. + +/usr1/lisp/hemlock/bindings.lisp, 28-Mar-89 11:32:03, Edit by DBM. + Names for a couple of bindings were incorrect and have been + fixed. + +/usr1/lisp/nhem/diredcoms.lisp, 28-Mar-89 11:19:50, Edit by Chiles. + Modified "View File" to name buffers better. + +/usr1/lisp/nhem/bindings.lisp, 27-Mar-89 13:01:14, Edit by Chiles. + Forgot a copy and rename dired bindings. + +/usr1/lisp/nhem/mh.lisp, 27-Mar-89 11:46:28, Edit by Chiles. + Fixed :delete-hook arg that was not a list. + +/usr1/lisp/nhem/lispeval.lisp, 25-Mar-89 09:44:46, Edit by Chiles. + Wrote "Editor Server Name". + +/usr1/lisp/nhem/rompsite.lisp, 25-Mar-89 09:37:57, Edit by Chiles. + Modified INIT-EDITOR-SERVER to include process ID in editor server name for + same user, same machine, multiple instance protection. + +/usr1/lisp/nhem/lispbuf.lisp, 24-Mar-89 23:19:56, Edit by Chiles. +/usr1/lisp/nhem/lispbuf.lisp, 24-Mar-89 23:12:48, Edit by Chiles. + "Reenter Interactive Input" must copy the region when it is active since + moving the point changed the input region. There also was a bug that it + checked for the value of buffer-input-mark, but this has no global binding. + It now checks for a binding instead of a non-nil value. + +/usr1/lisp/nhem/spellcoms.lisp, 24-Mar-89 21:44:36, Edit by Chiles. + Made CORRECT-BUFFER-SPELLING and SPELL-PREVIOUS-WORD always ignore trailing + apostrophe s's on words. + +/usr1/lisp/nhem/bindings.lisp, 23-Mar-89 20:51:16, Edit by Chiles. + Added Bufed bindings. + +/usr1/lisp/nhem/bufed.lisp, 23-Mar-89 20:52:48, Edit by Chiles. + New file. + +/usr1/lisp/nhem/ts.lisp, 22-Mar-89 17:04:44, Edit by Chiles. +/usr1/lisp/nhem/srccom.lisp, 22-Mar-89 17:04:02, Edit by Chiles. +/usr1/lisp/nhem/spellcoms.lisp, 22-Mar-89 17:03:17, Edit by Chiles. +/usr1/lisp/nhem/register.lisp, 22-Mar-89 17:00:37, Edit by Chiles. +/usr1/lisp/nhem/morecoms.lisp, 22-Mar-89 16:59:49, Edit by Chiles. +/usr1/lisp/nhem/mh.lisp, 22-Mar-89 16:59:08, Edit by Chiles. +/usr1/lisp/nhem/lispeval.lisp, 22-Mar-89 16:58:16, Edit by Chiles. +/usr1/lisp/nhem/lisp-lib.lisp, 22-Mar-89 16:57:31, Edit by Chiles. +/usr1/lisp/nhem/killcoms.lisp, 22-Mar-89 15:27:23, Edit by Chiles. +/usr1/lisp/nhem/htext2.lisp, 22-Mar-89 15:24:23, Edit by Chiles. +/usr1/lisp/nhem/hi-integrity.lisp, 22-Mar-89 15:23:12, Edit by Chiles. +/usr1/lisp/nhem/filecoms.lisp, 22-Mar-89 15:22:19, Edit by Chiles. +/usr1/lisp/nhem/edit-defs.lisp, 22-Mar-89 15:21:01, Edit by Chiles. +/usr1/lisp/nhem/echocoms.lisp, 22-Mar-89 14:59:18, Edit by Chiles. +/usr1/lisp/nhem/echo.lisp, 22-Mar-89 14:57:55, Edit by Chiles. +/usr1/lisp/nhem/diredcoms.lisp, 22-Mar-89 14:13:31, Edit by Chiles. +/usr1/lisp/nhem/cursor.lisp, 22-Mar-89 14:11:46, Edit by Chiles. +/usr1/lisp/nhem/command.lisp, 22-Mar-89 14:09:36, Edit by Chiles. +/usr1/lisp/nhem/bit-screen.lisp, 22-Mar-89 14:08:27, Edit by Chiles. + Replaced idioms with BUFFER-START-MARK and BUFFER-END-MARK. + +/usr1/lisp/nhem/buffer.lisp, 22-Mar-89 14:05:29, Edit by Chiles. + Wrote BUFFER-START-MARK and BUFFER-END-MARK. + +/usr1/lisp/nhem/lisp-lib.lisp, 21-Mar-89 14:32:14, Edit by Chiles. + Modified all Lisp Library commands to signal an editor-error when not in a + library buffer. + +/usr1/lisp/nhem/morecoms.lisp, 21-Mar-89 14:22:02, Edit by Mbb. + Made "Count Occurrences" use the active region when it exists, otherwise + point to end of buffer. "Count Lines Region" became "Count Lines", and + "Count Words Region" became "Count Words". These two use the active region + now too. + +/usr1/lisp/nhem/searchcoms.lisp, 21-Mar-89 14:19:17, Edit by Mbb. + Made QUERY-REPLACE-FUNCTION use the active region if it exists, otherwise + point to end of buffer. Also, "List Matching Lines", "Delete Matching + Lines", and "Delete Non-Matching Lines" handle the active region similarly. + +/usr1/lisp/nhem/spellcoms.lisp, 20-Mar-89 15:17:19, Edit by Chiles. + Made CORRECT-BUFFER-SPELLING and SPELL-PREVIOUS-WORD ignore apostrophes + following words. + +/usr1/lisp/nhem/mh.lisp, 17-Mar-89 11:16:13, Edit by Chiles. + Replaced MODIFYING-MAIL-BUF with WITH-WRITABLE-BUFFER. + +/usr1/lisp/nhem/buffer.lisp, 17-Mar-89 11:07:41, Edit by Chiles. + Wrote WITH-WRITABLE-BUFFER. + +/usr1/lisp/nhem/window.lisp, 16-Mar-89 11:13:41, Edit by Chiles. + Made MAKE-MODELINE-FIELD have a restart that clobbers the existing defintion + of a modeline field name. + +/usr1/lisp/nhem/display.lisp, 14-Mar-89 23:19:27, Edit by Chiles. + Made REDISPLAY-WINDOWS-FROM-MARK invoke *things-to-do-once*. Some commands + were making buffers, using line buffered output streams + (WITH-OUTPUT-TO-MARK), and when redisplaying from the mark. This didn't + allow the chance for the buffer's modeline info object's start fields to get + initialized via UPDATE-MODELINE-FIELDS. + +/usr1/ch/lisp/complete/table.lisp, 14-Mar-89 19:46:09, Edit by Hoover. + Fixed a bogus declaration in COMPUTE-FIELD-POS. + +/usr1/lisp/nhem/echo.lisp, 14-Mar-89 14:07:56, Edit by Chiles. + Wrote BUFFER-VERIFICATION-FUNCTION which now moves the point around for + ambiguous shit. + +/usr1/lisp/nhem/echocoms.lisp, 14-Mar-89 13:22:31, Edit by Chiles. + Made "Complete Keyword" move the point in the echo area to the first + ambiguous field for :keyword completion (when the prefix is ambiguous of + course). + +/usr1/lisp/nhem/filecoms.lisp, 14-Mar-89 11:04:49, Edit by Chiles. + Modified PROCESS-FILE-OPTIONS to LOUD-MESSAGE and abort file options on + parsing errors. It still goes on to try to set a major mode. + +/usr1/lisp/nhem/table.lisp, 13-Mar-89 13:17:32, Edit by Chiles. + Eliminated optional argument to COMPLETE-STRING. Entered code for signalling + an error if the tables did not contain the same separator character, but + commented it out. + +/usr1/lisp/nhem/bindings.lisp, 09-Mar-89 16:19:19, Edit by Chiles. + Added more page titles. Voided some character translations and made up for + the few commands that needed to be duplicated. + +/usr1/lisp/nhem/window.lisp, 07-Mar-89 16:37:18, Edit by Chiles. + Added print function for modeline field info objects. + +/usr1/lisp/nhem/edit-defs.lisp, 07-Mar-89 10:59:30, Edit by Chiles. + Made GO-TO-DEFINITION use name-len instead of calculating it again. + +/usr1/lisp/nhem/mh.lisp, 06-Mar-89 21:37:11, Edit by Chiles. + Now make new mail buffer with delete-hook NEW-MAIL-BUF-DELETE-HOOK. Delete + old CLEANUP-NEW-MAIL-BUF-DELETION. + + Made CLEANUP-HEADERS-BUFFER, CLEANUP-MESSAGE-BUFFER, and CLEANUP-DRAFT-BUFFER + no longer check for their appropriate information structure. Made + MAYBE-MAKE-MH-BUFFER set buffer local deletion hooks for these functions. + + +/usr1/lisp/nhem/buffer.lisp, 06-Mar-89 21:25:54, Edit by Chiles. + MAKE-BUFFER now takes a :delete-hook argument, and DELETE-BUFFER now invokes + these functions. + +/usr1/lisp/nhem/struct.lisp, 06-Mar-89 21:19:05, Edit by Chiles. + Made buffer structure have a local delete hooks list. + +/usr1/lisp/nhem/highlight.lisp, 06-Mar-89 17:54:46, Edit by Chiles. + Made HIGHLIGHT-ACTIVE-REGION no longer do anything on the tty. + +/usr1/lisp/nhem/filecoms.lisp, 03-Mar-89 18:02:19, Edit by Chiles. + Fixed some recently lost functionality in "Create Buffer". + +/usr1/lisp/nhem/dired.lisp, 01-Mar-89 11:07:46, Edit by Chiles. + Modified ARRAY-ELEMENT-FROM-MARK to take an error message. + +/usr1/lisp/nhem/dired.lisp, 27-Feb-89 15:03:49, Edit by Chiles. + DELETE-FILE-AUX no longer outputs deleted file names on standard output. + +/usr1/lisp/nhem/kbdmac.lisp, 23-Feb-89 10:36:37, Edit by Chiles. + Changed "Define Keyboard Macro Key" message. + +/usr1/lisp/hemlock/rompsite.lisp, 07-Mar-89 17:33:05, Edit by DBM. + Modified the Hemlock GC notify functions to conform with the new + format for the messages. + +/usr1/lisp/nhem/dired.lisp, 27-Feb-89 15:03:49, Edit by Chiles. + DELETE-FILE-AUX no longer outputs deleted file names on standard output. + +/usr1/lisp/nhem/kbdmac.lisp, 23-Feb-89 10:36:37, Edit by Chiles. + Changed "Define Keyboard Macro Key" message. + +/usr1/lisp/nhem/complete/bindings.lisp, 22-Feb-89 14:31:11, Edit by Chiles. + Added new keyboard macro bindings. + +/usr1/lisp/nhem/complete/kbdmac.lisp, 22-Feb-89 14:22:01, Edit by Chiles. + Added new command "Define Keyboard Macro Key". + +/usr1/lisp/nhem/complete/scribe.lisp, 21-Feb-89 12:52:19, Edit by Chiles. +/usr1/lisp/nhem/complete/morecoms.lisp, 21-Feb-89 12:50:45, Edit by Chiles. +/usr1/lisp/nhem/complete/doccoms.lisp, 21-Feb-89 12:46:15, Edit by Chiles. +/usr1/lisp/nhem/complete/abbrev.lisp, 21-Feb-89 12:42:26, Edit by Chiles. + Modified MAKE-STRING-TABLE call. + +/usr1/lisp/nhem/complete/echo.lisp, 21-Feb-89 12:37:06, Edit by Chiles. + Modified for new string tables. + +/usr1/lisp/nhem/complete/echocoms.lisp, 21-Feb-89 11:50:59, Edit by Chiles. + Modified stuff for new string tables. + +/usr1/lisp/nhem/complete/struct.lisp, 21-Feb-89 11:43:26, Edit by Chiles. + Added new setf method for string tables. + +/usr1/lisp/nhem/complete/complete.lisp, 21-Feb-89 11:46:04, Edit by Chiles. + New file. + +/usr1/lisp/nhem/complete/macros.lisp, 21-Feb-89 11:45:10, Edit by Chiles. + Added new DO-STRINGS. + +/usr1/lisp/hemlock/dired.lisp, 22-Feb-89 16:36:49, Edit by DBM. + Fixed "Dired Help" string. + +/usr1/lisp/hemlock/mh.lisp, 21-Feb-89 14:25:42, Edit by Chiles. + Added delete-buffer-hook to set *new-mail-buffer* to nil. + +/usr1/lisp/nhem/rompsite.lisp, 20-Feb-89 16:54:11, Edit by Chiles. + Added load for hem:lisp-lib.fasl. + +/usr1/lisp/nhem/lisp-lib.lisp, 20-Feb-89 16:51:19, Edit by Chiles. + This is a new file. + +/usr1/lisp/nhem/bindings.lisp, 20-Feb-89 16:50:13, Edit by Chiles. + Added "Lisp-Lib" bindings. + +/usr1/lisp/nhem/dired.lisp, 15-Feb-89 15:20:25, Edit by Chiles. + This is a new file. + +/usr1/lisp/nhem/bindings.lisp, 15-Feb-89 15:20:03, Edit by Chiles. + Added Dired bindings. + +/usr1/lisp/nhem/rompsite.lisp, 14-Feb-89 18:04:46, Edit by Chiles. + Added load for dired.fasl. + +/usr1/lisp/nhem/srccom.lisp, 14-Feb-89 16:16:11, Edit by Chiles. + Fixed some silly coding. + +/usr1/lisp/nhem/rompsite.lisp, 14-Feb-89 16:06:28, Edit by Chiles. + Removed tty MESSAGE of GC info. + +/usr1/lisp/nhem/scribe.lisp, 14-Feb-89 11:08:53, Edit by Chiles. + Made "Insert Scribe Directive" use the active region for environments. + +/usr1/lisp/nhem/group.lisp, 13-Feb-89 16:19:57, Edit by Chiles. + Put back routine I accidently deleted. + +/usr1/lisp/nhem/struct.lisp, 10-Feb-89 16:45:23, Edit by Chiles. + Deleted export of COPY-MODELINE-FIELD. + +/usr1/ch/lisp/rompsite.lisp, 02-Feb-89 16:49:42, Edit by Christopher Hoover. + Changed font path support to use EXT:CAREFULLY-ADD-FONT-PATHS. Made + Hemlock look first on the local machine and then in AFS for fonts. + +/usr1/lisp/nhem/searchcoms.lisp, 31-Jan-89 11:00:10, Edit by Chiles. + Installed "String Search Ignore Case" and removed "Default Search Kind". + +/usr1/lisp/nhem/rompsite.lisp, 30-Jan-89 15:17:12, Edit by Chiles. + Changed underline font variable values and set up to really use X11 font + paths. + +/usr1/lisp/nhem/bindings.lisp, 27-Jan-89 13:31:13, Edit by Chiles. + Removed "Typescript" mode local binding of "Process Control invoke EXT:ABORT" + to #\hyper-a. + +/usr1/lisp/nhem/macros.lisp, 20-Jan-89 16:11:18, Edit by Chiles. + Fixed bug in LISP-ERROR-ERROR-HANDLER that allowed logical characters in + COMMAND-CASE to throw us into the debugger with a recursive error. + +/usr1/lisp/nhem/doccoms.lisp, 16-Jan-89 19:04:03, Edit by Chiles. + Fixed doc string for "Help" p. + +/usr1/lisp/nhem/macros.lisp, 11-Jan-89 23:03:10, Edit by Chiles. + Deleted export of IGNORE-EDITOR-ERRORS which no longer exists. + +/usr1/lisp/nhem/htext1.lisp, 11-Jan-89 22:54:14, Edit by Chiles. + Exported LINE> and LINES-RELATED. + +/usr1/lisp/nhem/window.lisp, 11-Jan-89 22:45:22, Edit by Chiles. + Removed some bogus exports dirtying the system with "nonexistent" symbols. + +/usr1/lisp/nhem/filecoms.lisp, 11-Jan-89 13:37:41, Edit by Chiles. + Fixed bug in READ-BUFFER-FILE invoking hook on wrong pathname (not probed + one). + +/usr1/lisp/nhem/filecoms.lisp, 10-Jan-89 18:03:38, Edit by Chiles. + Fixed bug in PATHNAME-TO-BUFFER-NAME. + +/usr1/lisp/nhem/lispeval.lisp, 05-Jan-89 17:21:54, Edit by Chiles. + Made "Describe Symbol" use MARK-SYMBOL + +/usr1/lisp/nhem/lispbuf.lisp, 05-Jan-89 17:20:12, Edit by Chiles. + Wrote MARK-SYMBOL and made "Editor Describe Symbol" use it. + +/usr1/lisp/nhem/scribe.lisp, 05-Jan-89 15:55:23, Edit by Chiles. + Made INSERT-SCRIBE-DIRECTIVE use the next word if the mark is immediately + before it, instead of the previous word. Cleaned up the code some and + documented it (oh no!). + +/usr1/lisp/nhem/spellcoms.lisp, 05-Jan-89 15:32:32, Edit by Chiles. + Made SPELL-PREVIOUS-WORD return the next word when the mark is immediately + before the next word, such that the cursor is displayed within that word. + Renamed "Correct Word Spelling" to "Check Word Spelling" and "Check Word + Spelling" to "Auto Check Word Spelling". + +/usr1/lisp/nhem/rompsite.lisp, 03-Jan-89 11:37:50, Edit by Chiles. + Made INVOKE-SCHEDULED-EVENTS bind *time-queue* to nil around invoking event + function. + +/usr1/lisp/nhem/hunk-draw.lisp, 02-Jan-89 15:53:58, Edit by Chiles. + Fixed problem with underline font leaving dots at the end of lines. I was + copying the pixmap onto the screen one pixel short of the appropriate length. + +/usr1/lisp/nhem/lispeval.lisp, 23-Dec-88 15:13:07, Edit by Chiles. + Rewrote "Compile Defun", "Evaluate Defun", and "Re-evaluate Defvar" to + use DEFUN-REGION. + +/usr1/lisp/nhem/lispbuf.lisp, 23-Dec-88 15:04:46, Edit by Chiles. + Wrote DEFUN-REGION and rewrote "Editor Compile Defun", "Editor Evaluate + Defun", and "Editor Re-evaluate Defvar" to use it. + +/usr1/lisp/nhem/lispmode.lisp, 22-Dec-88 23:43:33, Edit by Chiles. + Wrote MARK-TOP-LEVEL-FORM. Rewrote "Mark Defun" and "End of Defun" to use + it. Added doc strings to START-DEFUN-P and INSIDE-DEFUN-P. + +/usr1/lisp/nhem/keytran.lisp, 22-Dec-88 17:39:21, Edit by Chiles. + Fixed a bug in TRANSLATE-MOUSE-CHARACTER that would have tried to set the + :lock bit for a character which our system doesn't support. + +/usr1/lisp/nhem/mh.lisp, 21-Dec-88 14:26:09, Edit by Chiles. + Replaced occurrences of FILL-REGION-COMMAND-AUX with + FILL-REGION-BY-PARAGRAHPS. + +/usr1/lisp/nhem/fill.lisp, 21-Dec-88 13:59:36, Edit by Chiles. + Renamed FILL-REGION-COMMAND-AUX to FILL-REGION-BY-PARAGRAHPS. Made some + arguments optional. + +/usr1/lisp/nhem/morecoms.lisp, 20-Dec-88 17:31:29, Edit by Chiles. + Modified PAGE-DIRECTORY to clean it up and made it pull control-l's off the + line strings if it occurred as the first characters. + +/usr1/lisp/nhem/window.lisp, 19-Dec-88 13:52:23, Edit by Chiles. + Modified WINDOW-CHANGED to update the modeline's dis-line length. + +/usr1/lisp/nhem/unixcoms.lisp, 17-Dec-88 10:53:54, Edit by Chiles. +/usr1/lisp/nhem/mh.lisp, 17-Dec-88 10:53:13, Edit by Chiles. +/usr1/lisp/nhem/lispeval.lisp, 17-Dec-88 10:52:09, Edit by Chiles. +/usr1/lisp/nhem/lispbuf.lisp, 17-Dec-88 10:51:08, Edit by Chiles. + Changed instances of WRITE-DA-FILE to WRITE-BUFFER-FILE. + +/usr1/lisp/nhem/killcoms.lisp, 14-Dec-88 23:32:02, Edit by Chiles. + Fixed a bug in the KILL-REGION/KILL-CHARACTER interaction code -- needed to + set the *delete-char-region* to nil when the previous command type was a + region kill. + +/usr1/lisp/nhem/echo.lisp, 14-Dec-88 22:40:43, Edit by Chiles. + Modified PROMPT-FOR-BUFFER to disallow input of the empty string when no + default is offered. This now permits defaults to be specified with + :default-string even when :default is nil, but when :must-exist is non-nil, + :default-string must name an existing buffer. + +/usr1/lisp/nhem/filecoms.lisp, 14-Dec-88 22:13:17, Edit by Chiles. + Rewrote "Create Buffer". It now offers a default of "Buffer n". + + Added doc strings for BUFFER-DEFAULT-PATHNAME and PATHNAME-TO-BUFFER-NAME. + Changed what PATHNAME-TO-BUFFER-NAME does. When there is a type but no name, + it inserts *name/type-separator-character* before the type. + + Renamed WRITE-DA-FILE to WRITE-BUFFER-FILE, and READ-DA-FILE to + READ-BUFFER-FILE. Modified FIND-FILE-BUFFER and "Visit File". Hope they're + right. + + "Process File Options" no longer complains about a missing pathname. + PROCESS-FILE-OPTIONS is willing to handle a buffer without an associated + pathname. + + +/usr1/lisp/nhem/echo.lisp, 14-Dec-88 22:05:31, Edit by Chiles. + PROMPT-FOR-BUFFER does not allow the empty string to be supplied anymore. + +/usr1/lisp/nhem/srccom.lisp, 14-Dec-88 21:56:53, Edit by Chiles. + Made the prompt for a destination buffer offer a sticky-default, + "Source Compare Default Destination". + +/usr1/lisp/nhem/mh.lisp, 14-Dec-88 13:19:01, Edit by Chiles. + Updated modeline stuff to use MODELINE-FIELD. + +/usr1/lisp/nhem/main.lisp, 13-Dec-88 13:52:20, Edit by Chiles. + Modified MAKE-MODELINE-FIELD calls. + +/usr1/lisp/nhem/morecoms.lisp, 13-Dec-88 13:50:07, Edit by Chiles. + Updated DO-RECURSIVE-EDIT to use MODELINE-FIELD. + +/usr1/lisp/nhem/struct.lisp, 13-Dec-88 12:47:22, Edit by Chiles. + Renamed modeline-field-name to %name. Defined setf'er. + +/usr1/lisp/nhem/window.lisp, 13-Dec-88 13:40:45, Edit by Chiles. + Modified modeline stuff to make names first class. Renamed some modelien + field objects. Wrote MODELINE-FIELD, MODELINE-FIELD-NAME, and a setf'er. + +/usr1/lisp/nhem/bit-screen.lisp, 13-Dec-88 11:41:32, Edit by Chiles. + Uncommented hook additions for WINDOW-BUFFER and BUFFER-NAME icon naming. + +/usr1/lisp/nhem/rompsite.lisp, 13-Dec-88 11:42:28, Edit by Chiles. + Updated window icon naming for X11. Someone wanted it. + +/usr1/lisp/nhem/killcoms.lisp, 12-Dec-88 12:30:23, Edit by Chiles. + Made PUSH-BUFFER-MARK signal a Lisp error. + +/usr1/lisp/nhem/rompsite.lisp, 10-Dec-88 20:50:06, Edit by Chiles. + Added doc strings for TEXT-CHARACTER and PRINT-PRETTY-CHARACTER. + +/usr1/lisp/nhem/auto-save.lisp, 10-Dec-88 14:26:52, Edit by Chiles. + Added some documentation and removed some bogus "interface" claims as per + Rob's understanding of what "interface" means in a function's comments. + +/usr1/lisp/nhem/macros.lisp, 08-Dec-88 13:49:04, Edit by Chiles. + Modified doc string for EDITOR-ERROR. It also now signals an error if the + editor-error condition goes unhandled. + +/usr1/lisp/nhem/interp.lisp, 08-Dec-88 13:37:02, Edit by Chiles. + Established editor-error condition handler around command invocation. + Editor-error's were being handled by the "internal:" error handler + established in ED since these conditions are a subtype of error. + +/usr1/lisp/nhem/filecoms.lisp, 06-Dec-88 14:29:26, Edit by Chiles. + Wrote DELETE-BUFFER-IF-POSSIBLE. Added doc string for CHANGE-TO-BUFFER. + +/usr1/lisp/nhem/buffer.lisp, 06-Dec-88 13:51:58, Edit by Chiles. + Modified page title and doc string for DELETE-BUFFER. + +/usr1/lisp/nhem/mh.lisp, 06-Dec-88 13:45:19, Edit by Chiles. + Moved DELETE-MH-BUFFER and replaced calls with DELETE-BUFFER-IF-POSSIBLE. + +/usr1/lisp/nhem/xcoms.lisp, 30-Nov-88 17:36:43, Edit by Chiles. + Here it is -- "Stack Window". + +/usr1/lisp/nhem/filecoms.lisp, 30-Nov-88 17:36:19, Edit by Chiles. + Moved "Stack Window". + +/usr1/lisp/nhem/fill.lisp, 29-Nov-88 11:59:51, Edit by Chiles. + Changed occurrences of %MARK-PARAGRAPH to MARK-PARAGRAPH. + +/usr1/lisp/nhem/text.lisp, 29-Nov-88 11:58:01, Edit by Chiles. + Changed %MARK-PARAGRAPH to MARK-PARAGRAPH. + +/usr1/lisp/hemlock/mh.lisp, 28-Nov-88 16:21:44, Edit by DBM. + Modified CLEANUP-HEADERS-REFERENCE to set the message/draft-hdrs-mark to + nil. This is necessary if someone deletes the headers buffer before the + message buffer. + +/usr1/lisp/nhem/macros.lisp, 27-Nov-88 15:59:21, Edit by Chiles. + Rewrote EDITOR-ERROR. Created an editor-error condition with accesses + EDITOR-ERROR-FORMAT-STRING and EDITOR-ERROR-FORMAT-ARGUMENTS. + +/usr1/lisp/nhem/main.lisp, 26-Nov-88 14:56:25, Edit by Chiles. + Deleted bogus export of *current-package*. + +/usr1/lisp/nhem/text.lisp, 26-Nov-88 12:28:30, Edit by Chiles. + Replaced occurrence of %KILL-REGION with KILL-REGION. + +/usr1/lisp/nhem/lispmode.lisp, 26-Nov-88 12:27:12, Edit by Chiles. + Replaced occurrence of %KILL-REGION with KILL-REGION. + +/usr1/lisp/nhem/lispbuf.lisp, 26-Nov-88 12:26:07, Edit by Chiles. + Replaced occurrence of %KILL-REGION with KILL-REGION. + +/usr1/lisp/nhem/echocoms.lisp, 26-Nov-88 12:25:25, Edit by Chiles. + Replaced occurrence of %KILL-REGION with KILL-REGION. + +/usr1/lisp/nhem/morecoms.lisp, 25-Nov-88 20:55:18, Edit by Chiles. + Modified "Delete Previous Character Expanding Tabs" to call KILL-CHARACTERS. + +/usr1/lisp/nhem/command.lisp, 25-Nov-88 21:27:07, Edit by Chiles. + Modified "Delete Next Character" and "Delete Previous Character" to call + KILL-CHARACTERS. + +/usr1/lisp/nhem/killcoms.lisp, 25-Nov-88 21:58:39, Edit by Chiles. + Wrote KILL-CHARACTERS and modified KILL-REGION (used to be %KILL-REGION). + +/usr1/lisp/nhem/icom.lisp, 25-Nov-88 16:04:48, Edit by Chiles. + Removed italicize comments file option. Changed package spec to string. + +/usr1/lisp/nhem/mh.lisp, 22-Nov-88 16:06:53, Edit by Chiles. + Made SHOW-PROMPTED-MESSAGE normalize message ID strings. + +/usr1/lisp/nhem/bit-screen.lisp, 21-Nov-88 16:22:30, Edit by Chiles. + DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE now sets the next hunk trashed since we + are somehow getting exposure events out of order with configure + notifications. We should be able to remove this when facilities fixes the + new software it just released. + +/usr1/lisp/nhem/lispeval.lisp, 18-Nov-88 13:54:01, Edit by Chiles. + Made CREATE-SLAVE correctly get the name of the slave that just connected. + +/usr1/lisp/nhem/rompsite.lisp, 18-Nov-88 13:52:21, Edit by Chiles. + Made EDITOR_CONNECT-HANDLER set the name of the editor that just connected. + +/usr1/lisp/nhem/hunk-draw.lisp, 17-Nov-88 09:08:04, Edit by Chiles. + Made HUNK-REPLACE-LINE-ON-PIXMAP set gcontext :exposures nil. Fixed the + macro it uses to no longer require binding gcontext each time around the + loop. + +/usr1/lisp/nhem/mh.lisp, 15-Nov-88 21:25:50, Edit by Chiles. + Added page of code for message buffer modeline fields. Wrote + MARK-TO-NOTE-REPLIED-MSG. Created "Default Message Modeline Fields". + Modified DELETE-MESSAGE and UNDELETE-MESSAGE. Modified MAYBE-MAKE-MH-BUFFER. + Modified "Deliver Message" and wrote DELIVER-DRAFT-BUFFER-MESSAGE. + +/usr1/lisp/nhem/struct.lisp, 16-Nov-88 13:25:17, Edit by Chiles. + Export MODELINE-FIELD-NAME instead ML-FIELD-NAME. + +/usr1/lisp/nhem/rompsite.lisp, 16-Nov-88 13:32:48, Edit by Chiles. + Wrote EDITOR-DESCRIBE-FUNCTION. + +/usr1/lisp/nhem/lispbuf.lisp, 16-Nov-88 13:39:41, Edit by Chiles. + Wrote FUNCTION-TO-DESCRIBE and modified "Editor Describe Function Call". + +/usr1/lisp/nhem/lispeval.lisp, 16-Nov-88 13:50:14, Edit by Chiles. + Made DESCRIBE-FUNCTION-CALL-AUX use EDITOR-DESCRIBE-FUNCTION and + FUNCTION-TO-DESCRIBE. + +/usr1/lisp/nhem/mh.lisp, 15-Nov-88 20:46:02, Edit by Chiles. + Added message buffer modeline stuff. Modified MAYBE-MAKE-MH-BUFFER for the + creation of the message buffer. Modified DELETE-MESSAGE + + Maybe D shouldn't be fixed width? + +/usr1/lisp/nhem/window.lisp, 15-Nov-88 13:34:41, Edit by Chiles. + Modified %SET-MODELINE-FIELD-WIDTH to not allow zero width fields. Modified + MAKE-MODELINE-FIELD to check constraints too. + + Fixed a bug in the :buffer-name modeline-field. + + +/usr1/lisp/nhem/rompsite.lisp, 15-Nov-88 12:30:32, Edit by Chiles. + Replaced "nmmonitor" with "nm_active". + +/usr1/lisp/nhem/display.lisp, 15-Nov-88 12:40:25, Edit by Chiles. + Fixed REDISPLAY-WINDOWS-FOR-MARK to force output and so on. + +/usr1/lisp/hemlock/buffer.lisp, 14-Nov-88 15:14:34, Edit by DBM. + Made SETUP-INITIAL-BUFFER supply :modeline-fields nil. This gets set + when the editor fires up. + +/usr1/lisp/nhem/tty-display.lisp, 10-Nov-88 16:23:04, Edit by Chiles. + Modified occurrences of WINDOW-MODELINE-STRING to be WINDOW-MODELINE-BUFFER. + Made dumb redisplay method set the window's dis-line flags to unaltered. + +/usr1/lisp/nhem/bit-display.lisp, 10-Nov-88 16:20:40, Edit by Chiles. + Modified occurrences of WINDOW-MODELINE-STRING to be WINDOW-MODELINE-BUFFER. + +/usr1/lisp/nhem/main.lisp, 10-Nov-88 16:07:07, Edit by Chiles. + Added "Default Status Line Fields" along with DEFVAR's and PROCLAIM's for + recursive edit and completion mode fields. + + Modified "Default Modeline Fields". + +/usr1/lisp/nhem/bit-screen.lisp, 10-Nov-88 13:11:49, Edit by Chiles. + Modified BITMAP-MAKE-WINDOW to take modelinep. Modified + DEFAULT-CREATE-INITIAL-WINDOWS-ECHO to supply :modelinep t to MAKE-WINDOW. + Modified SET-HUNK-SIZE to determine if the window displays modelines by + checking WINDOW-MODELINE-BUFFER. + +/usr1/lisp/nhem/screen.lisp, 10-Nov-88 13:02:34, Edit by Chiles. + MAKE-WINDOW now takes a :modelinep argument. + + Added sets for echo and main BUFFER-MODELINE-FIELDS. + +/usr1/lisp/nhem/mh.lisp, 09-Nov-88 11:43:45, Edit by Chiles. + Modified a few MAKE-BUFFER calls. The modeline fields for mail buffer should + be redesigned when this stuff goes into the core. + +/usr1/lisp/nhem/lispeval.lisp, 09-Nov-88 11:38:19, Edit by Chiles. + Modified MAKE-BUFFER call. Made "Set Buffer Package" do over buffer's + windows calling UPDATE-MODELINE-FIELD on :package. + +/usr1/lisp/nhem/echo.lisp, 09-Nov-88 11:31:34, Edit by Chiles. + Modified MAKE-BUFFER call. + +/usr1/lisp/nhem/tty-screen.lisp, 09-Nov-88 11:02:14, Edit by Chiles. + Made main-lines be one less for status line. Made echo :text-position be one + less for status line. Modified calls to SETUP-MODELINE-IMAGE. + + Made TTY-MAKE-WINDOW refer to modelinep argument and modified its + SETUP-MODELINE-IMAGE call. + +/usr1/lisp/nhem/struct.lisp, 08-Nov-88 21:52:14, Edit by Chiles. + Added modeline-fields slot to buffer structure. + + Deleted window structure slots: main-pane, text-pane, modeline-pane, + font-map, modeline-line, and modeline-width. Added modeline-buffer and + modeline-buffer-len slots. + + Added DEFSETF for BUFFER-MODELINE-FIELDS. + + Added modeline-field and modeline-field-info structures. + + +/usr1/lisp/nhem/buffer.lisp, 05-Nov-88 17:30:52, Edit by Chiles. + Added page titles. + + Modified MAKE-BUFFER to initialize the %modeline-fields slot with a list of + ml-field-info objects. Now it takes keyword arguments. Modified call in + SETUP-INITIAL-BUFFER. + + Wrote BUFFER-MODELINE-FIELDS, %SET-BUFFER-MODELINE-FIELDS, and + SUB-SET-BUFFER-MODELINE-FIELDS, BUFFER-MODELINE-FIELD-P. + +/usr1/lisp/nhem/bit-display.lisp, 27-Oct-88 21:09:46, Edit by Chiles. + Removed calls to UPDATE-MODELINE-IMAGE. + +/usr1/lisp/nhem/winimage.lisp, 27-Oct-88 20:51:21, Edit by Chiles. + Deleted UPDATE-MODELINE-IMAGE. + +/usr1/lisp/nhem/display.lisp, 30-Oct-88 19:47:04, Edit by Chiles. + Stopped REDISPLAY-WINDOW and REDISPLAY-WINDOW-ALL from forcing output and + calling the after methods. This was causing INTERNAL-REDISPLAY to queue + input events for the editor that weren't seen before going into SYSTEM:SERVER + with a non-zero timeout. This means SYSTEM:SERVER had to timeout, or another + character had to be entered, before the unseen one was revealed. + +/usr1/lisp/nhem/display.lisp, 27-Oct-88 15:10:58, Edit by Chiles. + Wrote INTERNAL-REDISPLAY and made REDISPLAY-LOOP optionally splice in calling + the device's after-redisplay function. + +/usr1/lisp/nhem/rompsite.lisp, 27-Oct-88 15:12:02, Edit by Chiles. + Replaced calls to REDISPLAY with INTERNAL-REDISPLAY. + +/usr1/lisp/nhem/morecoms.lisp, 26-Oct-88 15:50:43, Edit by Chiles. + Wrote "Goto Absolute Line". + +/usr1/lisp/nhem/hunk-draw.lisp, 26-Oct-88 15:32:22, Edit by Chiles. + Made HUNK-REPLACE-LINE dispatch on *hack-hunk-replace-line*. + +/usr1/lisp/nhem/display.lisp, 26-Oct-88 15:15:47, Edit by Chiles. + Added an after-redisplay slot to the basic display structure. Made + REDISPLAY-LOOP, REDISPLAY-WINDOWS-FROM-MARK, REDISPLAY-WINDOW, and + REDISPLAY-WINDOW-ALL use this. + +/usr1/lisp/nhem/bit-screen.lisp, 26-Oct-88 15:03:05, Edit by Chiles. + MAKE-DEFAULT-BITMAP-DEVICE now sets the :after-redisplay slot. + REVERSE-VIDEO-HOOK-FUN now sets *hack-hunk-replace-line*. + +/usr1/lisp/hemlock/macros.lisp, 25-Oct-88 15:14:49, Edit by DBM. + Fixed the restart case in lisp-error-error-handler. + +/usr1/lisp/nhem/hunk-draw.lisp, 23-Oct-88 18:12:12, Edit by Chiles. + Fixed pixmap creation to be root depth instead of 1, so color stuff works. + When inverting areas, now use boole-xor instead of boole-c2 and a foreground + that is the xor of the foreground and background. This makes color inversion + work. If A is the foreground, and B is the background, then A xor B is AxB. + This value has the property that A xor AxB is B, and B xor AxB is A, thus + inverting in color the region. + +/usr1/lisp/nhem/bit-screen.lisp, 23-Oct-88 16:26:43, Edit by Chiles. + Modified BITMAP-MAKE-WINDOW to make the gcontext after we definitely have a + window. Made sure that where I destroy an xwindow, that I free the gcontext + for that hunk. Added a DEFVAR for *foreground-background-xor*, which is + initialized in INIT-BITMAP-SCREEN-MANAGER. This function also has corrected + calls to GET-HEMLOCK-GREY-PIXMAP and GET-HEMLOCK-CURSOR. Made + REVERSE-VIDEO-HOOK-FUN deal with rthunk correctly for new strategy, and it + calls GET-HEMLOCK-CURSOR now. + +/usr1/lisp/nhem/rompsite.lisp, 23-Oct-88 14:17:19, Edit by Chiles. + Modified FLASH-WINDOW-BORDER and FLASH-WINDOW to use an xor function and a + pixel value that is the xor of foreground and background. This allows + inversion in a color window, that is for any pixel values including 1 and 0. + Changed the cursor fetching code to no longer save the pixmaps hot spots. + These are now generated each time you fetch a new Hemlock cursor, and this + code now uses distinct graphics contexts for each pixmap (cursor and mask) to + accomodate the color monitor. This also seemed more correct in general. The + grey pixmap generation has been changed to not use XLIB:PUT-RAW-IMAGE since + this required Hemlock to know every server/monitor's preferences for raw + data. Fixed pixmap creation to be the root depth instead of 1 when not + making cursors. + +/usr1/lisp/nhem/hunk-draw.lisp, 22-Oct-88 20:06:02, Edit by Chiles. + Made HUNK-REPLACE-LINE-PIXMAP call XLIB:CREATE-PIXMAP with a depth of + XLIB:SCREEN-ROOT-DEPTH instead of 1. + +/usr1/lisp/nhem/buffer.lisp, 22-Oct-88 16:09:32, Edit by Chiles. + Modified %SET-BUFFER-NAME to do the right thing if the name supplied was + already in use but for the buffer being affected. This allows the buffer to + be renamed to the same name, but with different casing for display effect. + +/usr1/lisp/nhem/filecoms.lisp, 22-Oct-88 16:37:45, Edit by Chiles. + Modified "Rename Buffer" to allow users to rename a buffer to the same + name,but with different casing for visual effect. + +/usr1/lisp/nhem/lispeval.lisp, 21-Oct-88 18:40:11, Edit by Chiles. + Made CREATE-SLAVE not mess with the value of "Current Eval Server". It now + uses a special *create-slave-wait* that is set by the connect handler. + +/usr1/lisp/nhem/rompsite.lisp, 21-Oct-88 18:08:42, Edit by Chiles. + Made EDITOR_CONNECT-HANDLER only affect the :global value of "Current Eval + Server". It also not sets ed::*create-slave-wait* to nil. + +/usr1/lisp/nhem/window.lisp, 21-Oct-88 02:26:40, Edit by Chiles. + Modified %SET-WINDOW-BUFFER to move the window's display start and ends to + the new display-start slot buffers have. + +/usr1/lisp/nhem/buffer.lisp, 21-Oct-88 02:25:07, Edit by Chiles. + Added initialization for :display-start slot of new buffer. + +/usr1/lisp/nhem/struct.lisp, 21-Oct-88 02:23:11, Edit by Chiles. + Added display-start slot to the buffer structure. + +/usr1/lisp/nhem/lispeval.lisp, 20-Oct-88 22:13:53, Edit by Chiles. + MAYBE-QUEUE-OPERATION-REQUEST now informs the user whether the operation is + queued to be sent or being sent. + +/usr1/lisp/nhem/killcoms.lisp, 17-Oct-88 13:34:26, Edit by Chiles. + Made "Set/Pop Mark" only MESSAGE when interactive. + +/usr1/lisp/nhem/filecoms.lisp, 17-Oct-88 12:16:08, Edit by Chiles. + Installed new "Save All Files" that tells how many files it saved. + +/usr1/lisp/nhem/mh.lisp, 14-Oct-88 13:56:45, Edit by Chiles. + Made EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS always set the name back in case the + user used "Pick Headers". Broke off part of it to form + MAYBE-GET-NEW-MAIL-MSG-HDRS which is now also called in PICK-MESSAGE-HEADERS. + Made "Incorporate and Read New Mail" set the unseen mail buffer's name when + it already existed just in case someone used "Pick Headers". + PICK-MESSAGE-HEADERS now checks for the new mail buffer, and when the pick + expression is empty, it uses MAYBE-GET-NEW-MAIL-MSG-HDRS. + +/usr1/lisp/nhem/mh.lisp, 13-Oct-88 11:31:13, Edit by Chiles. + PROMPT-FOR-FOLDER was not giving must-exist to PROMPT-FOR-KEYWORD. It was + always passing nil. + +/usr1/lisp/nhem/bit-screen.lisp, 12-Oct-88 15:09:10, Edit by Chiles. + Reinstalled the better window deletion next merger code. Commented out the + hack in case we run into another asinine window manager. + +/usr1/lisp/nhem/lispbuf.lisp, 10-Oct-88 14:03:41, Edit by Chiles. + Modified commands that redirected *standard-output* for compiler warnings to + now redirect *error-output* to adhere to new compiler + +/usr1/lisp/nhem/lispbuf.lisp, 09-Oct-88 16:54:18, Edit by Chiles. + Made "Package" file option not choke when it couldn't stringify the thing. + +/usr1/lisp/nhem/bindings.lisp, 05-Oct-88 20:24:21, Edit by Chiles. + Eliminated bogus BIND-KEY in "Eval" mode for "Confirm Eval Input". + +/usr1/lisp/nhem/morecoms.lisp, 04-Oct-88 20:13:34, Edit by Chiles. + Made "Uppercase Region" and "Lowercase Region" insist on the region being + active. Made TWIDDLE-REGION, which implements above, take a region instead + of two marks. + +/usr1/lisp/nhem/htext4.lisp, 04-Oct-88 19:57:55, Edit by Chiles. + Modified FILTER-REGION doc string. Added page titles. + +/usr1/lisp/hemlock/bit-display.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/keytrandefs.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/tty-screen.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/bit-screen.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/font.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/window.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/bit-stream.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/hunk-draw.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/main.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/xcoms.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/charmacs.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/rompsite.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/keytran.lisp, 03-October-88, Edit by Chiles. +/usr1/lisp/hemlock/screen.lisp, 03-October-88, Edit by Chiles. + Modified to support X11 using CLX. + +/usr1/lisp/nhem/scribe.lisp, 30-Sep-88 14:45:41, Edit by Chiles. + Broke up long FORMAT string into several lines of code. Fixed bug in + DIRECTIVE-HELP. + +/usr1/lisp/nhem/filecoms.lisp, 27-Sep-88 11:48:10, Edit by Chiles. + Added a "Make Buffer Hook" to add all new buffers to the history. Added some + doc and a page title. + +/usr1/lisp/nhem/bindings.lisp, 22-Sep-88 22:46:30, Edit by Chiles. + Added binding for "Insert Scribe Directive". Deleted lots of other "Scribe" + bindings. + +/usr1/lisp/nhem/scribe.lisp, 21-Sep-88 22:48:46, Edit by Chiles. + Added new code to dispatch on a character and either insert a Scribe command + or environment, instead of having 30 similar commands. Deleted the following + commands entirely: + "Scribe Appendix" + "Scribe AppendixSection" + "Scribe Chapter" + "Scribe Heading" + "Scribe MajorHeading" + "Scribe Paragraph" + "Scribe PrefaceSection" + "Scribe Section" + "Scribe SubHeading" + "Scribe SubSection" + "Scribe UnNumbered" + "Scribe Verbatim" + "Scribe Verse" + Introduced "List Scribe Paragraph Delimiters". + Cleaned up code. + Got the stuff working. + +/usr1/lisp/nhem/lispmode.lisp, 15-Sep-88 14:31:53, Edit by Chiles. + Modified LISP-INDENT-REGION to do it undoably. It takes an optional argument + for the undo text. "Indent Form" supplies its name when calling this. + Documented INDENT-FOR-LISP. Modified some page boundaries. + +/usr1/lisp/nhem/bindings.lisp, 07-Sep-88 16:44:35, Edit by Chiles. + Changed "Eval Input" bindings to "Confirm Eval Input". + +/usr1/lisp/nhem/lispbuf.lisp, 07-Sep-88 16:43:34, Edit by Chiles. + Renamed "Eval Input" to "Confirm Eval Input". + +/usr1/lisp/nhem/mh.lisp, 07-Sep-88 13:08:04, Edit by Chiles. + Modified DELETE-AND-EXPUNGE-TEMP-DRAFTS one more time. Now it makes use of + MH's :errorp arguement to squelch errors. + +/usr1/lisp/hemlock/lispeval.lisp, 30-Aug-88 11:32:53, Edit by DBM. + Changed references to slave-utility-name to slave-utility and + slave-arguments to slave-utility-switches. + +/usr1/lisp/nhem/ts.lisp, 19-Aug-88 21:47:12, Edit by Chiles. + Fixed "Unwedge Interactive Input String" according to mail I sent. + +/usr1/lisp/nhem/bindings.lisp, 15-Aug-88 12:30:05, Edit by Chiles. + Added binding for "Scribe Buffer File". + +/usr1/lisp/nhem/lispeval.lisp, 15-Aug-88 11:11:10, Edit by Chiles. + Renamed "Slave Utility Name" to "Slave Utility" and + "Slave Arguments" to "Slave Utility Switches". + +/usr1/lisp/nhem/unixcoms.lisp, 15-Aug-88 11:09:48, Edit by Chiles. + Renamed "Print Utility Options" to "Print Utility Switches". Added Scribe + stuff. + +/usr1/lisp/nhem/mh.lisp, 09-Aug-88 23:16:09, Edit by Chiles. + Made "Expunge Messages" and "Quit Headers" doc strings mention "Temporary + Draft Folder". Modified DELETE-AND-EXPUNGE-TEMPORARY-DRAFTS to do a + directory to realize if there were really any messages to blow away. + +/usr1/lisp/nhem/doccoms.lisp, 09-Aug-88 22:57:13, Edit by Chiles. + Modified "Apropos" to use CURRENT-VARIABLE-TABLES, and cleaned up this moby + growing command. + +/usr1/lisp/nhem/echo.lisp, 09-Aug-88 22:26:46, Edit by Chiles. + Wrote CURRENT-VARIABLE-TABLES, and exported it. Modified PROMPT-FOR-VARIABLE + to use it. + +/usr1/lisp/nhem/mh.lisp, 07-Aug-88 04:03:13, Edit by Chiles. + "Remail Message". + +/usr1/lisp/nhem/filecoms.lisp, 04-Aug-88 22:20:23, Edit by Chiles. + Made "Insert File" and "Insert Buffer" push a buffer mark before inserting. + +/usr1/lisp/nhem/lispbuf.lisp, 04-Aug-88 21:31:10, Edit by Chiles. + Fixed default binding and doc string of "Unwedge Interactive Input Confirm". + +/usr1/lisp/nhem/mh.lisp, 30-Jul-88 22:09:59, Edit by Chiles. + Fixed a bug with "Reply to Message Prefix Action". Made "Reply to M in O + Window", when invoked in the headers buffer, put the message in the "current" + window. + +/usr1/lisp/nhem/highlight.lisp, 26-Jul-88 17:26:32, Edit by Chiles. + Did away with HIGHLIGHT-ACTIVE-REGION-P. Replaced calls with + REGION-ACTIVE-P. Made MAYBE-HIGHLIGHT-OPEN-PARENS check the value of + "Highlight Active Region" and REGION-ACTIVE-P instead of just the latter. + +/usr1/lisp/nhem/killcoms.lisp, 26-Jul-88 17:21:36, Edit by Chiles. + Made REGION-ACTIVE-P check for the last command type being a member of + *ephemerally-active-command-types*. Modified "Kill Region" and "Save Region" + to call CURRENT-REGION normally. + +/usr1/lisp/nhem/lispbuf.lisp, 19-Jul-88 22:35:22, Edit by Chiles. + Fixed bug in "Eval Input". + +/usr1/lisp/hemlock/linimage.lisp, 27-Jul-88 11:09:17, Edit by DBM. +/usr1/lisp/hemlock/line.lisp, 27-Jul-88 10:56:33, Edit by DBM. + Removed some old Perq cruft. + +/usr1/lisp/nhem/lispbuf.lisp, 19-Jul-88 22:35:22, Edit by Chiles. + Fixed bug in "Eval Input". + +/usr1/lisp/nhem/filecoms.lisp, 11-Jul-88 12:55:48, Edit by Chiles. + Fixed bug in "Visit File" telling the user that the file is already in some + buffer. + +/usr1/lisp/nhem/doccoms.lisp, 06-Jul-88 23:14:13, Edit by Chiles. + Added "Describe Pointer" command and frobbed "Help". + +/usr1/lisp/nhem/bindings.lisp, 05-Jul-88 16:34:31, Edit by Chiles. + Added bindings for new commands in Commands.Lisp. + + Added initial value for *describe-pointer-keylist*. + +/usr1/lisp/nhem/command.lisp, 05-Jul-88 16:36:40, Edit by Chiles. + Added "Mark to Beginning of Buffer" "Mark to End of Buffer". + +/usr1/lisp/nhem/ts.lisp, 04-Jul-88 15:46:46, Edit by Chiles. + Broke "Process Control" up into separate commands. + +/usr1/lisp/nhem/filecoms.lisp, 01-Jul-88 23:40:00, Edit by Chiles. + made "Visit File" MESSAGE when another buffer also contains the pathname. + +/usr1/lisp/nhem/mh.lisp, 29-Jun-88 23:33:40, Edit by Chiles. + Wrote "Delete Message and Down Line". + + Made "Deliver Message" say "Delivering draft ...". + + Deleted GET-MESSAGE-HEADERS-SEQ. Made SET-MESSAGE-HEADERS-IDS optionally + return an MH sequence. These were identical but for this difference. + + Made "Refile Message" and "Delete Message" maintain consistency. + + Made SHOW-MESSAGE-OFFSET-MARK return nil when it couldn't place the mark + instead of signalling an error. Wrote SHOW-MESSAGE-OFFSET-MSG-BUG, and + renamed SHOW-MESSAGE-OFFSET-HEADERS to SHOW-MESSAGE-OFFSET-HDRS-BUF. In a + message buffer, we move back to the headers buffer and delete the message + buffer. + + Added "Reply to Message Prefix Action" which controls prefix argument actions + in "Reply to Message". + + Removed "Automatic Current Message" feature. + Removed DEFHVAR just after "Headers Information". + Removed when...show from: + "Message Headers" + "Pick Headers" + INSERT-NEW-MAIL-MESSAGE-HEADERS + Modified REVAMP-HEADERS-BUFFER and CLEANUP-HEADERS-BUFFER to always take care + of the main message buffer. + + +/usr1/lisp/nhem/bindings.lisp, 27-Jun-88 13:45:22, Edit by Chiles. + Added bindings for macroexpansion and reenter input stuff. + + Added new bindings for "Process Control" break up. + + +/usr1/lisp/nhem/lispbuf.lisp, 27-Jun-88 13:34:56, Edit by Chiles. + Added "Editor Macroexpand Expression". + + Added "Reenter Interactive Input". + + +/usr1/lisp/nhem/lispeval.lisp, 27-Jun-88 13:33:11, Edit by Chiles. + Added "Macroexpand Expression". + +/usr1/lisp/nhem/bindings.lisp, 26-Jun-88 20:02:02, Edit by Chiles. + Uncommented binding for "Delete Message and Down Line". + +/usr1/lisp/nhem/bindings.lisp, 24-Jun-88 16:11:37, Edit by Chiles. + Fixed C-c bindings messed up by making C-c a hyper prefix. Made all c-, m-, + and s- bindings be spelled out for consistency. + +/usr1/lisp/nhem/mh.lisp, 16-Jun-88 15:02:40, Edit by Chiles. + Made "Delete Draft and Buffer" cleanup after split window drafts. + +/usr1/lisp/nhem/spellcoms.lisp, 16-Jun-88 12:54:08, Edit by Chiles. + Made corrections based on previous corrections undoable and changed message + to say "corrected" instead of "replaced". + +/usr1/lisp/nhem/mh.lisp, 15-Jun-88 20:04:23, Edit by Chiles. + Added MESSAGE's to INCORPORATE-NEW-MAIL. + +/usr1/lisp/nhem/lispeval.lisp, 13-Jun-88 19:28:48, Edit by Chiles. + Made #\c for "Edit Compiler Errors" center the window around the current + error. + +/usr1/lisp/nhem/mh.lisp, 10-Jun-88 16:16:58, Edit by Chiles. + Fixed a bug in "Headers Refile Message". It wasn't supplying + *refile-default-destination* to PROMPT-FOR-FOLDER when in a message buffer. + +/usr1/lisp/nhem/mh.lisp, 10-Jun-88 13:21:55, Edit by Chiles. + Made CLEANUP-HEADERS-REFERENCE, when the info is TYPEP 'draft-info, set the + replied-to folder and msg to nil. + +/usr1/lisp/nhem/lispbuf.lisp, 09-Jun-88 20:17:30, Edit by Chiles. + Fixed bug in warning message for "List Compile Group". + +/usr1/ch/lisp/files.lisp, 06-Jun-88 23:44:01, Edit by Christopher Hoover. + Fixed a bug which caused WRITE-FILE to sometimes lose when given an + "access" value. + +/usr1/ch/lisp/unixcoms.lisp, 03-Jun-88 15:54:46, Edit by Christopher Hoover. + Wrote the command "Unix Filter Region". + +/usr1/ch/lisp/auto-save.lisp, 16-May-88 02:31:07, Edit by Christopher Hoover. + Fixed the code so that "Auto Save Checkpoint Frequency" is always + truncated to an integer to keep (very) bad things from happening. + +/usr1/lisp/nhem/spellcoms.lisp, 01-Jun-88 10:46:45, Edit by Chiles. + Made "Check Word Spelling" show close words regardless of "Correct Unique + Spelling Immediately". + +/usr1/lisp/nhem/bindings.lisp, 31-May-88 15:25:23, Edit by Chiles. + Bound all alpha chars to "Illegal" in "Headers" and "Message" modes. + +/usr1/lisp/nhem/mh.lisp, 25-May-88 11:42:13, Edit by Chiles. + Created "Temporary Draft Folder" variable, wrote + DELETE-AND-EXPUNGE-TEMP-DRAFTS, and modified "Quit Headers"and "Expunge + Messages". + +/usr1/lisp/nhem/edit-defs.lisp, 25-May-88 11:09:51, Edit by Chiles. + Made "Edit Definition" and "Goto Definition" (which has a new name) use + editor Lisp if there is no currently valid slave. + +/usr1/lisp/nhem/lispeval.lisp, 25-May-88 02:39:37, Edit by Chiles. + Made "Describe Function Call" and "Describe Symbol" use the editor Lisp when + the current eval server doesn't exist is invalid. + +/usr1/lisp/nhem/mh.lisp, 24-May-88 14:57:36, Edit by Chiles. + Changed PROMPT-FOR-MESSAGE to take keyword args adding prompt. Changed all + the call sites. Made "Message Headers", "Delete Message", "Undelete + Message", and "Refile Message" supply particular prompt messages. + + Changed "Quit Headers Confirm" to "Expunge Messages Confirm". + +/usr1/lisp/nhem/mh.lisp, 19-May-88 12:14:27, Edit by Chiles. + Wrote BREAKUP-MESSAGE-SPEC and added the variable, "Unseen Headers Message + Spec". This affected "Incorporate and Show New Mail" and "Expunge Message". + +/usr1/lisp/nhem/mh.lisp, 15-May-88 15:40:24, Edit by Chiles. + Made MH-PROFILE-COMPONENT take an optional error-on-open argument, so when + this is used for sequence files, and the sequence file is not there or + readable, then the command can continue ... assuming the sequence file + operation is insignificant if the file cannot be opened. Made + MH-SEQUENCE-LIST use this argument. + + Made MARK-ONE-MESSAGE not write the file on :delete unless the message was + really in the sequence before deletion. + +/usr1/lisp/nhem/lispmode.lisp, 12-May-88 15:11:15, Edit by Chiles. + Added mailer and xlib DEFINDENT forms. + +/usr1/lisp/nhem/mh.lisp, 12-May-88 10:45:02, Edit by Chiles. + Fixed documentation for "Reply to Message in Other Window". + +/usr1/lisp/nhem/mh.lisp, 11-May-88 14:03:29, Edit by Chiles. + Wrote "Edit Message Buffer". Made a bunch of (subseq folder 1) calls be + calls to STRIP-FOLDER-NAME for consistency. + +/usr1/lisp/nhem/mh.lisp, 11-May-88 10:33:23, Edit by Chiles. + Made "Insert Message Region" know about split-window drafts. + +/usr1/lisp/hemlock/edit-defs.lisp, 10-May-88 17:11:28, Edit by Chiles. + Made "Edit Command Definition" on an argument prompt for a key instead of + prompting for a command name. + +/usr1/lisp/nhem/mh.lisp, 10-May-88 12:37:40, Edit by Chiles. + Made DELETE-HEADERS-LINE-REFERENCES delete message buffers if they are + not associated with a draft buffer. If they are, then it cleans up the + reference. + + Wrote "Reply to Message in Other Window" which splits the current window + when replying to a message. Made "Insert Message Buffer" try to delete a + window if the draft is a split-window draft. Made "Deliver Message" + delete a window if there are a couple lieing around and the draft is a + split-window draft. + +/usr1/lisp/nhem/command.lisp, 10-May-88 11:19:21, Edit by Chiles. + Added doc strings to "Exit Hemlock" and "Pause Hemlock". + +/usr1/lisp/nhem/files.lisp, 09-May-88 16:57:39, Edit by Chiles. + Made WRITE-FILE take keywords keep-backup (previously optional) and access. + When access is supplied non-nil, it is used as Unix modes with + MACH:UNIX-CHMOD. + +/usr1/lisp/nhem/doccoms.lisp, 10-May-88 08:27:39, Edit by Chiles. + Made "Describe Command" show bindings. Fixed bindings printing. + +/usr1/lisp/nhem/auto-save.lisp, 09-May-88 17:28:05, Edit by Chiles. + Made WRITE-CHECKPOINT-FILE call WRITE-FILE the new correct way supplying + :access #o600 for read/write by owner only. + +/usr1/lisp/nhem/spellcoms.lisp, 09-May-88 10:09:13, Edit by Chiles. + Made "Set Buffer Spelling Dictionary" hash on the namestring of the true name + instead of what was given. Made it also add the write hook instead of the + "Dictionary" file option. Stopped modifying "Write File Hook" buffer + specifically, using ADD-HOOK now. Made "Dictionary" file option LOUD-MESSAGE + if it couldn't find the dictionary file, blowing the whole thing off. + Changed "Message Buffer Insertion Prefix" to four spaces. + +/usr1/lisp/nhem/mh.lisp, 09-May-88 09:34:43, Edit by Chiles. + Fixed a bug in SETUP-HEADERS-MESSAGE-DRAFT that associated the draft with the + headers buffer which caused CLEANUP-DRAFT-BUFFER to try to delete a nil + headers mark into the headers buffer. + +/usr1/lisp/nhem/mh.lisp, 06-May-88 10:06:23, Edit by Chiles. + Renamed SETUP-MSG-BUF-REPLY-DRAFT to SETUP-MESSAGE-BUFFER-DRAFT, modifying it + to take a message buffer, message info, and a type. The type is one of + :reply, :compose, or :forward. It does the right thing. + +/usr1/lisp/nhem/tty-display.lisp, 05-May-88 17:26:08, Edit by Chiles. + Rewrote CM-OUTPUT-COORDINATE to not use TRUNCATE on floats or LOG. Changed + it from a macro to a function too. Now it builds the characters in a buffer, + using DEVICE-WRITE-STRING to send the chars out. + +/usr1/lisp/nhem/mh.lisp, 03-May-88 14:41:30, Edit by Chiles. + New Hemlock file. Ta dah! + +/usr1/lisp/nhem/bindings.lisp, 03-May-88 14:55:46, Edit by Chiles. + Added new mailer bindings. + +/usr1/lisp/nhem/display.lisp, 18-Apr-88 14:30:41, Edit by Chiles. + Added DEFVAR for *screen-image-trashed* which was lost due to old bitmap code + tossing. + +/usr1/lisp/nhem/window.lisp, 19-Apr-88 12:01:26, Edit by Chiles. + Inserted code from Owindow.Lisp (previously thrown away due to old bitmap + code tossing) that was still necessary for tty redisplay. + +/usr1/lisp/nhem/rompsite.lisp, 18-Apr-88 11:02:05, Edit by Chiles. + Made HEMLOCK-WINDOW test *hemlock-window-mngt* for being non-nil. + + Removed OBITMAP-SHOW-MARK. + + Removed loading old bitmap files from BUILD-HEMLOCK. + +/usr1/lisp/nhem/rompsite.lisp, 06-Apr-88 12:44:22, Edit by Chiles. + Made the editer server name default to "[:]Editor". + +/usr1/lisp/nhem/display.lisp, 04-Apr-88 09:47:08, Edit by Chiles. + Removed some references to old bitmap redisplay in comments. + +/usr1/lisp/nhem/filecoms.lisp, 04-Apr-88 09:09:45, Edit by Chiles. + Changed the default of "Keep Backup Files" and the doc string. + +/usr1/lisp/hemlock/obit-display.lisp, 01-Apr-88 16:27:00, Edit by Chiles +/usr1/lisp/hemlock/obit-screen.lisp, 01-Apr-88 16:27:00, Edit by Chiles +/usr1/lisp/hemlock/ofont.lisp, 01-Apr-88 16:27:00, Edit by Chiles +/usr1/lisp/hemlock/owindow.lisp, 01-Apr-88 16:27:00, Edit by Chiles +/usr1/lisp/hemlock/pane-stream.lisp, 01-Apr-88 16:27:00, Edit by Chiles +/usr1/lisp/hemlock/pane.lisp, 01-Apr-88 16:27:00, Edit by Chiles +/usr1/lisp/hemlock/keyboard_codes.lisp, 01-Apr-88 16:27:00, Edit by Chiles + These files have been removed from the sources. + +/usr1/lisp/nhem/screen.lisp, 01-Apr-88 16:25:47, Edit by Chiles. + Made %INIT-SCREEN-MANAGER not regard CONSOLEP. + +/usr1/lisp/nhem/rompsite.lisp, 01-Apr-88 16:04:09, Edit by Chiles. + Rewrote (that is, mostly blew away a lot of code) GET-EDITOR-TTY-INPUT. Blew + away TRANSLATE-CHAR definition. + + Blew away all console character translation variables. + + Cleaned out console specific code in SETUP-INPUT and RESET-INPUT. + + Blew away use of *editor-console-input*. + + Blew away CONSOLEP. + + +/usr1/lisp/nhem/morecoms.lisp, 30-Mar-88 14:19:12, Edit by Chiles. + Removed unnecessary (null b) check in "List Buffers". + +/usr1/lisp/nhem/undo.lisp, 25-Mar-88 14:33:23, Edit by Chiles. + Massively documented this stuff. + +/usr0/ram/group.lisp, 21-Mar-88 13:58:49, Edit by Ram. + Changed Do-Active-Group to save and restore the Buffer-Point around the code + that hacks on the buffer. This means that group commands no longer trash the + point (which usually left you at the beginning of the buffer). + +/usr1/ch/lisp/echocoms.lisp, 21-Mar-88 13:33:57, Edit by Christopher Hoover. + Frobbed "Ignore File Types" -- deleted unknowns and added a few common + binary formats. + +/usr1/ch/lisp/auto-save.lisp, 16-Mar-88 16:54:00, Edit by Christopher Hoover. + Made the call to write-region in Auto Save supply NIL as the optional + argument for keeping backup files so that the luser does not end up + with .CKP.BAK files. + +/usr1/ch/lisp/files.lisp, 16-Mar-88 15:59:18, Edit by Christopher Hoover. + Made write-region take an optional argument which tells it whether or + not to do ":if-exist :rename" or ":if-exist :rename-and-delete". + If the argument is not supplied, it looks at the hvar "Keep Backup + Files". + +/usr1/ch/lisp/filecoms.lisp, 16-Mar-88 15:20:00, Edit by Christopher Hoover. + Added the hvar "Keep Backup Files". This variable controls whether + write region deletes .BAK files. + +/usr1/ch/lisp/filecoms.lisp, 14-Mar-88 22:14:47, Edit by Christopher Hoover. + Removed "c" and "h" from the file type hook which invokes Pascal mode + since Pascal mode is worse than Fundamental mode for editing C code. + Someday, there will be a real electric C mode. + +/usr1/lisp/nhem/rompsite.lisp, 15-Mar-88 21:00:11, Edit by Chiles. + Wrote RE-INIT-EDITOR-SERVER to be the port death handler instead of + INIT-EDITOR-SERVER. + +/usr1/lisp/nhem/morecoms.lisp, 15-Mar-88 16:25:44, Edit by Chiles. + Installed Naeem's mods to "Delete Previous Character Expanding Tabs" that + saves on the kill ring after some threshold. + +/usr1/lisp/nhem/command.lisp, 15-Mar-88 16:24:09, Edit by Chiles. + Installed Naeem's mods to "Delete Previous Character" and "Delete Next + Character" that saves on the kill ring after some threshold. + +/usr1/ch/lisp/echocoms.lisp, 14-Mar-88 21:50:47, Edit by Christopher Hoover + Deleted the hvar "Help Show Options" since it is not used anywhere. + Added a real doc string for the hvar "Beep on Ambiguity". + + Fixed Complete Keyword for files to use the new whizzy complete-file. + Added the hvar "Ignore File Types" to control which file types to + ignore. + +/usr1/lisp/nhem/morecoms.lisp, 10-Mar-88 20:59:36, Edit by Chiles. + Installed "Defhvar" command. + +/usr1/lisp/nhem/filecoms.lisp, 10-Mar-88 15:48:57, Edit by Chiles. + Modified PROCESS-FILE-OPTIONS to invoke the file type hook when no major mode + had been seen, even though some mode option had been specified. Modified the + "Mode" file option handler to return whether it had seen a major mode. + +/usr1/lisp/nhem/bit-screen.lisp, 08-Mar-88 14:57:10, Edit by Chiles. + Made REVERSE-VIDEO-HOOK-FUN make sure there is an X window for the random + typeout stream before trying to set its background. + +/usr1/lisp/nhem/fill.lisp, 06-Mar-88 21:28:51, Edit by Chiles. + Made %FILLING-SET-NEXT-LINE not call INDENT-NEW-COMMENT-LINE-COMMAND when + there is a fill prefix. + +/usr1/lisp/nhem/bit-display.lisp, 06-Mar-88 14:15:17, Edit by Chiles. + Fixed redisplay bug concerning excessive counting of lines to clear. + Otherwise case now stops counting cleared lines and packages off one clear + operations if we are currently counting. + +/usr1/lisp/nhem/font.lisp, 06-Mar-88 12:46:24, Edit by Chiles. + Made *default-font-family* have a default value so MAKE-WINDOW and things + trying to look at it under tty redisplay don't choke. + +/usr1/lisp/nhem/main.lisp, 02-Mar-88 22:03:26, Edit by Chiles. + Changed EXPORT of after-initializations to AFTER-EDITOR-INITIALIZATIONS which + is really what the macro is called. + +/usr1/lisp/nhem/font.lisp, 02-Mar-88 19:53:10, Edit by Chiles. + Rearranged some functions. Added doc strings for exported stuff. Deleted + hardwired structures. Moved two parameters to Rompsite.Lisp. Added logical + pages. + +/usr1/lisp/nhem/lispbuf.lisp, 02-Mar-88 14:12:30, Edit by Chiles. + Made SETUP-EVAL-MODE make a local binding of "Current Package" to nil. + +/usr1/lisp/nhem/lispeval.lisp, 02-Mar-88 13:42:49, Edit by Chiles. + Modified "Set Buffer Package" to set *package* when in the eval buffer. + +/usr1/lisp/nhem/bit-screen.lisp, 01-Mar-88 16:00:24, Edit by Chiles. + Made HUNK-MOUSE-ENTERED invoke the "Enter Window Hook" and made + HUNK-MOUSE-LEFT invoke the "Exit Window Hook". Fixed REVERSE-VIDEO-HOOK-FUN + to change the background pixmap for a window, so you don't get a flash of + white before Hemlock paints black when the window is exposed. + +/usr1/lisp/nhem/filecoms.lisp, 24-Feb-88 12:26:07, Edit by Chiles. + Changed "Last Resort Pathname Defaults" and "Last Resort Pathname Defaults + Function". + +/usr1/lisp/nhem/rompsite.lisp, 01-Mar-88 15:29:32, Edit by Chiles. + Made SITE-INIT define "Enter Window Hook" and "Exit Window Hook". Wrote + ENTER-WINDOW-AUTORAISE as example hook for losers into autoraising. + + Put in DEFHVAR in SITE-INIT for "Default Font". Modified INIT-RAW-IO, + SETUP-FONT-FAMILY, and OPEN-FONT in conjunction with supporting this new + variable. + +/usr1/chiles/work/temp-hem/rompsite.lisp, 22-Feb-88 21:07:14, Edit by Chiles. + Changed GET-HEMLOCK-CURSOR to not use ".mask" as a pathname, but to use + MAKE-PATHNAME :type "mask" ... instead. + +/usr1/chiles/work/temp-hem/lispeval.lisp, 22-Feb-88 21:01:49, Edit by Chiles. + Changed CLEANUP-COMPILE-NOTIFICATION to not use ".fasl" as a pathname, but to + use MAKE-PATHNAME :type "fasl" ... instead. + +/usr1/lisp/nhem/filecoms.lisp, 22-Feb-88 17:15:35, Edit by Chiles. + Introduced "Last Resort Pathname Defaults" and "Last Resort Pathname Defaults + Function" and modified BUFFER-DEFAULT-PATHNAME. + +/usr1/lisp/nhem/spellcoms.lisp, 22-Feb-88 16:50:33, Edit by Chiles. + Made "Check Word Spelling" output digits with possible correct spellings. + Made "Correct Last Misspelled Word" take 0-9 in the command loop as the + numbered word to use as a correct spelling. + +/usr1/lisp/nhem/morecoms.lisp, 22-Feb-88 13:13:54, Edit by Chiles. + Frobbed control flow in "Goto Page" and made it drop a mark when searching + page titles a first time. + +/usr1/lisp/nhem/auto-save.lisp, 18-Feb-88 17:25:10, Edit by Chiles. + Made "Save" mode turn off automatically in "Typescript" and "Eval" modes. + +/usr1/lisp/nhem/main.lisp, 18-Feb-88 17:11:12, Edit by Chiles. + Put "Save" mode in "Default Modes". + +/usr1/lisp/nhem/indent.lisp, 16-Feb-88 14:41:34, Edit by Chiles. + Fixed bug "Indent" being called with a zero argument. + +/usr1/lisp/nhem/searchcoms.lisp, 16-Feb-88 14:14:32, Edit by Chiles. + Made THE four searching commands only drop a mark if the region is not + active. Also, make i-search ^G invoke the abort-hook. Made incremental + searching commands set the last command type to nil since each letter typed + does not go through the command loop, and ephemerally active regions were + staying highlighted throughout the search. + +/usr1/lisp/nhem/lispmode.lisp, 14-Feb-88 20:34:03, Edit by Chiles. + Added DEFINDENT's for some CLOS stuff. Added one for "frob" for Rob and me. + Added a few for system calls. + +/usr1/lisp/nhem/lispeval.lisp, 11-Feb-88 13:58:31, Edit by Chiles. + Made FILE-COMPILE look at a new variable "Remote File Compile". + +/usr1/lisp/nhem/lispeval.lisp, 10-Feb-88 20:08:04, Edit by Chiles. + Made OLDER-OR-NON-EXISTENT-FASL-P's second argument optional. + +/usr1/lisp/nhem/lispbuf.lisp, 10-Feb-88 20:11:14, Edit by Chiles. + Made "List Compile Group" use OLDER-OR-NON-EXISTENT-FASL-P. + +/usr1/lisp/nhem/highlight.lisp, 10-Feb-88 19:52:50, Edit by Chiles. + Modified HIGHLIGHT-ACTIVE-REGION to not do anything when the window is the + echo area window. + +/usr1/lisp/nhem/killcoms.lisp, 10-Feb-88 15:55:19, Edit by Chiles. + Augmented the active region flag with an active region buffer variable to + circumvent echo area interactions. + +/usr1/lisp/nhem/main.lisp, 10-Feb-88 15:46:29, Edit by Chiles. + Made SAVE-ALL-BUFFERS optionally list unmodified buffers. + +/usr1/lisp/nhem/highlight.lisp, 08-Feb-88 13:49:37, Edit by Chiles. + Implemented highlighting active regions. Renamed a bunch of open paren + highlighting stuff, and frobbed it to interact with region highlighting. + +/usr1/lisp/nhem/killcoms.lisp, 08-Feb-88 13:30:20, Edit by Chiles. + Made CURRENT-REGION take another option to not deactivate the region. + +/usr1/lisp/nhem/rompsite.lisp, 06-Feb-88 16:23:45, Edit by Chiles. + Fixed bug in PRETTY-PRINT-CHARACTER that was created by INSERT-CHARACTER + checking the type of its arguments. + +/usr1/lisp/nhem/lispmode.lisp, 06-Feb-88 16:17:20, Edit by Chiles. + Fixed Scan-Direction-Valid to return NIL when it hits the end of the buffer. + +/usr1/lisp/nhem/killcoms.lisp, 06-Feb-88 10:11:35, Edit by Chiles. + Made "Exchange Point and Mark" no longer activate the region. + +/usr1/lisp/nhem/fill.lisp, 06-Feb-88 09:53:14, Edit by Chiles. + Made "Fill Paragraph" and "Fill Region" use p as the column if supplied. + +/usr1/lisp/nhem/rompsite.lisp, 04-Feb-88 15:33:11, Edit by Chiles. + Fixed the font stuff in initialization to not call TRUENAME on the font + names. This was wrong. Fixed the font stuff to be aware of a font not + opening, signalling an error if it is the default font and warning if it was + the highlighting font. + +/usr1/lisp/nhem/htext3.lisp, 04-Feb-88 16:02:41, Edit by Chiles. + Made INSERT-CHARACTER check the type of its argument. + +/usr1/lisp/nhem/searchcoms.lisp, 04-Feb-88 15:46:24, Edit by Chiles. + Fixed bug in i-search that allowed non-text characters to be searched for. + Also in the C-q case, nil was trying to be inserted into a buffer which + crashed Lisp. + +/usr1/lisp/nhem/command.lisp, 04-Feb-88 14:21:10, Edit by Chiles. + Provided error message for TEXT-CHARACTER nil result in "Self Insert" and + "Quoted Insert" + +/usr1/lisp/nhem/overwrite.lisp, 04-Feb-88 14:17:32, Edit by Chiles. + Protected use of TEXT-CHARACTER, testing for nil result. + +/usr1/lisp/nhem/lispeval.lisp, 03-Feb-88 11:57:33, Edit by Chiles. +/usr1/lisp/nhem/lispbuf.lisp, 03-Feb-88 11:57:33, Edit by Chiles. + Modified "Compile Buffer File", "Editor Compile Buffer File", "Compile + Group", and "Editor Compile Group". Deleted MAYBE-COMPILE-FILE and + MAYBE-COMPILE-EDITOR-FILE. Wrote OLDER-OR-NON-EXISTENT-FASL-P. + +/usr1/lisp/nhem/icom.lisp, 01-Feb-88 16:21:37, Edit by Chiles. + Merged Scott's hack to the comment hack to keep highlighted parens clean. + +/usr1/lisp/nhem/obit-screen.lisp, 01-Feb-88 16:08:35, Edit by Chiles. + Modified OBITMAP-MAKE-WINDOW and OBITMAP-DELETE-WINDOW to invalidate the + currently selected hunk. + +/usr1/lisp/nhem/tty-screen.lisp, 01-Feb-88 15:56:53, Edit by Chiles. + Modified TTY-MAKE-WINDOW and TTY-DELETE-WINDOW to invalidate the currently + selected hunk. + +/usr1/lisp/nhem/spellcoms.lisp, 01-Feb-88 08:28:09, Edit by Chiles. + Fixed MAYBE-READ-DEFAULT-USER-SPELLING-DICTIONARY. + +/usr1/lisp/nhem/bindings.lisp, 28-Jan-88 20:46:09, Edit by Chiles. + Deleted binding for "Compile Buffer File" in "Editor" mode. + +/usr1/lisp/nhem/interp.lisp, 28-Jan-88 11:18:47, Edit by Chiles. + Fixed problem with clearing prefix characters from the echo area when a bad + sequence is typed. + +/usr0/ram/lispmode.lisp, 27-Jan-88 17:21:48, Edit by Ram. + Wrote Find-Ignore-Region and used it to implement Valid-Spot and the new + Scan-Direction-Valid macro, which efficiently scans for a valid character + having the specified properties of its attribute. Used Scan-Direction-Valid + to substantially rewrite %Form-Offset. It now correctly handles character + literals (and as a side-effect, symbols with slashed characters). Also + changed form offset to skip over prefix characters when moving backward over + a list. Users will probably notice this, and hopefully like it. + +/usr0/ram/highlight.lisp, 27-Jan-88 17:15:35, Edit by Ram. + Changed Form-Offset to List-Offset in Maybe-Highlight-Open-Parens. Now that + backward form offset on lists include prefix characters, Form-Offset is no + longer correct. Directly doing List-Offset is slightly more efficient + anyway. + +/usr1/lisp/nhem/highlight.lisp, 27-Jan-88 15:29:50, Edit by Chiles. + Turned "Highlight Open Parens" off by default. + +/usr1/lisp/nhem/lispmode.lisp, 27-Jan-88 15:32:12, Edit by Chiles. + Turned "Paren Pause Period" and "Highlight Open Parens" on in "Lisp" mode. + Set "Paren Pause Period" to 0.5 by default. + +/usr1/lisp/nhem/tty-screen.lisp, 27-Jan-88 15:32:57, Edit by Chiles. + Made INIT-TTY-SCREEN-MANAGER make "Paren Pause Period" and "Highlight Open + Parens" be off in "Lisp" mode for tty's since we don't have highlighting + fonts for tty's. + +/usr1/lisp/hemlock/highlight.lisp, 25-Jan-88 16:19:49, Edit by DBM. + Chanded default for "Highlight Open Parens" to T. + +/usr1/lisp/nhem/newer/rompsite.lisp, 25-Jan-88 11:30:43, Edit by Chiles. + Made SLEEP-FOR-TIME deal with noting a read wait (dropping and lifting the + cursor). + +/usr1/lisp/nhem/main.lisp, 25-Jan-88 11:11:10, Edit by Chiles. + Entered DEFHVAR for "Key Echo Delay". + +/usr1/lisp/nhem/newer/interp.lisp, 25-Jan-88 11:06:01, Edit by Chiles. + Frobbed %COMMAND-LOOP to try to echo keys after some typing delay. + +/usr1/lisp/nhem/newer/lispeval.lisp, 24-Jan-88 19:43:50, Edit by Chiles. + Made DELETE-SERVER look for all bindings of "Current Eval Server", setting + them to nil if they referenced the argument info object. Also made it delete + the "Server Information" variable in the slave buffer if there was one. + +/usr1/lisp/nhem/newer/rompsite.lisp, 24-Jan-88 19:10:52, Edit by Chiles. + Modified EDITOR_CONNECT-HANDLER to define "Server Information" in the slave + buffer. + +/usr1/lisp/nhem/newer/command.lisp, 24-Jan-88 15:33:09, Edit by Chiles. + Installed Shareef's "Refresh Screen" that knows about arguments. + +/usr1/lisp/nhem/newer/lispmode.lisp, 24-Jan-88 15:27:06, Edit by Chiles. + Fixed bug in "Lisp Insert )" to make it echo the closing paren if it is not + DISPLAYED-P regardless of "Paren Pause Period". + +/usr1/lisp/nhem/highlight.lisp, 23-Jan-88 15:43:59, Edit by Chiles. + New file. + +/usr1/lisp/nhem/scribe.lisp, 23-Jan-88 15:42:11, Edit by Chiles. + Modified SCRIBE-INSERT-PAREN to know about "Paren Pause Period" possibly + being nil. + +/usr1/lisp/nhem/lispmode.lisp, 23-Jan-88 15:40:57, Edit by Chiles. + Modified "Lisp Insert )" to know about "Paren Pause Period" possibly being + nil. + +/usr1/lisp/nhem/morecoms.lisp, 23-Jan-88 15:36:22, Edit by Chiles. + Fixed "Mark Page" when point is at buffer-end. + +/usr1/lisp/nhem/srccom.lisp, 23-Jan-88 15:26:40, Edit by Chiles. + Put "Buffer Changes" from my init file into the core. + +/usr1/lisp/nhem/filecoms.lisp, 23-Jan-88 15:21:36, Edit by Chiles. + Modified "Revert File" to be more aware of whether it was backing up to the + checkpoint file or the saved file. + +/usr1/lisp/nhem/display.lisp, 23-Jan-88 14:01:50, Edit by Chiles. + Changed REDISPLAY-LOOP and REDISPLAY-WINDOWS-FROM-MARK to do the current + window first if it is going to get done, so the redisplay-hook effects could + be seen in other windows into the same buffer. + +/usr1/lisp/nhem/edit-defs.lisp, 23-Jan-88 14:47:28, Edit by Chiles. + Modified DEFINITION-EDITING-INFO to correspond to the new + FUN-DEFINED-FROM-PATHNAME ability to deal with encapsulations. + +/usr1/lisp/nhem/rompsite.lisp, 23-Jan-88 14:36:33, Edit by Chiles. + Modified FUN-DEFINED-FROM-PATHNAME, now deals with encapsulations. + +/usr1/lisp/nhem/indent.lisp, 23-Jan-88 13:42:43, Edit by Chiles. + Added Shareef's "Center Line" command. + +/usr1/lisp/nhem/files.lisp, 23-Jan-88 12:42:10, Edit by Chiles. + Made WRITE-FILE supply :if-exists :rename-and-delete. + +/usr1/lisp/nhem/lispeval.lisp, 23-Jan-88 12:28:13, Edit by Chiles. + Made "Compile File" signal an error when buffer has no associated pathname. + +/usr1/ch/lisp/filecoms.lisp, 22-Jan-88 11:48:49, Edit by Christopher Hoover + Fixed write-region to call (current-region) before prompting for filename. + This makes it work better with active regions. + +/usr1/chiles/work/modeline/window.lisp, 19-Jan-88 09:58:24, Edit by Chiles. + Modified DEFAULT-MODELINE-FUNCTION-FUNCTION and wrote + UPDATE-BUFFER-MODELINES, which is exported. + +/usr1/chiles/work/modeline/main.lisp, 19-Jan-88 10:10:27, Edit by Chiles. + Changed the value of "Default Modeline String". + +/usr1/chiles/work/modeline/lispmode.lisp, 19-Jan-88 10:05:31, Edit by Chiles. + Wrote SETUP-LISP-MODE to make a "Current Package" if there wasn't one already. + +/usr1/chiles/work/modeline/lispeval.lisp, 19-Jan-88 09:49:29, Edit by Chiles. + Made "Set Buffer Package" use PROMPT-FOR-EXPRESSION, using STRING on the + result. It also now calls UPDATE-BUFFER-MODELINES. When in a slave's + interactive buffer's, do NOT set "Current Package", but change *package* in + the slave. Modified sites of (value current-package) to supply "" instead of + the editor's *package*. + +/usr1/lisp/nhem/lispbuf.lisp, 18-Jan-88 12:50:34, Edit by Chiles. + Modified "package" file option to do a STRING of a READ-FROM-STRING. + +/usr1/lisp/nhem/ts.lisp, 17-Jan-88 20:53:13, Edit by Chiles. + Made MAKE-TYPESCRIPT use "Interactive History Length" when setting up + "Interactive History". + +/usr1/lisp/nhem/lispbuf.lisp, 17-Jan-88 20:51:25, Edit by Chiles. + Moved some stuff around. Created "Interactive History Length" used to setup + "Interactive History" when "Eval" mode is turned on. + +/usr1/lisp/nhem/spellcoms.lisp, 16-Jan-88 16:58:31, Edit by Chiles. + Introduced "Default User Spelling Dictionary". When set, this is loaded upon + entering "Spell" mode and when "Set Buffer Spelling Dictionary" (or + "dictionary" file option) runs. Also, "Save Incremental Spelling Insertions" + doesn't prompt for a file if this is set. + + Made SAVE-DICTIONARY-ON-WRITE make sure 'spell-information is bound in the + buffer. + +/usr1/ch/lisp/auto-save.lisp, 12-Jan-88 16:28:56, Edit by Christopher Hoover + Wrapped a condition-case around the write-file in Auto Save. This will cause + Auto Save to graceful handle write failures. + +/usr1/lisp/nhem/spellcoms.lisp, 06-Jan-88 22:14:14, Edit by Chiles. + Made incremental insertions dictionary specific with a global default for + upward compatability. + Commands with new names: + "Append to Spelling Dictionary" --> "Save Incremental Spelling Insertions" + "Augment Spelling Dictionary" --> "Read Spelling Dictionary" + New commands: + "Set Buffer Spelling Dictionary" + "Remove Word from Spelling Dictionary" + "List Incremental Spelling Insertions" + AND there is a "dictionary" file option that read a dictionary if necessary, + makes it the buffer's dictionary, and causes the incremental insertions for + this dictionary to be written when the buffer is. + + Added "Spelling Un-Correct Prompt for Insert" that makes "Undo Last Spelling + Correction" prompt before inserting word into dictionary. + +/usr1/lisp/nhem/doccoms.lisp, 22-Dec-87 15:42:26, Edit by Chiles. + Changed #\S help to #\V, "Describe and show Variable". Rewrote some code to + do this and added the command "Describe and show Variable". + +/usr1/lisp/nhem/spell-augment.lisp, 17-Dec-87 21:05:37, Edit by Chiles. + Added SPELL-ROOT-FLAGS, which returns a list of the letter flags a root entry + has, and SPELL-REMOVE-ENTRY, which removes an entry by clearing a flag if + appropriate or setting the dictionary element to -1. + +/usr1/lisp/nhem/spell-correct.lisp, 17-Dec-87 20:34:09, Edit by Chiles. + Made TRY-WORD-ENDINGS return the flag mask when a flag was used instead of + just t. Modified lookup hashing to know about deleted elements. + +/usr1/lisp/nhem/echo.lisp, 16-Dec-87 21:25:58, Edit by Chiles. + MAYBE-WAIT should really do a SLEEP instead of EDITOR-SLEEP to make sure + nothing happens while the user is trying to see the message. + +/usr1/lisp/nhem/active/text.lisp, 14-Dec-87 01:25:42, Edit by Chiles. + Made "Mark Paragraph" and "Mark Sentence" use PUSH-BUFFER-MARK, so it will + activate the region. + +/usr1/lisp/nhem/active/lispmode.lisp, 14-Dec-87 01:25:03, Edit by Chiles. + Made "Mark Defun" and "Mark Form" use PUSH-BUFFER-MARK, so it will activate + the region. + +/usr1/lisp/nhem/active/morecoms.lisp, 13-Dec-87 20:45:48, Edit by Chiles. + Modified "Insert Page Directory" to insert the listing at the curren point if + invoked with an argument. + +/usr1/lisp/nhem/active/lispeval.lisp, 12-Dec-87 13:15:04, Edit by Chiles. + Defined "Slave Utility Name" and "Slave Arguments" and made CREATE-SLAVE use + these to spawn Lisps. + +/usr1/lisp/nhem/active/main.lisp, 11-Dec-87 07:24:44, Edit by Chiles. + Defined and invoked "Reset Hook". + +/usr1/lisp/nhem/active/xcommand.lisp, 11-Dec-87 05:37:26, Edit by Chiles. + Made "Region to Cut Buffer" use CURRENT-REGION, insisting it be active. + +/usr1/lisp/nhem/active/lispbuf.lisp, 11-Dec-87 05:16:46, Edit by Chiles. + Made commands use CURRENT-REGION, insisting it be active. Changed the + semantics of "Editor Compile Defun" "Editor Evaluate Defun". + +/usr1/lisp/nhem/active/indent.lisp, 11-Dec-87 03:49:08, Edit by Chiles. + Made "Indent Region" and "Indent Rigidly" use CURRENT-REGION, insisting it be + active. + +/usr1/lisp/nhem/active/fill.lisp, 11-Dec-87 03:16:15, Edit by Chiles. + Made "Fill Region" use CURRENT-REGION, insisting it be active. + +/usr1/lisp/nhem/active/filecoms.lisp, 11-Dec-87 03:12:25, Edit by Chiles. + Made "Write Region" use CURRENT-REGION, insisting it be active. + +/usr1/lisp/nhem/active/abbrev.lisp, 11-Dec-87 03:05:12, Edit by Chiles. + Modified commands to use CURRENT-REGION, not insisting it be active. + +/usr1/lisp/nhem/active/morecoms.lisp, 11-Dec-87 02:40:31, Edit by Chiles. + Changed calls to PUSH-BUFFER-MARK that shouldn't activate the region. Made + "Count Lines Region" and "Count Words Region" use CURRENT-REGION, not + insisting it be active (for now). "Insert Page Directory" sets the command + type to :ephemerally-active, so "Kill Region" can kill the inserted text. + +/usr1/lisp/nhem/active/lispeval.lisp, 11-Dec-87 01:52:20, Edit by Chiles. + Made "Edit Compiler Errors" not activate the region when it calls + PUSH-BUFFER-MARK. Made commands use CURRENT-REGION, insisting it be active. + Changed the semantics of "Compile Defun" and "Evaluate Defun". Fixed bug in + FILE-COMPILE-TEMP-FILE. + +/usr1/lisp/nhem/active/edit-defs.lisp, 11-Dec-87 01:32:31, Edit by Chiles. + Made GO-TO-DEFINITION not activate the region when it calls + PUSH-BUFFER-MARK. + +/usr1/lisp/nhem/active/command.lisp, 11-Dec-87 01:25:22, Edit by Chiles. + Made "Beginning of Buffer" and "End of Buffer" not activate the region when + they call PUSH-BUFFER-MARK. + +/usr1/lisp/nhem/active/register.lisp, 11-Dec-87 01:01:22, Edit by Chiles. + Fixed bug in cleanup for deleted buffers -- should free register when its a + mark since you cannot list it. Made "Get Register" set LAST-COMMAND-TYPE to + :ephemerally-active, so "Kill Region" can kill the inserted text. + +/usr1/lisp/nhem/active/bindings.lisp, 10-Dec-87 23:41:40, Edit by Chiles. + Added bindings for "Activate Region", "Pop and Goto Mark", and "Pop Mark". + Bound "Verbose Directory" to ^X^D and destroyed translation for ^D, so I + duplicated bindings for "Delete Next Character" and "Scribe Display". + +/usr1/lisp/nhem/macros.lisp, 10-Dec-87 16:49:39, Edit by Chiles. + Made ADD-HOOK use PUSHNEW. + +/usr1/lisp/nhem/register.lisp, 10-Dec-87 00:08:00, Edit by Chiles. + New Register hacking code. + +/usr1/lisp/nhem/bindings.lisp, 09-Dec-87 13:55:22, Edit by Chiles. + Made bindings for "Transpose Regions" and "Directory". + Added default bindings for register stuff. + +/usr1/lisp/nhem/morecoms.lisp, 09-Dec-87 13:36:55, Edit by Chiles. + Added "Transpose Regions". + +/usr1/lisp/nhem/doccoms.lisp, 09-Dec-87 13:20:28, Edit by Chiles. + Wrote "Show Variable". + +/usr1/lisp/nhem/echo.lisp, 09-Dec-87 13:04:50, Edit by Chiles. + Modified PROMPT-FOR-VARIABLE and wrote VARIABLE-VERIFICATION-FUNCTION to + notice when a variable completion lost due to multiple entries of the same + variable. + +/usr1/lisp/nhem/spellcoms.lisp, 09-Dec-87 01:05:57, Edit by Chiles. + Made "Append to Spelling Dictionary" take an optional file argument. + +/usr1/lisp/nhem/edit-defs.lisp, 08-Dec-87 18:18:44, Edit by Chiles. + Merged with lost sources to get back the preference translation functionality + where one directory can be mapped to an ordered list of translations. + +/usr1/lisp/nhem/lispeval.lisp, 08-Dec-87 22:54:12, Edit by Chiles. + Modifed eval-notification structure, EVAL-OPERATION_COMPLETE, REGION-EVAL, + and FILE-COMPILE-TEMP-FILE. Wrote PATHNAME-FOR-REMOTE-ACCESS and STRING-EVAL + and the command "Load File". + +/usr1/lisp/nhem/lispbuf.lisp, 08-Dec-87 19:48:43, Edit by Chiles. + Renamed "Load File" to be "Editor Load File". + +/usr1/lisp/nhem/main.lisp, 05-Dec-87 18:14:19, Edit by Chiles. + Defined "Redisplay Hook". + +/usr1/lisp/nhem/display.lisp, 05-Dec-87 15:37:53, Edit by Chiles. + Put a redisplay hook into REDISPLAY-WINDOW-RECENTERING. + +/usr1/lisp/nhem/rompsite.lisp, 04-Dec-87 21:10:14, Edit by Chiles. + Made SITE-WRAPPER-MACRO bind *standard-input* to a stream that disallows + reads. This is to keep people from losing in "Eval" mode. + +/usr1/lisp/nhem/filecoms.lisp, 04-Dec-87 15:00:50, Edit by Chiles. + Made "Visit File" set buffer-writable, so the buffer's region could be + deleted when the buffer was read only. + +/usr1/lisp/nhem/edit-defs.lisp, 04-Dec-87 14:54:21, Edit by Chiles. + Created "Editor Definition Info" variable to control where "Edit + Definition" and "Go to Definition" get their defined from information, + the editor Lisp or the slave Lisp. + +/usr1/lisp/nhem/lispbuf.lisp, 04-Dec-87 13:52:46, Edit by Chiles. + Made "Editor Definition Info" t in "Eval" mode. + +/usr1/lisp/nhem/lispeval.lisp, 04-Dec-87 13:53:20, Edit by Chiles. + Made "Editor Definition Info" t in "Editor" mode. + +/usr1/lisp/hemlock/lispeval.lisp, 02-Dec-87 13:23:27, Edit by DBM. + Mofified for new name server. + +/usr1/lisp/hemlock/rompsite.lisp, 02-Dec-87 13:22:10, Edit by DBM. + Modified for new name server. + +/usr1/lisp/nhem/bit-screen.lisp, 29-Nov-87 22:55:03, Edit by Chiles. + Made BITMAP-DELETE-WINDOW call REMOVE-XWINDOW-OBJECT on the X window + instead of the Hemlock window. + +/usr1/lisp/nhem/auto-save.lisp, 23-Nov-87 15:59:36, Edit by Chiles. + Picked up Chris' latest version. Tweaked a defvar into a defhvar. + Changed its reference and made "Save" mode be turned off when nil or an + empty pathname is returned. + +/usr1/lisp/nhem/lispeval.lisp, 23-Nov-87 14:33:19, Edit by Chiles. + Fixed logic error in GET-CURRENT-SERVER. + +/usr1/lisp/nhem/lispeval.lisp, 20-Nov-87 14:17:52, Edit by Chiles. + Wrote CALL-EVAL_FORM that makes sure the server isn't busy, binds and + error handler, and binds a server death handler. EVAL_FORM-IN-CLIENT and + "Re-Evaluate Defvar" use this. + +/usr1/lisp/nhem/rompsite.lisp, 20-Nov-87 13:22:23, Edit by Chiles. + Made GET-HEMLOCK-CURSOR do a TRUENAME on the cursor bitmap file variable. + +/usr1/lisp/nhem/searchcoms.lisp, 20-Nov-87 11:56:35, Edit by Chiles. + "Delete Matching Lines" modified and new "Delete Non-Matching Lines" by + Chris. + +/usr1/lisp/nhem/killcoms.lisp, 20-Nov-87 11:58:26, Edit by Chiles. + "Delete Blank Lines" added by Chris. + +/usr1/lisp/nhem/bindings.lisp, 20-Nov-87 12:06:58, Edit by Chiles. + Added binding for "Delete Blank Lines". + +/usr1/lisp/nhem/morecoms.lisp, 20-Nov-87 12:10:21, Edit by Chiles. + Added Chris' "Count Words Region". + +/usr1/lisp/nhem/bit-screen.lisp, 19-Nov-87 00:02:04, Edit by Chiles. + Fixed problem with flushing random typeout with the mouse over the + typeout window. Apparently when X buries a window, you do not get an + exit event, but Hemlock was getting an entered event and causing the + cursor to get out of sync. + +/usr1/lisp/nhem/lispeval.lisp, 18-Nov-87 22:39:54, Edit by Chiles. + Rewrote CHECK-SERVER-INFO, SUB-CHECK-SERVER-INFO, and GET-CURRENT-SERVER. + Added MAYBE-CREATE-SLAVE in the process. Now when the current eval + server dies, the next Lisp interaction command does not signal an error + but tries to get a valid slave for the user. + +/usr1/lisp/nhem/rompsite.lisp, 18-Nov-87 01:07:02, Edit by Chiles. + Wrote EDITOR-INPUT-METHOD-MACRO to replace the bodies of EDITOR-TTY-IN + and EDITOR-WINDOW-IN. Added to the macro a test for re-entering a + Hemlock input method, signalling an error if this happens. Added a + binding of an error condition handler that exits Hemlock and goes into + the debugger. + +/usr1/lisp/hemlock/bit-screen.lisp, 17-Nov-87 17:03:15, Edit by Chiles. + Made enter and exit window event handlers call CURSOR-INVERT-CENTER when + the cursor is dropped. + +/usr1/lisp/nhem/lispeval.lisp, 17-Nov-87 15:40:42, Edit by Chiles. + Made CREATE-SLAVE not call INIT-EDITOR-SERVER since we presumably catch + nameserver crashes now. + +/usr1/lisp/nhem/lispbuf.lisp, 15-Nov-87 20:30:20, Edit by Chiles. + Made "Compile File" do an update compilation. + +/usr1/lisp/nhem/lispeval.lisp, 15-Nov-87 20:11:12, Edit by Chiles. + Made "Compile File" do an update compilation. + +/usr1/lisp/nhem/main.lisp, 15-Nov-87 18:20:19, Edit by Chiles. + Fixed doc string of ED to escape some "'s. + +/usr1/lisp/nhem/morecoms.lisp, 15-Nov-87 17:27:12, Edit by Chiles. + Made "Exit Recursive Edit" and "Abort Recursive Edit" call + IN-RECURSIVE-EDIT, signalling an error when nil. + +/usr1/lisp/nhem/buffer.lisp, 15-Nov-87 16:48:01, Edit by Chiles. + Made EXIT-RECURSIVE-EDIT and ABORT-RECURSIVE-EDIT signal an error when + not in a recursive edit. Wrote IN-RECURSIVE-EDIT. + +/usr1/lisp/nhem/lispbuf.lisp, 15-Nov-87 13:45:32, Edit by Chiles. + Made "Load File" supply (or load default buffer pathname default) for + :default to PROMPT-FOR-FILE. + +/usr1/lisp/nhem/, 15-Nov-87 13:24:00, Edit by Chiles. + Renamed Integrity.Lisp to Hi-Integrity.Lisp. Created Ed-Integrity.Lisp + that currently includes tty redisplay testing code. Modified Ctw.Lisp to + conform with these two changes. + +/usr1/lisp/nhem/tty-display.lisp, 15-Nov-87 12:35:09, Edit by Chiles. + Generally added major gobs of documentation. + Modified: + COMPUTE-TTY-CHANGES + Introduced cum-inserts. + Changed computation of line deletions location. + Changed where deletions are done for the modeline due to excessive + insertion above it. + DO-SEMI-DUMB-LINE-WRITES + Commented out a somewhat bogus optimization that was causing + TTY-SMART-WINDOW-REDISPLAY to lose when "Scroll Redraw Ration" + kicked in. + DELETE-SI-LINES + INSERT-SI-LINES + Changed variable names. + +/usr1/lisp/nhem/filecoms.lisp, 14-Nov-87 13:38:42, Edit by Chiles. + Made "Write Region" use BUFFER-PATHNAME-DEFAULTS. + +/usr1/lisp/nhem/lispeval.lisp, 11-Nov-87 21:54:53, Edit by Chiles. + Modified "Edit Compiler Errors" to not switch to errors buffer unless it + has too. This fixes spurious redisplay when there are no errors to edit. + +/usr1/lisp/nhem/main.lisp, 10-Nov-87 19:19:13, Edit by Chiles. + Removed DEFHVAR's for "Timer Hook" and "Timer Hook Interval". + +/usr1/lisp/nhem/rompsite.lisp, 10-Nov-87 19:15:25, Edit by Chiles. + Added page title "Time queue". This is used in editor input stream in + methods in conjunction with user interfaces SCHEDULE-EVENT and + REMOVE-SCHEDULED-EVENT to all the user to have functions invoked + periodically. + +/usr1/lisp/nhem/main.lisp, 09-Nov-87 21:23:37, Edit by Chiles. + Added AFTER-EDITOR-INITIALIZATIONS macro. Made ED funcall stuff on + *after-editor-initializations-funs* put there by the macro. + +/usr1/lisp/nhem/filecoms.lisp, 06-Nov-87 00:59:21, Edit by Chiles. + Modified WRITE-DA-FILE and READ-DA-FILE to invoke the "Write File Hook" + and "Read File Hook" hooks. eh! + +/usr2/lisp/nhem/lispeval.lisp, 26-Oct-87 11:36:35, Edit by Chiles. + Put back in feature of restoring previous buffer in "Edit Compiler + Errors" that was lost somehow. + +/usr2/lisp/nhem/filecoms.lisp, 25-Oct-87 17:13:04, Edit by Chiles. + ROB: Split two subfunctions off of "Find File". FIND-FILE-BUFFER does + all the work, returning the buffer and a flag indicating whether it + created a buffer. Fixed some :prompt values. + +/usr2/lisp/nhem/edit-defs.lisp, 25-Oct-87 16:42:00, Edit by Chiles. + Fixed bug in GET-DEFINITION-PATTERN for type :command. + +/usr0/ram/group.lisp, 04-Oct-87 15:10:49, Edit by Ram. + Changed Group-Read-File to use Find-File-Buffer instead of Find-File-Command, + eliminating the need for gruesome hacks to tell whether a buffer was created. + This also has the beneficial side-effect of making it easy for group commands + to leave to buffer history intact. Changed Do-Active-Group to restore the + buffer that was current at the time the command was done. + +/usr1/lisp/hemlock/hunk-draw.lisp, 23-Oct-87 15:45:14, Edit by Chiles. + Wrote CURSOR-INVERT-CENTER to hollow out the center of the cursor. THis + is used when Hemlock is not the listener to corresspond with Xterm + behaviour. Modified DROP-CURSOR and LIFT-CURSOR to use this new fun too + when Hemlock is not the listener, so we don't get little black squares or + empty boxes when we should. + +/usr2/lisp/nhem/filecoms.lisp, 23-Oct-87 15:36:25, Edit by Chiles. + Inserted Chris Hoover's "Revert File" and "Mode" file option definitions. + +/usr2/lisp/nhem/hunk-draw.lisp, 23-Oct-87 15:24:36, Edit by Chiles. + Fixed documentation for DRAW-HUNK-BOTTOM-BORDER and HUNK-REPLACE-MODELINE, + stating dependencies on BITMAP-HUNK-MODELINE-POS not returning nil. + +/usr2/lisp/nhem/bit-screen.lisp, 23-Oct-87 15:16:40, Edit by Chiles. + Fixed a usage of BITMAP-HUNK-MODELINE-POS that was assuming it was never + nil. + +/usr1/lisp/hemlock/lispeval.lisp, 23-Oct-87 12:10:09, Edit by DBM. + File-compile, Region-eval, and region-compile were passing a + structure as a port to the servers. + +/usr2/lisp/nhem/bindings.lisp, 23-Oct-87 11:58:45, Edit by Chiles. + Killed bindings for c-m-c and c-m-\c in "Echo Area". + +/usr2/lisp/nhem/bit-screen.lisp, 22-Oct-87 15:43:08, Edit by Chiles. + Fixed BITMAP-MAKE-WINDOW to set the thumb-bar-p slot to (and + modeline-string (value thumb-bar-meter)) instead of just the Hvar's + value. Windows without modelines were get a nil not number error. + +/usr2/lisp/nhem/lispbuf.lisp, 16-Oct-87 14:04:38, Edit by Chiles. + Made DESCRIBE-SYMBOL-AUX slightly better with respect to (quote ) + (function ). + +/usr2/lisp/nhem/lispeval.lisp, 15-Oct-87 22:22:13, Edit by Chiles. + Made DESCRIBE-SYMBOL-AUX slightly better with respect to (quote ) + (function ). + +/usr2/lisp/nhem/edit-defs.lisp, 15-Oct-87 21:02:29, Edit by Chiles. + Added a hack to catch command definitions when looking for the name of a + function, and the last sever letters of the function name are "COMMAND". + +/usr2/lisp/nhem/bit-screen.lisp, 15-Oct-87 16:33:54, Edit by Chiles. + Made HUNK-EXPOSED-OR-CHANGED take a width and height argument since the X + exposedwindow handler is supposed to now and eliminated the call to + FULL-WINDOW-STATE. + +/usr1/lisp/hemlock/rompsite.lisp, 12-Oct-87 16:56:14, Edit by DBM. + Added auto-save.fasl to list of files loaded. + +/usr1/lisp/hemlock/auto-save.lisp, 12-Oct-87 16:49:34, Edit by DBM. + Added to the hemlock sources. + +/usr2/lisp/nhem/lispeval.lisp, 06-Oct-87 00:18:25, Edit by Chiles. + Modified "Edit Compiler Errors" to save a pointer to the previous buffer + when moving to the background buffer, and to use this before EDITOR-ERROR + calls to restore the user's position. + +/usr2/lisp/nhem/edit-defs.lisp, 01-Oct-87 14:06:00, Edit by Chiles. + Rewrote translation stuff and GO-TO-DEFINITION to handle a list of + translations for a given match. This allows me to first look on + vancouver, then wb1, then lisp-rt1, then fred, etc. for sources depending + on which machines are down. + +/usr2/lisp/nhem/filecoms.lisp, 01-Oct-87 12:20:46, Edit by Chiles. + Modified "Save All Files" to show the file it is going to write when + prompting, and when the buffer name is not derived from the pathname, it + shows both. + +/usr2/lisp/nhem/bit-screen.lisp, 30-Sep-87 22:39:37, Edit by Chiles. + Rewrote BITMAP-DELETE-WINDOW to not lose when a window is made and then + deleted right away. Created DELETING-WINDOW-DROP-EVENT that drops + pending events for a window that is about to be deleted. Also, made + BITMAP-DELETE-WINDOW lift the cursor when the window being deleted + displayed the cursor. + +/usr2/lisp/nhem/ts.lisp, 30-Sep-87 21:57:18, Edit by Chiles. + Made PROCESS_OPERATION_CONTROL-HANDLER test for *in-top-level-catcher* + before throwing to top level. + +/usr2/lisp/nhem/tty-display.lisp, 29-Sep-87 15:40:22, Edit by Chiles. + Modified TTY-SMART-CLEAR-TO-EOW and TTY-DUMB-WINDOW-REDISPLAY to clear + screen image lines properly ... had some off-by-one problems. + +/usr2/lisp/nhem/lispbuf.lisp, 28-Sep-87 12:59:25, Edit by Chiles. + Made "Editor Compile Defun" and "Editor Compile Region" call + COMPILE-FROM-STREAM with :defined-from-pathname supplied as the buffer's + pathname. + +/usr2/lisp/nhem/rompsite.lisp, 28-Sep-87 11:21:07, Edit by Chiles. + Made FUN-DEFINED-FROM-PATHNAME test for "/..", clipping it and the + machine name if it is present in the defining file name. + +/usr2/lisp/nhem/lispeval.lisp, 25-Sep-87 11:42:25, Edit by Chiles. + Modified "Set Eval Buffer" to set the global eval server always. + Modified "Set Compile Server" to set the global compile server always. + Rewrote or added support routines SELECT-CURRENT-SERVER, + SELECT-GLOBAL-SERVER, SELECT-CURRENT-COMPILE-SERVER, + SELECT-GLOBAL-COMPILE-SERVER, GET-CURRENT-SERVER, CHECK-SERVER-INFO. + Modified "Select Background" to try for the current compile server's + background with a prefix argument. Modified "Edit Compiler Errors" to + look for a compile server before using the current eval server. Added + commands "Current Eval Server" and "Current Compile Server". Introduced + "Prompt for Current Server", so CHECK-SERVER-INFO does not prompt for + creating a new slave but prompts for an already known server instead. + +/usr2/lisp/nhem/morecoms.lisp, 24-Sep-87 23:12:42, Edit by Chiles. + Modified "List Buffers" to show both buffer name and pathname when the + are different and both exist. + +/usr2/lisp/nhem/hunk-draw.lisp, 25-Sep-87 09:48:17, Edit by Chiles. + Made HUNK-DRAW-BOTTOM-BORDER enhance the 80'th notch it draws. + +/usr2/lisp/nhem/defsyn.lisp, 24-Sep-87 23:32:57, Edit by Chiles. + Made #\formfeed no longer is a whitespace character. + +/usr2/lisp/nhem/bindings.lisp, 24-Sep-87 23:28:26, Edit by Chiles. + Did some "Argument Digit" binding. + +/usr2/lisp/nhem/lispmode.lisp, 24-Sep-87 23:24:29, Edit by Chiles. + "Minimum Lines Parsed" and "Maximum Lines Parsed" now default to 50 and + 500. + +/usr2/lisp/nhem/searchcoms.lisp, 24-Sep-87 23:22:41, Edit by Chiles. + Made "Count Occurrences" use echo area for result instead of random + typeout. + +/usr2/lisp/nhem/filecoms.lisp, 24-Sep-87 22:16:48, Edit by Chiles. + Made default for "Save All Files Confirm" be t. + +/usr2/lisp/nhem/bindings.lisp, 24-Sep-87 22:11:20, Edit by Chiles. + Made binding for "Select Background", C-M-C. + +/usr2/lisp/nhem/lispbuf.lisp, 24-Sep-87 22:02:32, Edit by Chiles. + Changed "Lisp Describe" to "Editor Describe". + +/usr2/lisp/nhem/doccoms.lisp, 24-Sep-87 21:56:40, Edit by Chiles. + Replaced instance of LISP-DESCRIBE-COMMAND with EDITOR-DESCRIBE-COMMAND. + +/usr2/lisp/nhem/lispbuf.lisp, 24-Sep-87 21:48:36, Edit by Chiles. + Removed "Eval Mode" command. + +/usr2/lisp/nhem/lispeval.lisp, 24-Sep-87 00:21:19, Edit by Chiles. + Fixed "Set Buffer Package" to not try to access nil when there isn't a + current eval server. Also, made it test for the server being valid + before trying to use it. + +/usr2/lisp/nhem/lispeval.lisp, 23-Sep-87 22:49:32, Edit by Chiles. + Modified GET-CURRENT-SERVER and CREATE-SERVER to use + MAYBE-GET-SLAVE-NAME. + +/usr2/lisp/nhem/rompsite.lisp, 23-Sep-87 22:27:38, Edit by Chiles. + Modified EDITOR_CONNECT-handler to handler name argument differently. + Added definition of "Thumb Bar Meter" to SITE-INIT. + +/usr2/lisp/nhem/bit-screen.lisp, 23-Sep-87 15:03:12, Edit by Chiles. + Made HUNK-EXPOSED-REGION and HUNK-RESET call HUNK-DRAW-BOTTOM-BORDER. + +/usr2/lisp/nhem/hunk-draw.lisp, 23-Sep-87 14:56:44, Edit by Chiles. + Renamed HUNK-DRAW-TOP-BORDER to HUNK-DRAW-BOTTOM-BORDER and made it do it + to the bottom. Made hunk-bottom-border be 10 instead of 3. + +/usr2/lisp/nhem/bindings.lisp, 21-Sep-87 17:13:39, Edit by Chiles. + Made "Compile File" be the default binding for "Editor" mode. + +/usr2/lisp/nhem/rompsite.lisp, 21-Sep-87 12:55:58, Edit by Chiles. + Modified EDITOR-WINDOW-IN to not use VARIABLE-VALUE four times in a loop. + Likewise for EDITOR-TTY-IN. + +/usr2/lisp/nhem/edit-defs.lisp, 20-Sep-87 23:57:08, Edit by Chiles. + Rewrote GET-DEFINTION-FILE and wrote MAYBE-TRANSLATE-DEFINITION-FILE to + have definition directory translation done in the editor instead of the + client. + +/usr2/lisp/nhem/bindings.lisp, 15-Sep-87 16:44:28, Edit by Chiles. + Made prefix key translation for #\control-^ to be :control. + +/usr2/lisp/nhem/lispeval.lisp, 14-Sep-87 22:09:42, Edit by chiles. + Modified "Set Buffer Package" to use new TL:SET_PACKAGE interface. + +/usr2/lisp/nhem/htext4.lisp, 14-Sep-87 17:27:44, Edit by chiles. + Modified DELETE-CHARACTERS to do nothing and return t when n = 0. + Modified DELETE-REGION to do nothing when the region is empty. + Modified DELETE-AND-SAVE-REGION to just return an empty region when its + argument is empty. + +/usr2/lisp/nhem/htext3.lisp, 14-Sep-87 17:12:52, Edit by chiles. + Modified INSERT-STRING to not modify buffer when the string is empty. + INSERT-CHARACTER always modifies the buffer. + INSERT-REGION wins on empty regions because of INSERT-STRING. + +/usr2/lisp/nhem/display.lisp, 14-Sep-87 17:14:52, Edit by chiles. + Added some documentation to REDISPLAY-WINDOW-RECENTERING. Modified + MAYBE-UPDATE-WINDOW-IMAGE to return to or nil based on whether it updated + the window image. + +/usr2/lisp/nhem/cursor.lisp, 14-Sep-87 16:59:56, Edit by chiles. + Modified MAYBE-RECENTER-WINDOW to return t or nil based on whether it + recentered. + +/usr2/lisp/nhem/filecoms.lisp, 13-Sep-87 18:37:15, Edit by Chiles. + Made "Log Entry Template" capitalize file author. + +/usr2/lisp/nhem/lispeval.lisp, 13-Sep-87 17:59:15, Edit by Chiles. + Modified server-info structure, removing the ll-buffer slot in favor of a + slave-ts slot. Modified CREATE-SLAVE to pass the -slave switch the name + of the editor server in case two people are on the same machine (in which + case they must use -edit differently), and instead of using EDITOR-SLEEP, + it now uses SERVER (it was returning immediately on input with + EDITOR-SLEEP). Modified REGION-EVAL, REGION-COMPILE, and FILE-COMPILE to + pass the slave-ts slot of the server-info structure of the notification, + so terminal-io will happen in the interactive buffer for the server + instead of the background buffer. + +/usr2/lisp/nhem/main.lisp, 13-Sep-87 14:32:47, Edit by Chiles. + Added DEFHVAR's for "Input Hook", "Timer Hook", and "Timer Hook + Interval". Added code in ED to handle Hemlock specific init files. + +/usr2/lisp/nhem/ts.lisp, 13-Sep-87 15:34:09, Edit by Chiles. + Modified READ-OR-HANG to message about input waits that occur while a + buffer is not visible. Introduced variable "Input Wait Alarm". + +/usr2/lisp/nhem/rompsite.lisp, 13-Sep-87 14:41:27, Edit by Chiles. + Made editor input stream methods deal with "Input Hook", "Timer Hook", + and "Timer Hook Interval". Modified EDITOR_CONNECT-HANDLER to correspond + with new server-info structure. + +/usr1/lisp/hemlock/rompsite.lisp, 10-Sep-87 14:38:14, Edit by DBM. + Now that Lisp no longer diddles the interrupt characters, the bare + console has to be modified so that it doesn't send one of the standard + control characters as part of the encoding for control characters. + +/usr0/ram/htext1.lisp, 10-Sep-87 13:29:50, Edit by Ram + Added a without-interrupts in Close-Line and some warnings about exclusion + elsewhere. + +/usr2/lisp/nhem/lispbuf.lisp, 09-Sep-87 22:09:00, Edit by Chiles. + Wrote "Select Eval Buffer" command. + +/usr2/lisp/nhem/lispeval.lisp, 09-Sep-87 21:47:46, Edit by Chiles. + Rewrote the local queuing of :unsent notifications. This involved + deleting all the old stuff and changing KILL-NOTIFICATION and + MAYBE-QUEUE-OPERATION-REQUEST. + +/usr2/lisp/nhem/filecoms.lisp, 09-Sep-87 18:17:34, Edit by Chiles. + Changed "Log Entry Template". + +/usr2/lisp/nhem/rompsite.lisp, 09-Sep-87 18:06:39, Edit by Chiles. + Made MORE-READ-CHAR call REDISPLAY while looping on SERVER. + +/usr2/lisp/nhem/tty-display-rt.lisp, 09-Sep-87 16:00:26, Edit by Chiles. + Modified INIT-TTY-DEVICE and EXIT-TTY-DEVICE to not assume that + system:*file-input-handlers* had an association for Unix stdin (0). + +/usr2/lisp/nhem/lispbuf.lisp, 08-Sep-87 14:04:00, Edit by Chiles. + Replaced appropriate occurrences of "top-level" and "top level" with + "eval". + +/usr2/lisp/nhem/lispeval.lisp, 07-Sep-87 20:56:39, Edit by Chiles. + Replaced occurrences of "lisp listener" with "slave lisp" or "lisp + interaction". Renamed things to to with "anonymous client lisp" to + "slave". + +/usr2/lisp/nhem/tty-display-rt.lisp, 06-Sep-87 18:47:02, Edit by Chiles. + Added some documentation to the exit method. + +/usr2/lisp/nhem/filecoms.lisp, 03-Sep-87 16:12:28, Edit by Chiles. + Made "Directory" list Unix dot files if the prefix is supplied and made + the random typeout window have the right number of lines for each + listing. Made a "Verbose Directory" command like "Directory" but based + on the new :verbose argument to PRINT-DIRECTORY. + +/usr2/lisp/nhem/rompsite.lisp, 06-Sep-87 18:07:40, Edit by Chiles. + Fixed INIT-RAW-IO again to not push into system:*file-input-handlers*. + Modified EDITOR_CONNECT-HANDLER to make "Slave Lisp " buffer names + instead of "Lisp Listener " buffer names. + +/usr2/lisp/nhem/tty-display.lisp, 06-Sep-87 16:54:18, Edit by Chiles. + Fixed TTY-SMART-CLEAR-TO-EOW boundary condition -- when clearing last + line of window to eow, needed >= test instead of = test. + +/usr2/lisp/nhem/bindings.lisp, 05-Sep-87 15:52:11, Edit by Chiles. + Deleted binding of "Exit Hemlock" to C-c since it is later used for + "Process Control". Changed binding of "Select Lisp Listener" to be a + binding for "Select Slave Lisp". Replaced occurrences of "top-level" + with "eval". + +/usr2/lisp/nhem/morecoms.lisp, 05-Sep-87 14:08:32, Edit by Chiles. + Made "List Buffers" print pathnames with the FILE-NAMESTRING first + followed by two spaces and the DIRECTORY-NAMESTRING. + +/usr2/lisp/nhem/hunk-draw.lisp, 01-Sep-87 15:02:57, Edit by Chiles. + Made CURSOR-INVERT do an X:XFLUSH. + +/usr2/lisp/nhem/bindings.lisp, 01-Sep-87 15:00:47, Edit by Chiles. + Fixed merge lossage from re-integration with sources. + +/usr2/lisp/nhem/bindings.lisp, 28-Aug-87 17:05:12, Edit by Chiles. + Fixed some bindings for "Editor" mode and put them on the right page. + +/usr2/lisp/nhem/lispeval.lisp, 28-Aug-87 19:05:14, Edit by Chiles. + Fixed bug in CREATE-ANONYMOUS-CLIENT-LISP and "Select Lisp Listener". + Made "Set Eval Server" really define a buffer local variable when a + prefix was supplied. + +/usr1/ram/charmacs.lisp, 25-Aug-87 19:59:00, Edit by Ram + Flushed Alt and Oops character names. Added Escape as a name to shadow + the initial Altmode name. Added Enter and Action as alternate names for + Return and Linefeed. + +/usr1/ram/keytran.lisp, 25-Aug-87 19:44:24, Edit by Ram + Changed delete to translate to delete rather than oops. Made all random + named keys translate to a super character when shifted. Made keypad keys + always translate to super characters. + +/usr1/ram/bindings.lisp, 25-Aug-87 19:15:10, Edit by Ram + Frobbed bindings to allow rational documentation. Case-Insensitivize now + translates to lowercase. Use of Insert as an Escape standin had been + flushed. Insert is now used for X cut buffer operations. Bindings to Oops + have been flushed. Interactive input kill/abort is now M-i/C-M-i. Flushed + redundant extra bindings of mouse commands to super-clicks (except for S-left + being the same as middle). Made S-Left and S-Right be illegal in the echo + area. Made illegal upclicks do nothing so that you don't get annoying double + errors. Made C-_ be a :Help character. Flushed M-_ binding for Help and + Help on Parse. Made redundant bindings to backspace and return for C-h and + C-m so that TTYs can win. (Scribe mode is still wedged pending intallation + of the new Scribe insertion command.) Use Delete character name instead of + Rubout. + +/usr2/lisp/nnhem/searchcoms.lisp, 24-Aug-87 09:17:00, Edit by Chiles + Added Chris Hoover's "List Matching Lines", "Delete Matching Lines", and + "Count Occurrences". Redid page breaks. + +/usr2/lisp/nnhem/lispeval.lisp, 23-Aug-87 18:53:42, Edit by Chiles + Rewrote "Select Lisp Listener" and wrote CREATE-ANONYMOUS-CLIENT-LISP to + be used in the command and GET-CURRENT-SERVER. + +/usr2/lisp/nnhem/tty-screen.lisp, 23-Aug-87 10:15:58, Edit by Chiles + TTY-RANDOM-TYPEOUT-CLEANUP now calls REDISPLAY-WINDOW-ALL instead of + funcall'ing DEVICE-DUMB-REDISPLAY directly. + +/usr2/lisp/nnhem/font.lisp, 22-Aug-87 14:10:06, Edit by Chiles + SETF methods for changing a window's font set the hunk's trashed slot to + :font-change instead of t. + +/usr2/lisp/nnhem/window.lisp, 21-Aug-87 19:59:19, Edit by Chiles + Replaced numeric constants with symbolic ones. WINDOW-CHANGED no longer + redisplays, but it does update the window image (recentering if current + window). + +/usr2/lisp/nhem/pane.lisp, 19-Aug-87 22:34:12, Edit by Chiles + Wrote OFROB-CURSOR to be the note-read-wait method for old bitmap + displays. Rewrote PANE-SHOW-CURSOR. Titled pages. Documented cursor + stuff. + +/usr2/lisp/nhem/obit-screen.lisp, 19-Aug-87 22:28:24, Edit by Chiles + Added an initialization for the note-read-wait slot of the default old + bitmap device to #'ofrob-cursor. OBITMAP-RANDOM-TYPEOUT-CLEANUP now + calls REDISPLAY-WINDOW-ALL instead of ODUMB-WINDOW-REDISPLAY. + +/usr2/lisp/nhem/hunk-draw.lisp, 19-Aug-87 18:53:14, Edit by Chiles + Rewrote HUNK-SHOW-CURSOR. Added FROB-CURSOR. Tweaked DROP-CURSOR and + LIFT-CURSOR. + +/usr2/lisp/nhem/bit-screen.lisp, 19-Aug-87 18:49:23, Edit by Chiles + Initialized note-read-wait slot of default bitmap device to #'frob-cursor + which is new in Hunk-Draw.Lisp. Modified SET-WINDOW-HOOK-RAISE-FUN. Put + DEFHVAR in SITE-INIT. Removed all references to BITMAP-HUNK-LOCK. + Additionally modified HUNK-RESET, HUNK-EXPOSED-OR-CHANGED, and + HUNK-CHANGED. HUNK-EXPOSED-OR-CHANGED now calls REDISPLAY-WINDOW-ALL + instead of DUMB-WINDOW-REDISPLAY. + +/usr2/lisp/nhem/display.lisp, 19-Aug-87 18:46:16, Edit by Chiles + Added device structure slot note-read-wait which is a function that + somehow notes on the display that input is expected. This will simply be + dropping the cursor for now on the RT. Rewrote REDISPLAY-LOOP to take a + window variable to bind and two forms for general window redisplay and + current window redisplay. Added REDISPLAY-WINDOW, REDISPLAY-WINDOW-ALL, + MAYBE-UPDATE-WINDOW-IMAGE, and REDISPLAY-WINDOW-RECENTERING. Modified + REDISPLAY-WINDOWS-FROM-MARK to use REDISPLAY-WINDOW-RECENTERING (which is + also used by REDISPLAY). + +/usr2/lisp/nhem/bit-display.lisp, 19-Aug-87 14:44:03, Edit by Chiles + Reorganized pages some: put smart redisplay structure definitions on the + smart window redisplay page, and retitle/titled other pages. Did away + with most macros, making them functions and moving their definitions + below their uses. Modified some call sites and argument passing of what + were macros and now are functions. Removed code from + SMART-WINDOW-REDISPLAY and DUMB-WINDOW-REDISPLAY that is now encorporated + into the REDISPLAY and REDISPLAY-ALL loops. Removed references and sets + to BITMAP-HUNK-LOCK. + +/usr2/lisp/nhem/obit-display.lisp, 19-Aug-87 14:44:14, Edit by Chiles + Moved definition of *current-font* from Bit-Display.Lisp to the only file + using it, this one. Removed recenterp argument from + OSMART-WINDOW-REDISPLAY and ODUMB-WINDOW-REDISPLAY. Also removed window + image building code from these functions since it is now taken care of + higher up in the redisplay calls. + +/usr2/lisp/nhem/tty-display-rt.lisp, 19-Aug-87 12:26:13, Edit by Chiles + Modified INIT-TTY-DEVICE and EXIT-TTY-DEVICE to destructively modify + system:*file-input-handlers*. Now the standard input file descriptor + used for terminal streams is associated with an editor input handler + instead of the editor having its own file descriptor. + +/usr2/lisp/nhem/rompsite.lisp, 18-Aug-87 15:29:01, Edit by Chiles + Modified INIT-RAW-IO to not open the tty device. Now, it simply assumes + Unix standard input. Modified TTY-BEEP to not write to the editor's file + descriptor which is Unix standard input but to write to 1 (Unix standard + output). Put DEFHVAR for "Set Window Autoraise" in SITE-INIT. Modified + SHOW-MARK to call REDISPLAY-WINDOW instead of calling the smart redisplay + method out of the device. Made editor connect handler store lisp + listener buffer in server-info slot. + +/usr2/lisp/nhem/tty-display.lisp, 18-Aug-87 15:13:41, Edit by Chiles + Moved INIT-TTY-DEVICE and EXIT-TTY-DEVICE to Tty-Display-Rt.Lisp. + Deleted code from TTY-SMART-WINDOW-REDISPLAY and + TTY-SEMI-DUMB-WINDOW-REDISPLAY that was folded into the REDISPLAY and + REDISPLAY-ALL loops. Likewise for TTY-DUMB-WINDOW-REDISPLAY. Also + deleted recenterp arguments from all these functions. + +/usr2/lisp/nhem/rompsite.lisp, 18-Aug-87 14:13:43, Edit by Chiles + Made EDITOR-TTY-IN and EDITOR-WINDOW-IN drop and lift the cursor at most + once, not each time SERVER is called. + +/usr2/lisp/nhem/vars.lisp, 18-Aug-87 13:29:37, Edit by Chiles + Fixed error form for GET-MODE-OBJECT to say the argument is not a defined + mode instead of saying NIL isn't. + +/usr2/lisp/nhem/buffer.lisp, 18-Aug-87 13:28:01, Edit by Chiles + Fixed MODE-MAJOR-P to return MODE-OBJECT-MAJOR-P instead of + MODE-OBJECT-NAME. + +/usr2/lisp/nhem/morecoms.lisp, 11-Aug-87 12:03:46, Edit by Chiles + JR fixed "List Buffers" to print the pathname of the buffer unless there + was not one or the buffer names was not derived from it. Otherwise, + print the buffer name. + +/usr2/lisp/nhem/bindings.lisp, 30-Jul-87 15:26:08, Edit by Chiles + Added binding for C-M-\L to "Illegal" in "Echo Area" mode. + +/usr2/lisp/nhem/line.lisp, 29-Jul-87 15:28:41, Edit by Chiles + Rob documented the line defstruct, eliminating the chars slot in favor of + always having the %chars slot. Added a macro for LINE-%CHARS instead of + symbol-function and symbol-plist hackery. + +/usr2/lisp/nhem/struct.lisp, 29-Jul-87 15:31:55, Edit by Chiles + Fixed documentation on COMMANDP. + +/usr2/lisp/nhem/echo.lisp, 28-Jul-87 16:26:44, Edit by Chiles + Merged some code from the Perq to fix up current buffer and window when + trying to confirm a non-existent parse. + +/usr2/lisp/nhem/bit-screen.lisp, 26-Jul-87 20:13:05, Edit by Chiles + Made SET-WINDOW-HOOK-RAISE-FUN look at the value of "Set Window Autoraise". + +/usr2/lisp/nhem/rompsite.lisp, 26-Jul-87 19:59:31, Edit by Chiles + Made EDITOR-SLEEP loop around SERVER using its timeout functionality + instead of busy looping. + +/usr2/lisp/nhem/lispeval.lisp, 26-Jul-87 20:04:08, Edit by Chiles + Made loop waiting for anonymous client lisp use EDITOR-SLEEP which loops + around SERVER. Before, the client Lisp could never connect since SERVER + was never being called. + + Wrote "Select Lisp Listener" command. + +/usr2/lisp/nhem/tty-display.lisp, 26-Jul-87 18:56:41, Edit by Chiles + Fixed display bug involving lines that are both new and changed (seen + often in the echo area for some reason). + +/usr2/lisp/nhem/filecoms.lisp, 25-Jul-87 19:37:16, Edit by Chiles + Fixed "Select Previous Buffer" to not call "Circulate Buffer" since it + doesn't exist. + +/usr2/lisp/nhem/macros.lisp, 25-Jul-87 18:30:59, Edit by Chiles + Made LISP-ERROR-ERROR-HANDLER have an E command that reports the + condition it was called on in a pop-up window. + +/usr2/lisp/nhem/lispeval.lisp, 25-Jul-87 19:28:23, Edit by Chiles + Made FILE-COMPILE use a temporary output file for compiler output when + its ouput-file argument is not t. This temporary file is publicly + writeable in case the eval server is running on another machine. + +/usr2/lisp/nhem/edit-defs.lisp, 25-Jul-87 19:25:32, Edit by Chiles + Made "Go to Definition" and "Edit Definition" use the client Lisp to + determine where something is defined. Had to restructure the code + significantly, but it can be put back to non-eval-server functionality + easily and cleanly. + +/usr2/lisp/nhem/bindings.lisp, 23-Jul-87 11:07:22, Edit by Chiles + Added bindings for "Process Control", "Editor Evaluate Expression", and + "Select Lisp Listener". + +Rompsite.Lisp, while doing eval-server, Edit by Chiles + Tty streams now loop over SERVER for input, so the eval-server stuff can + be used on terminals. There are a couple new functions for connection to + editor servers. + +Lispeval.Lisp, while doing eval-server, Edit by Chiles + This is a new file replacing a lot of commands in Lispbuf.Lisp with + similar commands that use the eval server interface. New in this file + from the Perq implementation is function description. + +Ts.Lisp, while doing eval-server, Edit by Chiles + This is a new file that implements the server side of the typescript + protocol. + +Morecoms.Lisp, while doing eval-server, Edit by Chiles + Made "Do Nothing", typically bound to up mouse clicks, propagate the last + command type (as if nothing happened). This was needed to make + super-rightup keep the command type of super-rightdown ("Insert Kill Buffer"). + +Keytran.Lisp, while doing eval-server, Edit by Chiles + Made shift-mouseclicks send super-mouseclick. + +Bindings.Lisp, while doing eval-server, Edit by Chiles + Addeds lots of new bindings and changed a few with respect to the + eval-server stuff going in. + +Bit-Screen.Lisp, while doing eval-server, Edit by Chiles + Fixed initial windows hook to keep echo area border visible on the screen + by hacking in another -2 pixels. This might be because X has by default + moves windows down from the top, so the top borders will show. + +/usr1/ram/lispmode.lisp, 01-Jul-87 12:04:59, Edit by Ram + Fixed Quest-For-Balancing-Paren to use the net-open and net-close information + correctly. It's silly to go to the trouble of computing this information, + and then (incorrectly) compute a paren balance by subtracting the two. + +/usr2/lisp/nhem/streams.lisp, 19-Jun-87 18:02:55, Edit by Chiles + Merged in some fixes from old Perq version. + +/usr2/lisp/nhem/lispbuf.lisp, 19-Jun-87 17:54:25, Edit by Chiles + Changed the following command names to be prefixed by "Editor ": + "Editor Evaluate Defun" + "Editor Re-evaluate Defvar" + "Editor Evaluate Expression" + "Editor Compile Defun" + "Editor Compile Region" + "Editor Evaluate Region" + "Editor Evaluate Buffer" + "Editor Compile File" + "Editor Compile Group" + "Editor Describe Function Call" + "Editor Describe Symbol". + Removed old reference to KILL-TOP-LEVEL-INPUT-COMMAND in "Top-Level Eval". + +/usr2/lisp/nhem/killcoms.lisp, 19-Jun-87 17:39:34, Edit by Chiles + Wrote BUFFER-MARK which is to CURRENT-MARK as BUFFER-POINT is to + CURRENT-POINT. + +/usr2/lisp/nhem/filecoms.lisp, 16-Jun-87 23:25:52, Edit by Chiles + Removed the definition of the "Package" file option, placing a new + version in Lispbuf.Lisp. + +/usr2/lisp/nhem/srccom.lisp, 18-Jun-87 10:23:01, Edit by Chiles + Made "Compare Buffers" and "Merge Buffers" only handle the current region + in each buffer when the prefix argument is supplied. + +/usr2/lisp/nhem/bindings.lisp, 16-Jun-87 14:09:20, Edit by Chiles + Added bindings for super- characters. Added binding for + "Exit Hemlock". Added binding for "Circulate Buffer". + +/usr2/lisp/nhem/morecoms.lisp, 15-Jun-87 22:18:26, Edit by Chiles + Made "Do Nothing" set the last command type to its current value. + Added "Insert Kill Buffer". + +/usr2/lisp/nhem/echocoms.lisp, 15-Jun-87 13:47:15, Edit by Chiles + Made "Help on Parse" check for *parse-help* being nil. + +/usr2/lisp/nhem/bit-screen.lisp, 08-Jun-87 12:20:39, Edit by Chiles + Modified DEFAULT-CREATE-INITIAL-WINDOWS-HOOK to added in a couple more + border widths, so the echo area's bottom border is visible. + +************************* + +/usr1/lisp/hemlock/rompsite.lisp, 03-Jun-87 10:09:24, Edit by DBM. + All references to the accint package have been changed to Mach. + +/usr1/lisp/hemlock/obit-screen.lisp, 03-Jun-87 10:05:34, Edit by DBM. + All references to the accint package have been changed to Mach. + +/usr2/lisp/nhem/tty-display.lisp, 01-Jun-87 21:25:15, Edit by Chiles + Modified TTY-SMART-WINDOW-REDISPLAY to punt insert/delete line + optimizations in favor of redrawing every altered line when "Scroll + Redraw Ratio" is exceeded. + +/usr2/lisp/nhem/command.lisp, 01-Jun-87 21:12:21, Edit by Chiles + "Scroll Redraw Ratio" is a new Hemlock variable that controls the + abortion of insert/delete line optimization in terminal redisplay in + favor of redrawing all altered lines. This is used in Tty-Display.Lisp. + +/usr2/lisp/nhem/tty-display.lisp, 27-May-87 14:38:50, Edit by Chiles + Wrote TTY-SMART-CLEAR-TO-EOW to use the internal screen image instead of + TTY-SEMI-DUMB-WINDOW-REDISPLAY and TTY-SMART-WINDOW-REDISPLAY using the + clear-to-eow method that clears every line disregarding internal + information. + +/usr2/lisp/nhem/rompsite.lisp, 26-May-87 16:14:27, Edit by Chiles + Modified EDITOR-TTY-IN to detect lowercase control g's. + +/usr2/lisp/nhem/bit-screen.lisp, 25-May-87 17:40:30, Edit by Chiles + Modified arguments to X window event handlers as per the changes in + X.Lisp. + +/usr1/ram/spellcoms.lisp, 22-May-87 04:02:19, Edit by Ram + Fixed Fix-Word to bump the mark in the all uppercase case even when the word + is already in the hashtable. + +/usr1/ram/echo.lisp, 14-May-87 13:07:07, Edit by Ram + Changed Message to use displayed-p on the buffer end to tell whether the echo + area needs to be cleared rather than just counting the lines. This works + much better in the presence of wrapped lines. + +/usr1/ram/cursor.lisp, 14-May-87 13:02:09, Edit by Ram + Changed renamed Display-P to %Displayed-P, and wrote Displayed-P which does + an update-window-iamge before calling %Displayed-P. + +/usr2/lisp/xhem/xcommand.lisp, 12-May-87 16:00:16, Edit by Chiles + This is a new file of X specific commands. Currently it only contains + "Insert Cut Buffer" and "Region to Cut Buffer". + +/usr2/lisp/xhem/keyboard_codes.lisp, 12-May-87 15:55:42, Edit by Chiles + Modified some translations to work better with the new key bindings. + +/usr2/lisp/xhem/lispbuf.lisp, 12-May-87 14:43:15, Edit by Chiles + Added "List Compile File" and "Re-evaluate Defvar". + +/usr2/lisp/xhem/command.lisp, 12-May-87 14:07:11, Edit by Chiles + Modified "Self Insert" and "Quoted Insert" to handler new TEXT-CHARACTER + in Rompsite.Lisp. + +/usr2/lisp/xhem/morecoms.lisp, 12-May-87 14:01:29, Edit by Chiles + Made "List Buffers" on a prefix argument list only modified buffers. + +/usr2/lisp/xhem/main.lisp, 12-May-87 12:55:51, Edit by Chiles + Stopped ED from calling REDISPLAY-ALL when the editor has been entered + already and moved this into the device init methods that require this. + +/usr2/lisp/xhem/lispmode.lisp, 12-May-87 12:53:32, Edit by Chiles + Blasted a couple bogus type declarations on some DEFSTRUCT slots. + Inserted a few lines to LISP-INDENTATION from my init file. + +/usr2/lisp/xhem/indent.lisp, 12-May-87 12:48:29, Edit by Chiles + Replaced a couple SCAN-CHAR and REV-SCAN-CHAR uses with FIND-ATTRIBUTE + and REVERSE-FIND-ATTRIBUTE, so compilation in a Lisp without Hemlock + wouldn't lose. + +/usr2/lisp/xhem/filecoms.lisp, 12-May-87 12:42:08, Edit by Chiles + Renamed "New Window" to "Split Window", and made "New Window" prompt the + user for a window. + +/usr2/lisp/xhem/charmacs.lisp, 12-May-87 12:24:05, Edit by Chiles + Modified character name a-list. Rob Flushed addition of the command-bits + feature and added the all-bit-names constant. + +/usr2/lisp/xhem/window.lisp, 12-May-87 11:47:35, Edit by Chiles + This contains the stuff we still need from Owindow.Lisp and some new + stuff brought over from the Perq. + +/usr2/lisp/xhem/tty-screen.lisp, 12-May-87 11:43:55, Edit by Chiles + Modified to fit the new device independent structure, adding beep and + finish-output methods. Creating and Deleting window methods now set + *screen-image-trashed since not all devices need this. Random typeout + methods got an extra argument that we ignore. + +/usr2/lisp/xhem/struct.lisp, 12-May-87 11:37:25, Edit by Chiles + Modified window, dis-line, and font structures. When the old bitmap + stuff goes away, so will a few slots of windows. Also, some old setf + stuff for old font information will go away. + +/usr2/lisp/xhem/screen.lisp, 12-May-87 11:34:06, Edit by Chiles + Modified to be once-again device independent with respect to the addition + of Hemlock running under X windows. MAKE-WINDOW and DELETE-WINDOW no + longer set *screen-image-trashed* since this isn't necessary for all + devices. + +/usr2/lisp/xhem/rompsite.lisp, 12-May-87 00:56:01, Edit by Chiles + SITE-INIT is all new and defines some Hemlock variables for controlling + some of the X activity. INIT-RAW-IO is much bigger now for initializing + stuff when we are running under X. *editor-windowed-input* is set to t + when we are running under X, and WINDOWED-MONITOR-P returns the value of + this variable for use is other files. + + BEEP was moved to Code:Machio.Lisp, and there's a couple different + beeping methods in here now that get called as a result of + *beep-function* being bound by SITE-WRAPPER-MACRO. HEMLOCK-WINDOW calls + *hemlock-window-mngt* when *current-window* is bound, which happens going + in and out of Hemlock. + + The X scan code translation mechanism lives here, but the initialization + is in Keytran.Lisp. Terminal translation now downcases control + characters to interact more smoothly with the new Hemlock key translation + and binding scheme. + + There are now different types of editor input streams that all a head and + tail pointer into an input queue of events. One is used for terminals + and flat bitmap screens, and the other uses SERVER for windowed input + under X. TEXT-CHARACTER is new and now more correct. + + There is a page of X support: getting a Hemlock cursor, setting up a grey + pixmap for border frobbing, cut buffer manipulation, and naming windows. + +/usr2/lisp/xhem/owindow.lisp, 12-May-87 00:52:54, Edit by Chiles + This file used to be Window.Lisp. It now contains only the old bitmap + related code for setting up a windows image. + +/usr2/lisp/xhem/ofont.lisp, 12-May-87 00:51:35, Edit by Chiles + This file used to be Font.Lisp. It now contains only the few things + necessary for old bitmap font interfacing. + +/usr2/lisp/xhem/obit-screen.lisp, 12-May-87 00:43:50, Edit by Chiles + This file used to be Screen-Bit.Lisp. Shared stuff has been moved to + the new file by the old name. Window creation and deletion methods now + set *screen-image-trashed* since this is not meaningful across all + devices. + +/usr2/lisp/xhem/obit-display.lisp, 12-May-87 00:40:35, Edit by Chiles + This file used to be Bit-Display.Lisp. Shared stuff has been moved to + the new file by the old name. + +/usr2/lisp/xhem/macros.lisp, 12-May-87 00:35:30, Edit by Chiles + WITH-RANDOM-TYPEOUT has been modified to handle new termination + functionality involved with running Hemlock under X. + LISP-ERROR-ERROR-HANDLER no longer calls REDISPLAY after returning from a + BREAK. This is the responsibility of the device's init method if it is + necessary. + +/usr2/lisp/xhem/keytran.lisp, 12-May-87 00:30:18, Edit by Chiles + This is a new file. It contains the initialization of the keyboard + translations for Hemlock running under X. These were too numerous to + leave in Rompsite since there is no hack for generating the translations. + +/usr2/lisp/xhem/hunk-draw.lisp, 12-May-87 00:28:02, Edit by Chiles + This is a new file, a kin to Pane.Lisp. It contains screen painting + routines for Hemlock running under X windows. This includes cursor and + border manipulation. + +/usr2/lisp/xhem/font.lisp, 12-May-87 00:12:10, Edit by Chiles + This is a new file, replacing the currently named Ofont.Lisp. It + contains the pseudo-independent Hemlock font information implementation. + This includes stuff particular for running Hemlock under X windows and + stuff that is used by the other bitmap redisplay/screen manager code. + +/usr2/lisp/xhem/display.lisp, 12-May-87 00:09:23, Edit by Chiles + The device structure has been modified to handle new methods, such as + beeping and finishing output. The device-clear method is now optional. + The entry points into redisplay have been modified to encorporate the + needs of Hemlock running under X windows. + +/usr2/lisp/xhem/bit-screen.lisp, 11-May-87 23:16:26, Edit by Chiles + This is a new file, replacing the currently named Obit-Screen.Lisp. It + contains the event handlers for selected events on Hemlock windows, the + screen management methods for Hemlock running under X windows, the random + typeout methods, and screen manager initialization. + +/usr2/lisp/xhem/bit-hunk-stream.lisp, 11-May-87 22:43:36, Edit by Chiles + This is a new file. It contains the bitmap-hunk-output-stream structure + definition and the associated methods. This is used for random typeout. + +/usr2/lisp/xhem/bit-display.lisp, 11-May-87 22:38:47, Edit by Chiles + This is a new file, replacing the currently named Obit-Display.Lisp. It + contains the bitmap-hunk structure and the X related redisplay methods.d + +/usr1/ram/cursor.lisp, 08-May-87 05:02:09, Edit by Ram + Totally rewrote dis-line-offset-guess, making it dramatically simpler and + more correct by making it do only what is needed for the scrolling functions, + rather than attempting to make it preserve position within the line. + +/../chiles/usr/lisp/hemlock/bindings.lisp, 29-Apr-87 23:33:27, Edit by Ram + Massively revised bindings now that we have key-translations and a real meta + key. C-Z and Escape are now handled as bit-prefix characters, so all + explicit bindings containing these have been flushed. Key translations are + used to make things case-insensitive, so duplicate bindings for different + case have been flushed. + + All the C-/Escape bindings pairs have been + replaced with M-. This is the main user-interface change. Also + the commands previously bound to C-Z M- have been rebound to C-M- + (i.e. control meta shift). This is necessary since C-Z M- is just + C-M- due to the bit prefix mechanism. We selectively flush the + uppercasing translation for the control meta chars used in this way. + + In a more rt-specific change, uses of Help have been replaced with Home. + +/usr/ram/interp.lisp, 30-Apr-87 00:36:04, Edit by Ram + New Key-Translation mechanism replaces key links. A key translation + specifies a substitution that is done one key arguments to the bindings + functions. When the translated-from key appears as a subsequence of the key + to be translated, that subsequence is replaced with the translation. There + is also a mechanism for defining bit-prefix characters. + + The key-table code has been changed a fair amount. Key-tables are now + structures. The conditionalization off of the commands-bits feature has been + flushed. Keys are no longer internally assumed to be simple-vectors so that + we can use vectors with fill-pointers as internal buffers. + + Also put in a few doc strings and made crunch-key allow any seqence and check + that the components are characters. The type check was in the PERQ version + but got lost. + +/usr/ram/spellcoms.slisp, 12-Apr-87 10:57:44, Edit by Ram + Fixed Spell-Replace-Word not to consider words beginning with #\' to be + capitalized. + +/../wb1/usr/chiles/nhem/lispmode.slisp, 04-Apr-87 22:44:36, Edit by Chiles + Modified "Transpose Forms" such that + (form1) ;comment + (form2) + became + (form2) ;comment + (form1) + instead of + ;comment + (form2) (form1) + +/../wb1/usr/chiles/nhem/tty-display.slisp, 26-Mar-87 18:51:40, Edit by Chiles + Fixed bug in TTY-SEMI-DUMB-WINDOW-REDISPLAY and + TTY-SMART-WINDOW-REDISPLAY that came up when writing the modeline. Put + in an UNWIND-PROTECT around TTY-SMART-LINE-REDISPLAY since it can throw + out of redisplay leaving the terminal in standout mode. + +/../wb1/usr/chiles/nhem/htext1.slisp, 26-Mar-87 18:10:15, Edit by Chiles + Modified MODIFYING-BUFFER to invoke new "Buffer Modified Hook" when the + buffer went from unmodified to modified. + +/../wb1/usr/chiles/nhem/main.slisp, 26-Mar-87 17:49:12, Edit by Chiles + Added definition for "Buffer Modified Hook" and changed definition for + "Default Modeline String". + +/../wb1/usr/chiles/nhem/window.slisp, 26-Mar-87 17:37:32, Edit by Chiles + Made %INIT-REDISPLAY add QUEUE-BUFFER-CHANGES to new "Buffer Modified Hook". + Made DEFAULT-MODELINE-FUNCTION-FUNCTION return one more value, whether + the buffer is modified. + +/../wb1/usr/chiles/nhem/buffer.slisp, 26-Mar-87 18:14:08, Edit by Chiles + Made %SET-BUFFER-MODIFIED to invoke new "Buffer Modified Hook" on sense. + +/usr1/ram/group.slisp, 20-Mar-87 14:10:56, Edit by Ram + Changed the "Group Search" commands to feel more like the "Query Replace" + commands. :Yes now exits instead of skipping, skipping is moved to :No and + skipping the rest of the file is move to :Do-All. + +/usr/ram/searchcoms.slisp, 19-Mar-87 00:04:09, Edit by Ram + Changed query-replace-function to set up the search pattern itself. Also + made it error if the count is specified and negative, rather than trying to + do replacement backwards and getting it wrong. Also restore the search + pattern after a recursive edit. + +/usr/ram/group.slisp, 19-Mar-87 00:31:13, Edit by Ram + Fixed up a bunch of things. Indirect filespecs are parsed normally; it is no + longer assumed that the rest of the line is the name of the file. The + default file name is no longer capitalized. Temporary search buffers are no + longer renamed to "Group Search", making exiting from searches more + well-defined. "Group Search" restores the search pattern after a recursive + edit. + +/usr/lisp/nhem/lispmode.slisp, 12-Mar-87 16:05:30, Edit by Chiles + Rewrote TOP-LEVEL-OFFSET to be correct and to not move the mark unless it + could really do the offset. Modified INSIDE-DEFUN-P to not return t when + point is between a top level form and the beginning of the buffer. Added + START-DEFUN-P to be used in heavily modified versions of "End of Defun" + and "Mark Defun" commands. + +/../wb1/usr/chiles/nhem/lispmode.slisp, 03-Mar-87 17:33:05, Edit by Chiles + Fixed LISP-INDENTATION to do a "generic" indent instead of simply + returning 0. This fixes doc strings. + +/../wb1/usr/chiles/nhem/indent.slisp, 27-Feb-87 14:18:59, Edit by Chiles + Fixed "Indent" command to only affect argument number of lines (instead + of one too many) when the prefix argument is supplied. Rewrote + INDENT-REGION-FOR-COMMANDS to be much simpler, fixing a couple + irritatingly buggy special cases. + +/../wb1/usr/chiles/nhem/fill.slisp, 27-Feb-87 12:18:50, Edit by Chiles + Fixed "Fill Paragrah" command's undoability. When a prefix was added to + the first line, it was ignored by the undo region do to a :left-inserting + mark. + +/usr1/ram/text.slisp, 23-Feb-87 11:00:53, Edit by Ram + The "Paragraph Delimiter Function" variable is now used to determine whether + a line is a paragraph break. This is used by Scribe mode. + +/usr1/ram/spellcoms.slisp, 23-Feb-87 10:52:18, Edit by Ram + "Spell Correct Unique Spelling Immediately" (on by default) causes an unknown + word with only one correction to be corrected immediately in auto-spell mode, + rather than requiring "Correct Last Misspelled Word" to be done. + + The "Undo Last Spelling Correction" command undoes the last incremental + spelling correction and places the word in the dictionary. + + "Spell Ignore Uppercase" (off by default) causes all-uppercase unknown words + to be ignored. + +/usr1/ram/defsyn.slisp, 23-Feb-87 10:50:01, Edit by Ram + Changed definition of "Lisp Syntax" attribute for new Lisp mode primitives. + +/usr1/ram/lispbuf.slisp, 23-Feb-87 10:48:54, Edit by Ram + Changed to use new Lisp mode primitives. + +/usr1/ram/htext1.slisp, 23-Feb-87 10:19:19, Edit by Ram + Deleted old line-plist support. The user directly accesses the Plist slot + now that he is responsible for keeping treack of when it changes. + +/usr1/ram/line.slisp, 23-Feb-87 10:17:30, Edit by Ram + Merged in code to implement the documented line-plist/line-signature + semantics. This code somehow never got merged in from the PERQ version. + +/usr1/ram/scribe.slisp, 20-Feb-87 16:25:07, Edit by Ram + A real Scribe mode. Has general bracket balancing, and knows about paragraph + boundaries. Also various commands for inserting Scribe directives bound to + C-H mumble. + +/usr1/ram/bindings.slisp, 20-Feb-87 14:22:45, Edit by Ram + New bindings for "Undo Last Spelling Correction" and Scribe mode commands. + +/usr1/ram/lispmode.slisp, 18-Feb-87 11:42:22, Edit by Ram + New Lisp mode primitives, courtesy of Ivan (Crash and burn like an unblanced + paren Vazquez. These primitives know about Lisp commenting and quotation + conventions, and ignoring meaningless parens and quotes. This is done by + pre-parsing the lines in the buffer, annotating them with information about + the quoted areas on the line. Forward-Form and Backward-Form are gone, + replaced by Form-Offset. Similarly, Forward-List and Backward-List are + replaced by List-Offset. + + All users of these Lisp parsing primitives must call Pre-Command-Parse-Check + or equivalent to ensure that the buffer is properly annotated. This function + calls the values of "Parse Start Function" and "Parse End Function" to + determine the area of the buffer to parse. The default parse start and end + functions use "Minimum Lines Parsed", "Maximum Lines Parsed" and + "Defun Parse Goal" to determine how much stuff to parse. + + I also reimplemented Lisp indentation. Other than general cleanup, use of + newly avilable syntax information, and bug fixes, the major changes are: + -- Unless there is a reason otherwise, indentation for a form will be copied + from the previous form. + -- If no special args appear on the same line with the form name, then the + special args are indented four spaces. This is useful with + Unwind-Protect and Multiple-Value-Bind. + -- DEFxxx is now uniformly treated as a two-arg special form, rather than + being bizzarely special-cased. "Indent Defanything" controls this + behavior. + -- Lines in the middle of a quoted string are not indented, rather than + being indented as though they were lines of code. This eliminates + spurious whitespace in multi-line strings. + +/usr/lisp/hemlock/termcap.slisp, 17-Feb-87 12:04:32, Edit by Chiles + Made GET-TERMCAP handle TERMCAP environment variable. + +/usr/lisp/hemlock/rompsite.slisp, 17-Feb-87 11:48:16, Edit by Chiles + Modified SITE-WRAPPER-MACRO to call init/exit methods out of the device. + EDITOR-LISTEN now loops a parameter number of times which can be set when + using a slow line to make sure the editor listens for input before + wasting redisplay effort. + +/usr/lisp/hemlock/tty-display.slisp, 16-Feb-87 17:05:01, Edit by Chiles + Added "semi dumb" terminal redisplay. This is used for terminals without + add line and delete line. Made INIT-TTY-DEVICE (renamed) and + EXIT-TTY-DEVICE (renamed) call standard init/exit function from + Rompsite.Slisp. + +/usr/lisp/hemlock/macros.slisp, 14-Feb-87 01:33:08, Edit by Chiles + Made LISP-ERROR-ERROR-HANDLER call init/exit methods out of the device + when going in and out of Hemlock. + +/usr/lisp/hemlock/bit-screen.slisp, 14-Feb-87 01:08:15, Edit by Chiles + Added INIT-BITMAP-DEVICE and EXIT-BITMAP-DEVICE. Now whenever the editor + is exited or entered there is a method to be called in the device + structure. + +/usr/lisp/hemlock/main.slisp, 14-Feb-87 00:27:47, Edit by Chiles + Made ED reflect new SITE-WRAPPER-MACRO in Rompsite.Slisp. + +/usr/lisp/hemlock/tty-screen.slisp, 14-Feb-87 00:13:44, Edit by Chiles + Modified MAKE-DEVICE to reflect new "semi dumb" redisplay ability. + +/usr/lisp/hemlock/rompsite.slisp, 12-Feb-87 13:02:40, Edit by DBM. + A bug in get-editor-input was causing Hemlock to drop characters. + There used to be a (setq *events* before the (rplacd (last *events*... + +/usr/lisp/hemlock/rompsite.slisp, 10-Feb-87 15:58:23, Edit by DBM. + Modified all the unix package specifiers to be mach. + +/usr/lisp/hemlock/tty-display-rt.slisp, 10-Feb-87 15:54:04, Edit by DBM. + Modified all the unix package specifiers to be mach. + +/usr/lisp/hemlock/spell-rt.slisp, 10-Feb-87 15:52:41, Edit by DBM. + Modified all the unix package specifiers to be mach. + +/usr/lisp/hemlock/macros.slisp, 10-Feb-87 15:51:58, Edit by DBM. + Modified all the unix package specifiers to be mach. + +/usr/lisp/hemlock/files.slisp, 10-Feb-87 15:49:03, Edit by DBM. + Modified all the unix package specifiers to be mach. + +/usr/lisp/hemlock/rompsite.slisp, 14-Jan-87 14:20:03, Edit by DBM. + Wrapped a catch of redisplay-catcher around the redisplay form + in show-mark -- otherwise sometimes a bad throw would happen. + +/usr/lisp/hemlock/rompsite.slisp, 14-Jan-87 14:05:30, Edit by DBM. + Export pause-hemlock, so that the command works. + +/usr/lisp/hemlock/tty-hunk-stream.slisp, 14-Jan-87 11:58:52, Edit by Chiles + Fixed scrolling for random typeout -- forgot to local variable to line 0 + TTY-HUNK-STREAM-NEWLINE. + +/usr/lisp/hemlock/bit-screen.slisp, 13-Jan-87 16:45:31, Edit by DBM. + Modified bitmap-make-window so that it creates a bitmap-hunk + instead of device-hunk to describe the device. Also added the + arguments :device, :text-pane, and :modeline-pane to the call. + +/usr/lisp/hemlock/macros.slisp, 12-Jan-87 12:56:43, Edit by DBM. + Changed device-random-output-stream to device-random-typeout-stream. + +/usr/lisp/hemlock/tty-screen.slisp, 11-Jan-87 17:03:35, Edit by Chiles + This is a new file. It contains terminal screen management + initialization, device methods for window operations, and device methods + for random typeout. + +/usr/lisp/hemlock/tty-hunk-stream.slisp, 11-Jan-87 16:58:52, Edit by Chiles + This is a new file. It contains stream-hunk and tty-hunk-stream + structure definitions and stream operations. This is used for random + typeout. + +/usr/lisp/hemlock/tty-display.slisp, 10-Jan-87 15:35:09, Edit by Chiles + This is a new file. It contains terminal device structures, hunk + structures, and other structures needed for terminal redisplay methods. + +/usr/lisp/hemlock/tty-display-rt.slisp, 31-Dec-86 01:12:12, Edit by Chiles + This is a new file. It contains RT specific, terminal redisplay code. + +/usr/lisp/hemlock/termcap.slisp, 11-Jan-87 16:36:33, Edit by Chiles + This is a new file. It contains code for building a representation of + terminal capabilities from Unix termcap files. + +/usr/lisp/hemlock/screen.slisp, 11-Jan-87 16:30:31, Edit by Chiles + This is a new file. The previous contents are now in Bit-Screen.Slisp -- + see log entry below. This file contains new %INIT-SCREEN-MANAGER, + PREPARE-FOR-RANDOM-TYPEOUT, and RANDOM-TYPEOUT-CLEANUP functions, and it + contains new window operations that dispatch off the device structure -- + MAKE-WINDOW, NEXT-WINDOW, PREVIOUS-WINDOW, and DELETE-WINDOW. + +/usr/lisp/hemlock/rompsite.slisp, 11-Jan-87 16:06:26, Edit by Chiles + Organized file into logical partitions with page markers. Added + *editor-console-input* to be used in GET-EDITOR-INPUT, which should go + away when we are on a window system -- maybe a device method for + translating input characters or even getting them. Modified INIT-RAW-IO + to set *editor-console-input*. Modified SITE-WRAPPER-MACRO, so it does + not signal an error if it cannot find a bitmap device. Added terminal + character translation tables and TTY-TRANSLATE-CHAR. Added + SLEEP-FOR-TIME to be used in input stuff and SHOW-MARK. Rewrote + SHOW-MARK code to dispatch off of device. Added functions CONSOLEP and + GET-TERMINAL-NAME for use in Screen.Slisp. Modified BUILD-HEMLOCK to be + consistent with new files. + +/usr/lisp/hemlock/main.slisp, 11-Jan-87 16:00:36, Edit by Chiles + Modified ED to call any device init or exit function going in or out of + ED. + +/usr/lisp/hemlock/display.slisp, 11-Jan-87 14:35:16, Edit by Chiles + This is a new file. The previous contents are now in Bit-Display.Slisp -- + see log entry below. This file contains device structure definitions for + redisplay methods and device-hunk structure definitions for claiming + areas of the screens. It contains the entry points into redisplay. + +/usr/lisp/hemlock/bit-screen.slisp, 11-Jan-87 15:03:07, Edit by Chiles + Created from old Screen.Slisp. Removed functions MAKE-WINDOW, + NEXT-WINDOW, PREVIOUS-WINDOW, DELETE-WINDOW, PREPARE-FOR-RANDOM-TYPEOUT, + and RANDOM-TYPEOUT-CLEANUP putting them in the new Screen.Slisp. Added + bitmap device funs, bitmap-hunk structure definition, new initialization + function for bitmap screen management, new bitmap window operation + methods (make, delete, next, previous), and new random typeout setup and + cleanup for bitmaps. Deleted screen-hunk structure definition. + +/usr/lisp/hemlock/bit-display.slisp, 11-Jan-87 14:50:38, Edit by Chiles + Created file from old Display.Slisp. Removed functions REDISPLAY, + REDISPLAY-ALL, and REDISPLAY-WINDOWS-FROM-MARK putting them in the new + Display.Slisp. + +/usr/lisp/hemlock/window.slisp, 28-Dec-86 21:46:17, Edit by Chiles + Modified %REDISPLAY-INIT to initialize the device before calling + REDISPLAY-ALL. + +/usr/lisp/hemlock/macros.slisp, 18-Dec-86 17:14:25, Edit by Chiles + Rewrote WITH-RANDOM-TYPEOUT to grab the random typeout stream from the + device structure gotten from the current window. + +/usr/slisp/hemlock/macros.slisp, 22-Oct-86 22:11:22, Edit by Chiles + Error-error handler calls BREAK on the condition instead of the string + "Hemlock Debug". + +/usr/slisp/hemlock/rompsite.slisp, 22-Oct-86 22:01:22, Edit by Chiles + Setup for spell files. + +/usr/slisp/hemlock/spell-build.slisp, 22-Oct-86 17:48:02, Edit by Chiles +/usr/slisp/hemlock/spellcoms.slisp, 22-Oct-86 17:47:04, Edit by Chiles +/usr/slisp/hemlock/spell-augment.slisp, 22-Oct-86 17:46:21, Edit by Chiles +/usr/slisp/hemlock/spell-correct.slisp, 22-Oct-86 17:45:29, Edit by Chiles + The spelling correction stuff has been rewritten substantially. This is + the RT implementation. These files should be implementation independent, + modulo their use of Spell-Rt.Slisp. + +/usr/slisp/hemlock/spell-rt.slisp, 22-Oct-86 17:38:27, Edit by Chiles + Created this file to contain implementation dependent spelling code. + +/usr/slisp/hemlock/bindings.slisp, 22-Oct-86 17:35:48, Edit by Chiles + Used the new DO-ALPHA-CHARS macro from Charmacs.Slisp to do key linking. + Also, uncommented the spelling bindings. + +/usr/slisp/hemlock/edit-defs.slisp, 11-Oct-16 16:56:45, Edit by Chiles + Created this file to contain the stuff just removed from Lispmode.Slisp. + +/usr/slisp/hemlock/lispmode.slisp, 10-Oct-16 12:53:41, Edit by Chiles + Rewrote GET-DEFINITION-FILE to match longer, more specific directory + specification before matching shorter, less specific specifications. + Before it only matched whole directory namestrings. + + Removed all of the definition editing code form Lispmode.slisp. + +/sys/slisp/hemlock/echo.slisp#1, 08-Sep-86 01:15:37, Edit by Chiles +/sys/slisp/hemlock/macros.slisp#1, 08-Sep-86 01:15:37, Edit by Chiles + Made error handling stuff use the new error system. + +/sys/slisp/hemlock/morecoms.slisp#1, 27-Aug-86 10:51:27, Edit by Chiles + Modified "View Page Directory" and "Insert Page Directory" to be smarter + when creating a pop-up window and to be more general with respect to a + :page-delimiter character that is not also a :whitespace character. + +/sys/slisp/hemlock/filecoms.slisp#1, 26-Aug-86 16:18:09, Edit by Chiles + Modified WRITE-DA-FILE to display the buffer's name when prompting about + tacking a newline at the end of the file. + +/sys/slisp/hemlock/filecoms.slisp#1, 05-Aug-86 18:17:17, Edit by Chiles + Added *buffer-history-ptr* and modified "Select Previous Buffer" to walk + down *buffer-history* (when called repeatedly with an argument), selecting + successively previous buffers while leaving *buffer-history* unchanged. + +/sys/slisp/hemlock/Bindings.slisp#1, 26-Jul-86 10:57:47, Edit by Chiles + Added bindings: + (bind-key "Kill Previous Word" #\meta-backspace) + (bind-key "Echo Area Kill Previous Word" #\meta-backspace) + (bind-key "Complete Keyword" #\altmode :mode "Echo Area") + The last one is added in case you hit Esc, see nothing happened, and hit + it again. It doesn't hurt to bind this even if you have to hit Esc Esc + to get it to work. + +/sys/slisp/hemlock/lispmode.slisp#1, 25-Jul-86 11:49:43, Edit by Chiles + Fixed bug involving a comment starting after a function name and the + first argument being lined up with the comment instead of under the + function name; for example: + (cond (special-arg-p ; comment this cond branch + (first-thing-in-branch arg) + ...) + becomes + (cond (special-arg-p ; comment this cond branch + (first-thing-in-branch arg) + ...) + Note, this is somewhat kludged since a #|...|# comment will still + generate bogus indentation, but the whole LISP-INDENTATION algorithm + needs to be revamped anyway. + +/sys/slisp/hemlock/lispmode.slisp#1, 24-Jul-86 13:22:30, Edit by Chiles + "End of Defun" never worked since it was believed that MARK-AFTER was + enough to cause NEXT-TOP-LEVEL to move its argument mark, but actually + the use of LINE-OFFSET is required. + +/sys/slisp/hemlock/lispmode.slisp#1, 23-Jul-86 10:20:29, Edit by Chiles + Made LISP-INDENTATION check that the paren was on the start of a line + before doing the "DEF" hack with *indent-defanything*. + +/sys/slisp/hemlock/echo.slisp#1, 15-Jul-86 12:10:21, Edit by Chiles + Missed :trim argument to PROMPT-FOR-STRING while merging. + +08-Jul-86 + Merged most of Hemlock's changes on the Perq since the fall of 85. + Didn't try to pick up anything having to do with the eval server/ + two Lisps. The files things were taken from were: + abbrev.slisp + bindings.slisp + command.slisp + comments.slisp + echo.slisp + filecoms.slisp + fill.slisp + group.slisp + indent.slisp + kbdmac.slisp + killcoms.slisp + lispbuf.slisp + lispeval.slisp + lispmode.slisp + main.slisp + morecoms.slisp + overwrite.slisp + perqsite.slisp + scribe.slisp + searchcoms.slisp + text.slisp + undo.slisp + vars.slisp + window.slisp Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/hemlock.upd =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/hemlock.upd (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/hemlock.upd (revision 8058) @@ -0,0 +1,104 @@ +struct.lisp +struct-ed.lisp +rompsite.lisp +charmacs.lisp +key-event.lisp +keysym-defs.lisp +input.lisp +macros.lisp +line.lisp +ring.lisp +table.lisp +htext1.lisp +htext2.lisp +htext3.lisp +htext4.lisp +search1.lisp +search2.lisp +linimage.lisp +cursor.lisp +syntax.lisp +winimage.lisp +hunk-draw.lisp +@!bit-stream.lisp +termcap.lisp +display.lisp +bit-display.lisp +tty-disp-rt.lisp +tty-display.lisp +@!tty-stream.lisp +pop-up-stream.lisp +screen.lisp +bit-screen.lisp +tty-screen.lisp +window.lisp +font.lisp +interp.lisp +vars.lisp +buffer.lisp +files.lisp +streams.lisp +echo.lisp +main.lisp +echocoms.lisp +defsyn.lisp +command.lisp +morecoms.lisp +undo.lisp +killcoms.lisp +searchcoms.lisp +filecoms.lisp +indent.lisp +lispmode.lisp +comments.lisp +fill.lisp +text.lisp +doccoms.lisp +srccom.lisp +group.lisp +spell-rt.lisp +spell-corr.lisp +spell-aug.lisp +spell-build.lisp +spellcoms.lisp +abbrev.lisp +overwrite.lisp +gosmacs.lisp +ts-buf.lisp +ts-stream.lisp +eval-server.lisp +lispeval.lisp +lispbuf.lisp +kbdmac.lisp +icom.lisp +scribe.lisp +pascal.lisp +edit-defs.lisp +auto-save.lisp +register.lisp +xcoms.lisp +unixcoms.lisp +mh.lisp +highlight.lisp +dired.lisp +diredcoms.lisp +bufed.lisp +lisp-lib.lisp +completion.lisp +shell.lisp +debug.lisp +netnews.lisp +bindings.lisp +compilation.order +things-to-do.txt + +@! Files that don't get compiled, but you'd expect to be listed in a .upd file. +@! +@! .../tools/hemcom.lisp +@! .../tools/hemload.lisp +@! ed-integrity.lisp +@! hi-integrity.lisp +@! hemlock.log +@! perq-hemlock.log +@! hemlock.upd +@! Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/notes.txt =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/notes.txt (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/notes.txt (revision 8058) @@ -0,0 +1,27 @@ +(defcommand "Find File From Sources" (p) + "" "" + (declare (ignore p)) + (let ((point (current-point))) + (with-mark ((start point) + (end point)) + (find-file-command + nil + (merge-pathnames "src:" + (region-to-string (region (line-start start) + (line-end end)))))))) + +* abbrev.lisp +* doccoms.lisp +* echo.lisp +* echocoms.lisp +* filecoms.lisp +* lisp-lib.lisp ;Blew away help command, should do describe mode. +* lispbuf.lisp +* lispeval.lisp ;Maybe write MESSAGE-EVAL_FORM-RESULTS. +* macros.lisp <<< Already changed in WORK: +* mh.lisp <<< Ask Bill about INC in "Incorporate New Mail". +* morecoms.lisp +* register.lisp +* scribe.lisp +* searchcoms.lisp +* spellcoms.lisp Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/perq-hemlock.log =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/perq-hemlock.log (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/perq-hemlock.log (revision 8058) @@ -0,0 +1,146 @@ +/Lisp2/Slisp/Hemlock/perqsite.slisp#1, 23-Mar-85 11:05:16, Edit by Ram + Made wait-for-more use logical-char=. + +/lisp2/slisp/hemlock/echocoms.slisp#1, 22-Mar-85 13:41:10, Edit by Ram + Made "Complete Keyword" and "Help on Parse" pass the parse default into + Complete-File and Ambiguous-Files, respectively. + +/Lisp2/Slisp/Hemlock/echocoms.slisp#1, 22-Mar-85 10:51:09, Edit by Ram + Updated to correspond to new prompting conventions. + +/Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 10:21:19, Edit by Ram + Changes to make defaulting work better. *parse-default* is now a string + which we pretend we read when we confirm an empty parse. + *parse-default-string* is now only used in displaying the default, as it + should be. The prompt and help can now be a list of format string and format + arguments. The feature of help being a function is gone. + +/Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 08:00:01, Edit by Ram + Made Parse-For-Something specify NIL to Recursive-Edit so that C-G's will + blow away prompts. + +/Lisp2/Slisp/Hemlock/buffer.slisp#1, 22-Mar-85 07:57:49, Edit by Ram + Added the optional Handle-Abort argument to recursive-edit so that we can + have recursive-edits that aren't blown away by C-G's. + +/Lisp2/Slisp/Hemlock/spellcoms.slisp#1, 22-Mar-85 07:35:01, Edit by Ram + Made Sub-Correct-Last-Misspelled-Word delete the marks pointing to misspelled + words when it pops them off the ring. + +/lisp2/slisp/hemlock/syntax.slisp#1, 18-Mar-85 07:20:53, Edit by Ram + Fixed problem with the old value not being saved if a shadow-attribute was + dowe for a mode that is currently active. + +/lisp2/slisp/hemlock/defsyn.slisp#1, 14-Mar-85 09:42:53, Edit by Ram + Made #\. be a word delimiter by default. For old time's sake, it is not + a delimiter in "Fundamental" mode. + +/Lisp2/Slisp/Hemlock/filecoms.slisp#1, 13-Mar-85 00:25:19, Edit by Ram + Changed write-da-file not to compare write dates if the file desn't exist. + +/Lisp2/Slisp/Hemlock/perqsite.slisp#1, 13-Mar-85 00:15:31, Edit by Ram + Changed emergency message stuff to divide the message size by 8. + +/Lisp2/Slisp/Hemlock/htext2.slisp#1, 13-Mar-85 00:07:13, Edit by Ram + Changed %set-next-character to use the body of Modifying-Buffer. Made + string-to-region give the region a disembodied buffer count. + +/Lisp2/Slisp/Hemlock/htext3.slisp#1, 12-Mar-85 23:53:57, Edit by Ram + Changed everyone to use the body of modifying-buffer. + +/Lisp2/Slisp/Hemlock/htext1.slisp#1, 12-Mar-85 23:45:51, Edit by Ram + Made Modifying-Buffer have a body and wrap a without-interrupts around the + body. Changed %set-line-string to run within the body of modifying-buffer. + +/Lisp2/Slisp/Hemlock/echocoms.slisp#1, 12-Mar-85 23:28:40, Edit by Ram + Made "Confirm Parse" push the input before calling the confirm function so + that if it gets an error, you don't have to type it again. Also changed it + to directly return the default if there is empty input, rather than calling + the confirm function on the default string. It used to be this way, and I + changed it, but don't remember why. + +/Lisp2/Slisp/Hemlock/group.slisp#1, 12-Mar-85 23:10:43, Edit by Ram + Made group-read-file go to the beginning of the buffer, which is useful in + the case where the file was already read. + +/Lisp2/Slisp/Hemlock/lispbuf.slisp#1, 12-Mar-85 22:58:03, Edit by Ram + Made "Compile File" use buffer-default-pathname to get defaults for the + prompt. Added "Compile Group" command. + +/lisp2/slisp/hemlock/kbdmac.slisp#1, 09-Mar-85 20:53:33, Edit by Ram + Made default-kbdmac-transform bind *invoke-hook* so that recursive edits + don't try do clever stuff. + +/lisp2/slisp/hemlock/perqsite.slisp#1, 09-Mar-85 14:16:41, Edit by Ram + Changed editor-input stream to use new stream representation. Moved + Input-Waiting here from Streams, changed definition to return T or NIL + instead of number of chars. Made Wait-For-More not unread the character if + it is rubout. Made level-1-abort handler clear input. + +/lisp2/slisp/hemlock/streams.slisp#1, 09-Mar-85 14:59:02, Edit by Ram + Changed to use new stream representation. + +/lisp2/slisp/hemlock/pane-stream.slisp#1, 09-Mar-85 14:51:25, Edit by Ram + Changed to use new stream representation. + +/lisp2/slisp/hemlock/lispmode.slisp#1, 05-Mar-85 11:59:15, Edit by Ram + Changed the "Defindent" command to go to the beginning of the line before + doing the backward-up-list. This means that we always find the form + controlling indentation for the current line, rather than the enclosing form. + Do a "Indent For Lisp" after we redefine the indentation, since it presumably + changed. + +/lisp2/slisp/hemlock/spell-corr.slisp#1, 05-Mar-85 11:39:19, Edit by Ram + Fixed everyone to use gr-call. Made Correct-Spelling call + maybe-read-spell-dictionary, rather than trying to look at + *spell-opeining-return*. + +/lisp2/slisp/hemlock/spell-augment.slisp#1, 05-Mar-85 11:53:04, Edit by Ram + Fixed everyone to use gr-call and friends. + +/Lisp2/Slisp/Hemlock/command.slisp#1, 21-Feb-85 00:56:52, Edit by Ram + Edited back in change to "Scroll Next Window ..." commands to make them + complain if there is only one window. + +/Lisp2/Slisp/Hemlock/filecoms.slisp#1, 21-Feb-85 00:48:00, Edit by Ram + Edited back in changes: + Make "Backup File" message the file written. + Make Previous-Buffer return any buffer other than the current buffer + and the echo area buffer it there is nothing good in the history. + +/Lisp2/Slisp/Hemlock/bindings.slisp#1, 21-Feb-85 00:30:48, Edit by Ram + Removed spurious binding of #\' to "Check Word Spelling". + +/Lisp2/Boot/Hemlock/spellcoms.slisp#1, 05-Feb-85 13:58:54, Edit by Ram + Added call to Region-To-String in "Add Word to Spelling Dictionary" so that + it worked. + +/Lisp2/Boot/Hemlock/fill.slisp#1, 31-Jan-85 12:09:01, Edit by Ram + Made "Set Fill Prefix" and "Set Fill Column" define a buffer local variable + so that the values are buffer local. + +/Lisp2/Boot/Hemlock/fill.slisp#1, 26-Jan-85 17:19:57, Edit by Ram + Made / be a paragraph delimiter. + +/Lisp2/Boot/Hemlock/search2.slisp#1, 26-Jan-85 17:07:37, Edit by Ram + Fixed the reclaim-function for set search patterns to reclaim the set instead + of the search-pattern structure. + +/Lisp2/Boot/Hemlock/group.slisp#1, 25-Jan-85 22:07:15, Edit by Ram + Changed the way Group-Read-File works. We always use "Find File" to read in + the file, but if "Group Find File" is false, and we created a new buffer, we + rename the buffer to "Group Search", nuking any old buffer of that name. If + we are in the "Group Search" buffer when we finish, we nuke it and go to the + previous buffer. + +/Lisp2/Boot/Hemlock/macros.slisp#1, 25-Jan-85 22:35:26, Edit by Ram + Fixed Hlet so that it worked. Evidently nobody had used it before. + +/Lisp2/Boot/Hemlock/filecoms.slisp#1, 25-Jan-85 23:26:35, Edit by Ram + Made "Log Change" merge the buffer pathname defaults into the log file name. + Added the feature that the location for the point in the change log entry + template can be specified by placing a "@" in the template. + +/Lisp2/Boot/Hemlock/search2.slisp#1, 25-Jan-85 23:23:35, Edit by Ram + Fixed various one-off errors in the end args being passed to position and + %sp-find-character-with-attribute. Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/things-to-do.txt =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/things-to-do.txt (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/misc/things-to-do.txt (revision 8058) @@ -0,0 +1,630 @@ +-*- Mode: Text; Package: Hemlock; Editor: t -*- + + + + +;;;; X problems. + +Compute mininum width of a window group by taking the maximum of all the +windows' font-widths, each multiplied by minimum-window-columns. Right now it +just uses the default font or current window. + +Compute minimum window split correctly: look at current window's font-height +and new window's font-height, extra height pixels, whether each has a modeline, +and minimum-window-lines to determine if we can split the current window. + +Server not implementing DRAW-IMAGE-GLYPHS correctly, so we don't have to do our +pixmap hack. + + + + +;;;; Bill and/or Rob. + +Make editor-error messages; that is just make many of the (editor-error) +forms have some string to be printed. + Importance: often beeps and don't know why. + Difficulty: pervasive search for EDITOR-ERROR. + +Probably the ERROR for trying to modify a read-only buffer could/should be an +EDITOR-ERROR. Maybe the error message should be a Hemlock variable that can be +set for certain buffers or modes. + +Make definition editing different. Maybe only one command that offers some +appropriate default, requiring confirmation. Maybe some way to rightly know to +edit the function named under a #'name instead of the function name in a +function position. Think about whizzy, general definition location logging and +finding mechanism that is user extensible. + +Think about regular expression searching. + Importance: it would be used weekly by some and daily by others. + +Make illegal setting window width and height, (or support this). + +Think about example init file for randoms. It should show most of the simple +through intermediate customizations one would want to do starting to use +Hemlock. + setting variables + file type hooks + hooks + transposing two keys + changing modifiers + +DEFMODE should take a keyword argument for the modeline name, so "Fill" +could be named "Auto Fill" but show "Fill" in the modeline (similarly with +"Spell" and "Save"). + Importance: low. + Difficulty: low. + +Optional doc strings for commands? + Importance: suggested by a couple people. + Difficulty: ??? + +Get a real italic comment mode. + Importance: some people want it, like Scott. + Difficulty: hard to do right. + +Line-wrap-character a user feature? Per device? Per device set from Hvar? + Importance: a few people set this already for bitmap devices. + Difficulty: low. + Bill should just throw this in. + +When MESSAGE'ing the line of a matching open paren, can something be done to +make the exact open paren more pronounced -- SUBSEQ'ing the line string? + Importance: low + Difficulty: one line frob to major echo area changes. + +Do something about active region highlighting and blank lines. Consider +changing redisplay to be able to hack some glyph onto the line, a virtual +newline or something. + Importance: blank lines at the ends of the active region can be confusing. + Difficulty: unknown difficult changes to redisplay. + +Change redisplay on bitmaps to draw top down? Currently line writes are queued +going down the window image but the queue is written backwards. + Importance: low, two people commented on how it looks funny. + Difficulty: unknown, but probably little. + +Disallow tty I/O when the tty is in a bad state. Since editor is sharing +Unix standard input with *terminal-io*, doing reads on this is bad among +other problems. + Importance: necessary or non-experienced users. + Difficulty: slight. Error system wants to use *terminal-io* if you go + into a break loop from the editor. + Bill. + +Make Lisp indentation respect user indentation even when in a form with known +special arguments? + Importance: noticeable correctness. + Difficulty: Lucid wrote this already with LOOP macro. + Rob. +Make Lisp motion that exceeds the parsed region lose more gracefully by +informing the user, possibly offering to enlarge the parsing parameters. + Importance: very deceptive as it is currently. + Difficulty: ??? + Rob. +Lisp motion fails to handle correctly vertical bar syntax; for example, + package:|foo| + Importance: correctness, not too necessary + Difficulty: ??? +"Editor Evaluate Defun" does not handle multiple value returns correctly +... if we admit that this is often used to evaluate non-DEFUN top-level +forms. + Importance: user convenience. + Difficulty: low. + +Super-confirm select buffer. Super confirm means "make this be a legal +input". Has no interaction with prompting function interface. More +generally, make a *super-confirm-parse-function* that can be bound around +prompters. One suggestion when prompting for a buffer is to make it, but +another suggestion is to find file some appropriate file. + Importance: multiple people requested. + Difficulty: low. + Bill. +A super-confirm for a more facist "Find File" that disallowed creating buffers +when the file didn't exist could tell the command to really create the buffer. + +Displayed-p shouldn't directly call update-window-image, or perhaps uwi should +be changed to check if the ticks and whatnot indicate recomputation is needed. + Importance: minor efficiency hack and maybe a little cleaner. + Difficulty: low. + Bill. + +Fix line-length for hemlock output streams. The following example causes lines +to brek incorrectly in "Eval" mode but not in "Typescript" mode: + (defun dup (x n &aux r) (dolist (i n r) (push x r))) + (dup 'a 100) ;lines wrap due to faulty line breaking + (dup 'aa 100) ;lines wrap due to faulty line breaking + (dup 'aaa 100) ;now lines break correctly + Importance: correctness. It's not screwing anyone. + Difficulty: depends on what the right thing is. + +Termcap bug: + setenv TERMCAP "foobar:li#65:tc=vt102:" + set term = foobar +This causes an EOF unexpectedly on the string stream. This is because the +the termcap parsing stuff wasn't written to go all the way back to the top +entry point to determine what file to use when the TERMCAP variable had an +indirection. The code currently just goes to the beginning of the stream +and looks for the new tty name. + +Make prompt text not part of input buffer. Do some magical thing to solve +the problem of having special echo area commands that simply get around the +prompt text in the echo are buffer. + Importance: low sense problem is currently somewhat taken care of. + Possibly resolve problem when new Hemlock environment stuff + goes in. + Difficulty: Magical in origin. + Rob. + +Commonify everything. Make everything portable that could be made so (file +system extensions, character att. finding, string ops, etc.) and document +our expectations of the non-portable stuff we lean on. Provide portable +code for stuff done in assembler. + Some known problems: + %sp- functions aren't documented and don't have portable code for + them. + semantics of initial values versus declared type. + :error-file to COMPILE-FILE calls. + + Importance: cleanliness and portability ease for those who want our + code. + Difficulty: identify the problems and alter some code. + Bill and Rob. + +Fix things that keep text from getting gc'ed. Buffer local things keep +pointer to buffer. + Importance: could be important, maybe nothing is wrong. + Difficulty: identifying problems. + Bill or Rob. + +Two reproducible window image builder bugs: +THIS IS NUMBER ONE: +I wrote this command: + (defcommand "Fetch Input" (p) + "Does \"Point to Here\" followed by \"Reenter Interactive Input\"." + "Does \"Point to Here\" followed by \"Reenter Interactive Input\"." + (declare (ignore p)) + (point-to-here-command nil) + (reenter-interactive-input-command nil)) +I made the following bindings: + (bind-key "Fetch Input" #\hyper-leftdown :mode "Eval") + (bind-key "Fetch Input" #\hyper-leftdown :mode "Typescript") + (bind-key "Do Nothing" #\hyper-leftup :mode "Eval") + (bind-key "Do Nothing" #\hyper-leftup :mode "Typescript") +In an interactive buffer I typed hyper-leftdown twice on the same line and +got the following error: + Error in function HEMLOCK-INTERNALS::CACHED-REAL-LINE-LENGTH. + Vector index, 14700, out of bounds. +This index is always the one you get no matter what line of input you try to +enter twice. +;;; +THIS IS NUMBER TWO: +Put point at the beginning of a small defun that has at least some interior +lines in addition to the "(defun ..." line and the last line of the routine. +Mark the defun and save the region. Now, yank the defun, and note that the +beginning of the second instance starts at the end of the line the yanked copy +ends on. Now type c-w. You'll delete the yanked copy, and the lines that +should not have been touched at all end up with font marks. Interestingly the +first line of the defun and the last don't get any font marks. + Importance: well, they are reproducible, and they're pretty ugly. No one + has noticed these yet though. + Difficulty: Rob and I didn't conjure up the bugs after a casual inspection. + Bill AND Rob + +Consider a GNU-style undo where action is undo-able. + Importance: low, but people point it out as an inadequacy of Hemlock. + Difficulty: possibly very hard. Have to figure out what's necessary first. + Bill and Rob + + + +;;;; Mailer stuff. + +Find all message-info-msgs sets and refs, changing them from possible list +values to always be a simple-string value. Maybe must leave a list (or make +another slot) if I need to indicate that I can't use the value as a msg-id. +The only problem is coming through SHOW-PROMPTED-MESSAGE. This could pick or +something to really know if there were more than one message or not. + +Write "Refile Message and Show Next". + +Do something about message headers when reading mail. Suggestions include a +list of headers components that get deleted from the buffer and simply +scrolling the window past the "Received:" lines. + +Add more folder support and possibly something specific for Bovik groveling. +For example, rehashing the cached folder names and/or adding new ones from a +folder spec or root directory (allows adding the bovik folders). + +Consistency problems: + Expunging message should not JUST delete headers buffers and their + associated message buffers. There could be independent message buffers with + invalid message id's. Since these are independent, though, we might not + want to gratuitously delete them. + + "Headers Delete Message" should check for message buffers when virtual + message deletion is not used, deleting them I suppose. Instead of just + making headers buffers consistent. + + + + +;;;; Spelling stuff. + +This stuff is probably for Rob or Bill, but think about undergrad +dispatching before actually implementing it. + +Two apostrophes precede a punctuation character, as in: + ``This is a very common occurrence in TeX.'' +"Correct Buffer Spelling" complains that '' is an unknown word. The problem +doesn't show up if the character preceding the apostrophes is alphabetic. + +"Correct Last Misspelled Word" should try to transpose the space on the +ends of a word if there are more than one misspelling (adjacent?). This +would have to be done at the command level trying to correct different +words formed from the buffer. + +Fahlman would like to see a list of words that are treated as errors, even +though they may be in the dictionary. These are considered common typos made +that actually are rarely-used words. These would be flagged as errors for the +user to do a conscious double check on. + +When the spelling correction stuff cannot find any possible corrections, it +could try inserting a space between letters that still form legal words, +checking the two new words are in the dictionary. + Importance: possibly pretty useful, especially with "Spell" mode. + Difficulty: low to medium. + Bill, possibly undergrad after I looked at it. + +Fix "Undo Last Spelling" correction interaction with auto-fill. When this +command is invoked on a word that made auto-fill break the line, shit +happens. + Importance: Rob noticed it. + Difficulty: unknown. + Bill or Rob. + + + + +;;;; User and Implementors Manuals + +User Manual wall chart appendix based on systems (e.g., dired, mailer, Lisp +editing, spelling, etc.), then modes (e.g., "Headers", "Message", and "Draft"), +then whatever seems appropriate. + +Point out that "Make Buffer Hook" runs after mode setup. + + + + +;;;; Things for undergrads. + +Create "Remote Load File" and make "Load File" use it the way "Compile File" +uses "Remote Compile File". + +Make "Insert Scribe Directive" undo-able, and make the "command" insertion +stuff use the active region. Also, clean up terminology with respect to using +command and environment. + Importance: it would be nice. + Difficulty: little + +Add a feature that notes modified or new lines, probably down in +HI::MODIFYING-BUFFER. Then add interfaces for moving over these lines, moving +over text structures with these lines such as DEFUN's, paragraphs, etc. Write +commands that display these in some way, compile them, etc. + +Look at open paren highlighting and the Scribe bracket table stuff to make a +general bracket highlighter. Possibly have to call function based on mode or +something since Lisp parens are found differently than Scribe brackets (Lisp +parse groveling versus counting open and close brackets). + +Make hooks that are lists of function have list in the name, so users can know +easily whether to set this to a list or function. + Importance: low. + Difficulty: low, but pervasive. must be careful. + +Make FILTER-REGION not move all marks in the buffer to the end. It should +affect each line, letting marks stay on a line, instead of deleting the whole +region and inserting a new one. + Importance: low, but described behaviour is better than current behaviour. + Difficulty: low. + +Make some "Auto Save Access" variable, so users don't have to write fully +protected auto save files. Possibly there could be some variable to that +represents Hemlock's default file writing protection. + Importance: one person requested. + Difficulty: easy. + +Make "Save" mode on a first write or on startup check for a .CKP file. If it +is there and has a later write date than the file, warn the user before a save +could overwrite this file that potentially has good stuff in it from a previous +Lisp crash. + Importance: good idea, though people should know to check. + Difficulty: easier if done on start up. + +We need Lisp-like movement in Text mode -- skipping parenthetic and quoted +expressions while ignoring some Lisp syntax stuff. Either can write a few +commands that do what we expect, or we can get really clever with the +pre-command parse checking and bounds rules for Text mode. May even be able to +get the right thing to happen with code fragments in documents. + Importance: would be pretty convenient to have it work right all the time. + Difficulty: will take some thinking and playing around. Rob or Bill guidance. + +Make "Extended Command" offer a default of the last command entered. + +Make "Select Group" command take an optional argument for the group +pathname and group name. + Importance: convenience for init files. + Difficulty: low. + +Put in buffer percentage. + Importance: Lots of people want it. + Difficulty: Rob thinks he knows how to do it. + Rob will tell some undergrad how to do it. + +Make "Unexpand Abbrev" work when no expansion had been done -- test for +error condition was backwards. + +Add modeline display of current eval server and current compile server, when +appropriate. + Importance: suggested by a couple people. Low. + Difficulty: none. + Basically, just have to change string and function. + +Make "Corrected xxx to yyy" messages use actual case of yyy that was +inserted into the buffer. + Importance: more user friendly. + Difficult: low. + Anyone could do this, but it wouldn't be very educational for an + undergrad. + +"Find all Symbols" does a FIND-ALL-SYMBOLS on previous or current form if +it is a symbol. See code for "Where is Symbol" in Scott's +Hemlock-Init.Lisp file. + Importance: probably quite useful. + Difficulty: none. + Anyone could grab Scott's code. + +Make buffer read-only when visiting unwritable file? Bill and Scott +vehemently disagreed with this, but thought a variable would make everyone +happy. + Importance: one person suggested. + Difficulty: low. + Anyone could do this, but it wouldn't be very educational for an + undergrad. + +Modify MAKE-BUFFER to error when buffer exists? + Importance: more user friendly. + Difficulty: none. + Anybody could do this, but it wouldn't be very educational for an + undergrad. + +Warn when unable to rename a buffer according to its file. This occurs +when writing files. + Importance: more user friendly. + Difficulty: none. + Anyone could do this. +Uniquify buffer names by tacking a roman numeral on the end? + Importance: I don't know why this is here. + Difficulty: low. + Anyone could do this. + +Automatically save word abbrevs? + Importance: low. + Difficulty: low. + Some undergrad could do this. + +Automatically save named keyboard macros? Maybe on request? + Importance: other editors can do it. + Difficulty: this is non-trivial since our kbmacs are based on their own + little interpreter. + Medium undergrad task. + +Make nested prompts work. + Importance: some day this might be useful. + Difficulty: medium. + Upper level undergrad could do this. + +Make character searches deal with newlines. + Importance: correctness. + Difficulty: medium. + Upper level undergrad. + +Put argument type checks in the Hemlock primitives. + Importance: low, the compiler should do this from type declaration + (cool?!). + Difficulty: work in a lot of places. + Undergrad could do the things Rob or Bill say. + +Add a "Preferred File Types" to work in coordination with "Ignore File Types". + Importance: low, suggested by one user. + Difficulty: minimal. + +Write separate search and i-search commands that do case-sensitive searches, so +user's don't have to set the Hvar for one search. + Importance: low. + Difficulty: low. + +Add a write-region function which writes to a stream. + Importance: low. + Difficulty: medium. + Undergrad. + + + + +;;;; The great rewrite and cleanup. + +Compilation order. Cleanup up defvars, defhvars, proclaims, etc. for clean +compilation of Hemlock in a Lisp without one. Rename ED and HI packages +and start cleaning up compilation. Defvars should go near pertinent code, +and proclaims should do the rest. Do something about macros, rompsite, and +main. + Importance: necessary for those taking our code and sets better example. + Difficulty: few days of work. + Bill. + +Hemlock package cleanup -- exporting Hemlock stuff, so users don't live in +ED package. + Find primitives to export and describe in Command Implementor's Manual. + Export existing command names in a separate file. + DEFCOMMAND always interns in current package. + Variables + One global table. + DEFHVAR only at top level. Interns into current package. WHAT ABOUT SITE-INIT? + BIND-VARIABLE, a new form, will be used at top level or in setup + functions to establish default values. + Find all uses of FIND-PACKAGE, *hemlock-package*, etc. since these are + suspect in the new package regime. + Put DEFVAR's (esp. from Main.Lisp) in appropriate files, putting PROCLAIM's + in a single file or in files with compiler warnings. + Importance: really needs to be done along with environment stuff. + Difficulty: pervasive changes to get right. + Bill! + +Generalized environments: + Generalize notion of environment to first-class objects. + can inherit stuff from other environments. Shadowing for conflict + resolution. Transparent key bindings another sort of interaction. + If we retain modes as a primitive concept, then how do they interact? + If not, how do we get the effect? Each buffer has an environment. + This is normally the composition of the default environment and + various mode environments. + + Turning modes on and off is simply adding and removing the mode's environment + from the buffer's environment's inherit list. The only sticky issue is the + order of the inheritence. We could assign each environment a precedence. + + I guess we could punt modes as a primitive concept. The only thing this + wouldn't provide that modes do is a namespace and the major/minor + distinction. Setting the major mode is just frobbing the lowest precedence + environment in a buffer. A major mode is distinct from a minor mode in that + it inherits the global environment. An interesting question is at which + level precedences should be implemented. We could have it be a property only + of minor modes, which determines only the order in which a buffer inherits + its minor modes, or we could make it a property of environments, and have it + determine the total order of inheritance. Probably the former is better: it + simpler, and adequate. Also, at the environment level, it is more powerful + to be able to specify inheritance order on a per-case basis. + + Make mode-hooks be a mode-object slot rather than hemlock variables. [a + random cleanup] + + We change the (... &optional kind where) arguments to + (... &optional where). Where can be an environment such as + *global-environment* (the default) or a buffer, or it can be a string, in + which case it is interpreted as a mode name. + + Instead of having key binding transparentness be a property of modes or of + commands, we make it a property of binding. Each environment has separate + key-tables for transparent and opaque bindings, and there is a + Transparent-Bind-Key function that is used to make transparent key bindings. + [... or something. This would imply a delete-transparent-key-binding and + prehaps other functions, so we might consider passing a transparent flag to + the primitives.] + + *current-environment* is the current environment, which is normally eq to the + current buffer. Attributes and variables are implemented using deep-binding + and caching. Whenever there is any change to the inheritance structure or to + variable or attribute bindings, then we just totally flush all the caches. + The most frequent operation that would cause this to happen would be changing + a mode in a buffer, which is rare enough so that there should be no problem. + + For variables, we just have a symbol-name X environment => binding cache. + + For attributes we have two caches: attribute X environment => value vector + and attribute X environment X test-function => search vector. The first + translates an attribute and environment to a simple-vector that contains the + current value for each character in that environment. This is used for + Character-Attribute and when the Find-Attribute cache misses. When this + cache misses, we fill the vector with a magic "unspecified" object, and then + scan up the inheritance, filling in any bindings that are unspecified. We + could optimize this by noting in the character-attribute object when an + attribute has no shadowings. character-attribute hooks have to go away, + since they depends on shallow-binding. + + Make Hemlock variables be typed. Have a :type defhvar argument, + variable-type function. In implementation, create a test function for each + variable so that we can efficiently check the type of each assigned value. + This implies defhvar should be a macro. We could make specifying the test + function be an explicit feature, but the same effect could always be obtained + with a Satisfies type specfier. + + Split binding of hvars from definition. + Bind-Variable Symbol-Name Value &Optional Where + Creates a binding. If :Value is specified to defhvar, then it creates a + global binding of that value. If no :Value is specified, then there is no + global binding. We could flush the :Mode and :Buffer options, and require an + explicit Bind-Variable to be done in this case, or we could still allow them. + It would probably be better to flush them, since it would break code that is + doing run-time defhvars to make buffer-local variables. Perhaps we would + flush only :Buffer, since it is clearly useless, while being able to give an + initial mode binding may be useless. + + All variable attributes except for value are global. Hooks are global. The + concept of a hook is somewhat dubious in the presence of non-global bindings. + It might be semi-useful to invoke the hook on each new binding in addition to + on each set. + + Importance: Next big step for Hemlock. + Difficulty: Two months. + Bill will do this. + +Multiple font support: + Figure what kind of multi-font stuff we want to do. + Bogus to use integer constants for facecodes. It is reasonable within the + font mark, but the user interface should be keywords for facecodes. + Importance: no documented font support currently. Really need it. + Difficulty: includes massively reworking redisplay data structures. + Bill and Rob. + + + + +;;;; Things to think about. + +;;; These are things that have been thought of, but we don't know much more +;;; about them. + +Some general facility for users to associate definition locations with kinds of +things and/or forms. + +What's the right way to be in a comment in some Lisp file and have filling, +spelling, and whatever work out just right. Possibly regions with environment +information. Maybe with a whole new hierarchical text representation, this +would fall out. + +Synchronization/exclusion issues: + Currently there are non-modification primitives that are looking into a + buffer assuming it will not change out from under the primitive. We + need to identify these places and exactly what the nature of this + problem is (including whether it exists). Probably we need to make + non-trivial text examination primitives use without-interrupts so that + they see a consistent state. + + Find other places where exclusion is needed: + Redisplay? + Typescript code? + +Online documentation stuff: What to do and how to do it. Rob has some +notes on this from a year or two ago. + Importance: something to do. + Difficulty: high. + maybe no one. + +Think about general "Save My Editor State". Can generalize notion of +stateful things? -- Word abbrevs, keyboard macros, defindent, spelling +stuff, etc. This could be the last thing we ever do to Hemlock. + Importance: low. + Difficulty: very. + ??? + + + + +;;;; New Eval Servers + +Do something about slaves dieing in init files. Lisps start up and first load +init.lisp. When a slave does this, it goes into the debugger before connecting +to the editor. Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/NOTES =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/NOTES (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/NOTES (revision 8058) @@ -0,0 +1,13 @@ +Scribe Syntax + +The Syntax of Scribe is actually very nice. A command is always +introduced by #\@ followed by the command name and arguments delimited +by delimiters (sic). + +The following delimiter pairs are supported: + + { } [ ] < > ( ) " " ' ' + + + +$Id$ Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/README =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/README (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/scribe-converter/README (revision 8058) @@ -0,0 +1,12 @@ +This directory should eventually contain a scribe to HTML converter +using the same backend formatter as i used for the annotatable CLIM +manual. + +Since very rare information about Scribe is available, we'll work by +infering the neccessary information from the Scribe files we have at +hand, see file NOTES for details. + +$Id$ + + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/commands.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/commands.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/commands.mss (revision 8058) @@ -0,0 +1,822 @@ +@comment{-*- Dictionary: hem; Mode: spell; Package: Hemlock -*-} +@chap[Basic Commands] +@section[Motion Commands] + +@index[commands, basic]@index[motion]There is a fairly small number of +basic commands for moving around in the buffer. While there are many other +more complex motion commands, these are by far the most commonly used and +the easiest to learn. + +@defcom[com "Forward Character", bind (C-f, Rightarrow)] +@defcom1[com "Backward Character", bind (C-b, Leftarrow)] +@index[character, motion] +@hid[Forward Character] moves the point forward by one character. If a prefix +argument is supplied, then the point is moved by that many characters. +@hid[Backward Character] is identical, except that it moves the point +backwards. +@enddefcom + +@defcom[com "Forward Word", bind {M-f}] +@defcom1[com "Backward Word", bind {M-b}] +@index[word, motion]These commands move the point forward and backward +over words. The point is always left between the last word and first +non-word character in the direction of motion. This means that after moving +backward the cursor appears on the first character of the word, while after +moving forward, the cursor appears on the delimiting character. Supplying +a prefix argument moves the point by that many words. +@enddefcom + +@defcom[com "Next Line", bind (C-n, Downarrow)] +@defcom1[com "Previous Line", bind (C-p, Uparrow)] +@defcom1[com "Goto Absolute Line"] +@index[line, motion] +@hid[Next Line] and @hid[Previous Line] move to adjacent lines, while remaining +the same distance within a line. Note that this motion is by logical lines, +each of which may take up many lines on the screen if it wraps. If a prefix +argument is supplied, then the point is moved by that many lines. + +The position within the line at the start is recorded, and each successive +use of @binding[C-p] or @binding[C-n] attempts to move the point to that +position on the new line. If it is not possible to move to the recorded +position because the line is shorter, then the point is left at the end of +the line. + +@hid[Goto Absolute Line] moves to the indicated line, as if you counted them +starting at the beginning of the buffer with number one. If the user supplies +a prefix argument, it is the line number; otherwise, @Hemlock prompts the user +for the line. +@enddefcom + +@defcom[com "End of Line", bind {C-e}] +@defcom1[com "Beginning of Line", bind {C-a}] +@hid[End of Line] moves the point to the end of the current line, while +@hid[Beginning of Line] moves to the beginning. If a prefix argument is +supplied, then the point is moved to the end or beginning of the line that +many lines below the current one. +@enddefcom + +@defcom[com "Scroll Window Down", bind {C-v}] +@defcom1[com "Scroll Window Up", bind {M-v}] +@index[scrolling] +@hid[Scroll Window Down] moves forward in the buffer by one screenful of text, +the exact amount being determined by the size of the window. If a prefix +argument is supplied, then this scrolls the screen that many lines. When this +action scrolls the line with the point off the screen, it this command moves +the point to the vertical center of the window. @hid[Scroll Window Up] is +identical to @hid[Scroll Window Down], except that it moves backwards. +@enddefcom + +@defhvar[var "Scroll Overlap", val {2}] +This variable is used by @hid[Scroll Window Down] and @hid[Scroll Window Up] to +determine the number of lines by which the new and old screen should overlap. +@enddefhvar + +@defcom[com "End of Buffer", bind (M-<)] +@defcom1[com "Beginning of Buffer", bind (@bf[M->])] +These commands are used to conveniently get to the very beginning and end of the +text in a buffer. Before the point is moved, its position is saved by +pushing it on the mark stack (see page @pageref[marks]). +@enddefcom + +@defcom[com "Top of Window", bind (M-,)] +@defcom1[com "Bottom of Window", bind (M-.)] +@index[window, motion]@hid[Top of Window] moves the point to the beginning of +the first line displayed in the current window. @hid[Bottom of Window] moves +to the beginning of the last line displayed. +@enddefcom + + +@section[The Mark and The Region] + +@label[marks]@index[marks]@index[region]@index[selection]Each buffer has a +distinguished position known as the @i[mark]. The mark initially points to the +beginning of the buffer. The area between the mark and the point is known as +the @i[region]. Many @hemlock commands which manipulate large pieces of text +use the text in the region. To use these commands, one must first use some +command to mark the region. + +@index[active regions]Although the mark is always pointing somewhere (initially +to the beginning of the buffer), region commands insist that the region be made +@i[active] before it can be used. This prevents accidental use of a region +command from mysteriously mangling large amounts of text. + +@defhvar[var "Active Regions Enabled", val {t}] +When this variable is true, region commands beep unless the region is active. +This may be set to @false for more traditional @emacs region semantics. +@enddefhvar + +Once a marking command makes the region active, it remains active until: +@begin[itemize] +a command uses the region, + +a command modifies the buffer, + +a command changes the current window or buffer, + +a command signals an editor error, + +or the user types @binding[C-g]. +@end[itemize] +Motion commands have the effect of redefining the region, since they move the +point and leave the region active. + +@index[ephemerally active regions]Commands that insert a large chunk of +text into the buffer usually set an @i[ephemerally active] region around +the inserted text. An ephemerally active region is always deactivated by +the next command, regardless of the kind of command. The ephemerally +active region allows an immediately following region command to manipulate +the inserted text, but doesn't persist annoyingly. This is also very +useful with active region highlighting, since it visibly marks the inserted +text. + + +@defhvar[var "Highlight Active Region", val {t}] +@defhvar1[var "Active Region Highlighting Font", val {nil}] +When @hid[Highlight Active Region] is true, @hemlock displays the text in the +region in a different font whenever the region is active. This provides a +visible indication of what text will be manipulated by a region command. +Active region highlighting is only supported under @windows. + +@hid[Active Region Highlighting Font] is the name of the font to use for active +region highlighting. If unspecified, @hemlock uses an underline font. +@enddefhvar + + +@defcom[com "Set/Pop Mark", bind (C-@@)] +This command moves the mark to the point (saving the old mark on the mark +stack) and activates the region. After using this command to mark one end of +the region, use motion commands to move to the other end, then do the region +command. This is the traditional @emacs marking command; when running under a +windowing system with mouse support, it is usually easier to use the mouse with +the @comref[Point to Here] and @comref[Generic Pointer Up]. + +For historical reasons, the prefix argument causes this command to do things +that are distinct commands in @Hemlock. A prefix argument of four does +@hid[Pop and Goto Mark], and a prefix argument of @f[16] does +@hid[Pop Mark]. +@enddefcom + +@defcom[com "Mark Whole Buffer", bind (C-x h)] +@defcom1[com "Mark to Beginning of Buffer", bind (C-<)] +@defcom1[com "Mark to End of Buffer", bind (C->)] +@hid[Mark Whole Buffer] sets the region around the whole buffer, with the point +at the beginning and the mark at the end. If a prefix argument is supplied, +then the mark is put at the beginning and the point at the end. The mark is +pushed on the mark stack beforehand, so popping the stack twice will restore +it. + +@hid[Mark to Beginning of Buffer] sets the current region from point to the +beginning of the buffer. + +@hid[Mark to End of Buffer] sets the current region from the end of the buffer +to point. +@enddefcom + +@defcom[com "Activate Region", bind (C-x C-Space, C-x C-@@)] +This command makes the region active, using whatever the current position of +the mark happens to be. This is useful primarily when the region is +accidentally deactivated. +@enddefcom + + +@subsection[The Mark Stack] + +@index[mark stack]As was hinted at earlier, each buffer has a @i[mark stack], +providing a history of positions in that buffer. The current mark is the mark +on the top of the stack; earlier values are recovered by popping the stack. +Since commands that move a long distance save the old position on the mark +stack, the mark stack commands are useful for jumping to interesting places in +a buffer without having to do a search. + +@defcom[com "Pop Mark", bind (C-M-Space)] +@defcom1[com "Pop and Goto Mark", bind (M-@@, M-Space)] +@hid[Pop Mark] pops the mark stack, restoring the current mark to the next most +recent value. @hid[Pop and Goto Mark] also pops the mark stack, but instead of +discarding the current mark, it moves the point to that position. Both +commands deactivate the region. +@enddefcom + +@defcom[com "Exchange Point and Mark", bind (C-x C-x)] +This command interchanges the position of the point and the mark, thus moving +to where the mark was, and leaving the mark where the point was. This command +can be used to switch between two positions in a buffer, since repeating it +undoes its effect. The old mark isn't pushed on the mark stack, since it is +saved in the point. +@enddefcom + + +@subsection[Using The Mouse] + +@index[mouse]It can be convenient to use the mouse to point to positions in +text, especially when moving large distances. @hemlock defines several +commands for using the mouse. These commands can only be used when running +under @windows (see page @pageref[using-x].) + +@defcom[com "Here to Top of Window", bind (Rightdown)] +@defcom1[com "Top Line to Here", bind (Leftdown)] +@index[window, motion]@hid[Here to Top of Window] scrolls the window so as to +move the line which is under the mouse cursor to the top of the window. This +has the effect of moving forward in the buffer by the distance from the top of +the window to the mouse cursor. @hid[Top Line to Here] is the inverse +operation, it scrolls backward, moving current the top line underneath the +mouse. + +If the mouse is near the left edge of a window, then these commands do smooth +scrolling. @hid[Here To Top of Window] repeatedly scrolls the window up by one +line until the mouse button is released. Similarly, @hid[Top Line to Here] +smoothly scrolls down. +@enddefcom + +@defcom[com "Point to Here", bind (Middledown, S-Leftdown)] +This command moves the point to the position of the mouse, changing to a +different window if necessary. + +When used in a window's modeline, this moves the point of the window's buffer +to the position within the file that is the same percentage, start to end, as +the horizontal position of the mouse within the modeline. This also makes this +window current if necessary. + +This command supplies a function @hid[Generic Pointer Up] invokes if it runs +without any intervening generic pointer up predecessors executing. If the +position of the pointer is different than the current point when the user +invokes @hid[Generic Pointer Up], then this function pushes a buffer mark at +point and moves point to the pointer's position. This allows the user to mark +off a region with the mouse. +@enddefcom + +@defcom[com "Generic Pointer Up", bind (Middleup, S-Leftup)] +Other commands determine this command's action by supplying functions that +this command invokes. The following built-in commands supply the following +generic up actions: +@Begin[Description] +@hid[Point to Here]@\ + When the position of the pointer is different than the current point, the +action pushes a buffer mark at point and moves point to the pointer's position. + +@hid[Bufed Goto and Quit]@\ + The action is a no-op. +@End[Description] +@enddefcom + +@defcom[com "Insert Kill Buffer", bind (S-Rightdown)] +This command is a combination of @hid[Point to Here] and @comref[Un-Kill]. It +moves the point to the mouse location and inserts the most recently killed +text. +@enddefcom + + +@section[Modification Commands] +@index[commands, modification] + +There is a wide variety of basic text-modification commands, but once again the +simplest ones are the most often used. + +@subsection[Inserting Characters] +@index[character, insertion] +@index[insertion, character] + +In @hemlock, you can insert characters with graphic representations by typing +the corresponding key-event which you normally generate with the obvious +keyboard key. You can only insert characters whose codes correspond to ASCII +codes. To insert those without graphic representations, use @hid[Quoted +Insert]. + +@defcom[com "Self Insert"] +@hid[Self Insert] inserts into the buffer the character corresponding to the +key-event typed to invoke the command. This command is normally bound to all +such key-events @binding[Space]. If a prefix argument is supplied, then this +inserts the character that many times. +@enddefcom + +@defcom[com "New Line", bind (Return)] +This command, which has roughly the same effect as inserting a @bf[Newline], +is used to move onto a new blank line. If there are at least two blank +lines beneath the current one then @binding[Return] cleans off any +whitespace on the next line and uses it, instead of inserting a newline. +This behavior is desirable when inserting in the middle of text, because +the bottom half of the screen does not scroll down each time @hid[New Line] +is used. +@enddefcom + +@defcom[com "Quoted Insert", bind {C-q}] +Many key-events have corresponding ASCII characters, but these key-events are +bound to commands other than @hid[Self Insert]. Sometimes they are otherwise +encumbered such as with @binding[C-g]. @hid[Quoted Insert] prompts for a +key-event, without any command interpretation semantics, and inserts the +corresponding character. If the appropriate character has some code other than +an ASCII code, this will beep and abort the command. A common use for this +command is inserting a @bf[Formfeed] by typing @binding[C-q C-l]. If a prefix +argument is supplied, then the character is inserted that many times. +@enddefcom + +@defcom[com "Open Line", bind {C-o}] +This command inserts a newline into the buffer without moving the point. +This command may also be given a prefix argument to insert a number of +newlines, thus opening up some room to work in the middle of a screen of +text. See also @comref[Delete Blank Lines]. +@enddefcom + + +@subsection[Deleting Characters] +@index[deletion, character] +@index[character, deletion] +There are a number of commands for deleting characters as well. + +@defhvar[var "Character Deletion Threshold", val {5}] +If more than this many characters are deleted by a character deletion command, +then the deleted text is placed in the kill ring. +@enddefhvar + +@defcom[com "Delete Next Character", bind {C-d}] +@defcom1[com "Delete Previous Character", bind (Delete, Backspace)] +@hid[Delete Next Character] deletes the character immediately following the +point, that is, the character which appears under the cursor. When given a +prefix argument, @binding[C-d] deletes that many characters after the +point. @hid[Delete Previous Character] is identical, except that it +deletes characters before the point. +@enddefcom + +@defcom[com "Delete Previous Character Expanding Tabs"] +@hid[Delete Previous Character Expanding Tabs] is identical to +@hid[Delete Previous Character], except that it treats tabs as the +equivalent number of spaces. Various language modes that use tabs for +indentation bind @binding[Delete] to this command. +@enddefcom + + +@subsection[Killing and Deleting] + +@index[killing]@index[cutting]@index[pasting]@index[kill ring]@hemlock has many +commands which kill text. Killing is a variety of deletion which saves the +deleted text for later retrieval. The killed text is saved in a ring buffer +known as the @i[kill ring]. Killing has two main advantages over deletion: +@begin[enumerate] +If text is accidentally killed, a not uncommon occurrence, then it can be +restored. + +Text can be moved from one place to another by killing it and then +restoring it in the new location. +@end[enumerate] + +Killing is not the same as deleting. When a command is said to delete +text, the text is permanently gone and is not pushed on the kill ring. +Commands which delete text generally only delete things of little +importance, such as single characters or whitespace. + +@subsection[Kill Ring Manipulation] +@defcom[com "Un-Kill", bind {C-y}] +@index[kill ring, manipulation]This command "yanks" back the most +recently killed piece of text, leaving the mark before the inserted text +and the point after. If a prefix argument is supplied, then the text that +distance back in the kill ring is yanked. +@enddefcom + +@defcom[com "Rotate Kill Ring", bind {M-y}] +This command rotates the kill ring forward, replacing the most recently +yanked text with the next most recent text in the kill ring. @binding[M-y] +may only be used immediately after a use of @binding[C-y] or a previous +use of @binding[M-y]. This command is used to step back through the text +in the kill ring if the desired text was not the most recently killed, and +thus could not be retrieved directly with a @binding[C-y]. If a prefix +argument is supplied, then the kill ring is rotated that many times. +@enddefcom + +@defcom[com "Kill Region", bind {C-w}] +@index[region, killing]This command kills the text between the point and +mark, pushing it onto the kill ring. This command is usually the best way +to move or remove large quantities of text. +@enddefcom + +@defcom[com "Save Region", bind {M-w}] +This command pushes the text in the region on the kill ring, but doesn't +actually kill it, giving an effect similar to typing @binding[C-w C-y]. +This command is useful for duplicating large pieces of text. +@enddefcom + +@subsection[Killing Commands] + +@index[commands, killing]Most commands which kill text append into the +kill ring, meaning that consecutive uses of killing commands will insert +all text killed into the top entry in the kill ring. This allows large +pieces of text to be killed by repeatedly using a killing command. + +@defcom[com "Kill Line", bind {C-k}] +@defcom1[com "Backward Kill Line"] +@index[line, killing]@hid[Kill Line] kills the text from the point to the +end of the current line, deleting the line if it is empty. If a prefix +argument is supplied, then that many lines are killed. Note that a prefix +argument is not the same as a repeat count. + +@hid[Backward Kill Line] is similar, except that it kills from the point to the +beginning of the line. If it is called at the beginning of the line, it kills +the newline and any trailing whitespace on the previous line. With a prefix +argument, this command is the same as @hid[Kill Line] with a negated argument. +@enddefcom + +@defcom[com "Kill Next Word", bind {M-d}] +@defcom1[com "Kill Previous Word", bind (M-Backspace, M-Delete)] +@index[word, killing]@hid[Kill Next Word] kills from the point to the end +of the current or next word. If a prefix argument is supplied, then that +many words are killed. @hid[Kill Previous Word] is identical, except that +it kills backward. +@enddefcom + +@subsection[Case Modification Commands] + +@index[case modification]@hemlock provides a few case modification +commands, which are often useful for correcting typos. + +@defcom[com "Capitalize Word", bind {M-c}] +@defcom1[com "Lowercase Word", bind {M-l}] +@defcom1[com "Uppercase Word", bind {M-u}] +@index[word, case modification]These commands modify the case of the +characters from the point to the end of the current or next word, leaving +the point after the end of the word affected. A positive prefix argument +modifies that many words, moving forward. A negative prefix argument +modifies that many words before the point, but leaves the point unmoved. +@enddefcom + +@defcom[com "Lowercase Region", bind (C-x C-l)] +@defcom1[com "Uppercase Region", bind (C-x C-u)] +@index[region, case modification]These commands case-fold the text in the +region. Since these commands can damage large amounts of text, they ask for +confirmation before modifying large regions and can be undone with @hid[Undo]. +@enddefcom + +@subsection[Transposition Commands] + +@index[transposition]@index[commands, transposition]@hemlock provides a +number of transposition commands. A transposition command swaps the +"things" before and after the point and moves forward one "thing". Just +how a "thing" is defined depends on the particular transposition command. +Transposition commands, particularly +@hid[Transpose Characters] and @hid[Transpose Words], are useful for +correcting typos. More obscure transposition commands can be used to amaze +your friends and demonstrate your immense knowledge of exotic @emacs +commands. + +To the uninitiated, the behavior of transposition commands may seem mysterious; +this has led some implementors to attempt to improve the definition of +transposition, but right-thinking people will accept no substitutes. The +@emacs transposition definition used in @hemlock has two useful properties: +@begin[enumerate] +Repeated applications of a transposition command have a useful effect. The +way to visualize this effect is that each use of the transposition command +drags the previous thing over the next thing. It is possible to correct +double transpositions easily using @hid[Transpose Characters]. + +Transposition commands move backward with a negative prefix argument, thus +undoing the effect of the equivalent positive argument. +@end[enumerate] + +@defcom[com "Transpose Characters", bind {C-t}] +@index[character, transposition]This command exchanges the characters on +either side of the point and moves forward, unless at the end of a line, in +which case it transposes the previous two characters without moving. +@enddefcom + +@defcom[com "Transpose Lines", bind (C-x C-t)] +@index[line, transposition]This command transposes the previous and +current line, moving down to the next line. With a zero argument, it +transposes the current line and the line the mark is on. +@enddefcom + +@defcom[com "Transpose Words", bind {M-t}] +@index[word, transposition]This command transposes the previous word and +the current or next word. +@enddefcom + + +@defcom[com "Transpose Regions", bind (C-x t)] +This command transposes two regions with endpoints defined by the mark stack +and point. To use this command, place three marks (in order) at the start and +end of the first region, and at the start of the second region, then place the +point at the end of the second region. Unlike the other transposition +commands, a second use will simply undo the effect of the first use, and to do +even this, you must reactivate the current region. +@enddefcom + + +@subsection[Whitespace Manipulation] +These commands change the amount of space between words. See also the +indentation commands in section @ref[indentation]. + +@defcom[com "Just One Space", bind (M-|)] +@index[whitespace, manipulation]@index[indentation, manipulation]This +command deletes all whitespace characters before and after the point and then +inserts one space. If a prefix argument is supplied, then that number of +spaces is inserted. +@enddefcom + +@defcom[com "Delete Horizontal Space", bind (M-\)] +This command deletes all blank characters around the point. +@enddefcom + +@defcom[com "Delete Blank Lines", bind (C-x C-o)] +This command deletes all blank lines surrounding the current line, leaving the +point on a single blank line. If the point is already on a single blank line, +then that line is deleted. If the point is on a non-blank line, then all blank +lines immediately following that line are deleted. This command is often used +to clean up after @comref[Open Line]. +@enddefcom + +@section[Filtering] + +@i[Filtering] is a simple way to perform a fairly arbitrary transformation +on text. Filtering text replaces the string in each line with the result +of applying a @llisp function of one argument to that string. The function must +neither destructively modify the argument nor the return value. It is an +error for the function to return a string containing newline characters. + +@defcom[com "Filter Region"] +This function prompts for an expression which is evaluated to obtain a +function to be used to filter the text in the region. For example, to +capitalize all the words in the region one could respond: +@begin[programexample] +Function: #'@comment<>string-capitalize +@end[programexample] +Since the function may be called many times, it should probably be +compiled. Functions for one-time use can be compiled using the compile +function as in the following example which removes all the semicolons on any line +which contains the string "@f[PASCAL]": +@begin[programexample] +Function: (compile nil '(lambda (s) + (if (search "PASCAL" s) + (remove #\; s) + s))) +@end[programexample] +@enddefcom + +@section[Searching and Replacing] +@index[searching]@index[replacing] +Searching for some string known to appear in the text is a commonly used method +of moving long distances in a file. Replacing occurrences of one pattern with +another is a useful way to make many simple changes to text. @hemlock provides +powerful commands for doing both of these operations. + +@defhvar[var "String Search Ignore Case", val {t}] +@index[case sensitivity] +This variable determines the kind of search done by searching and replacing +commands. +@enddefhvar + +@defcom[com "Incremental Search", bind {C-s}] +@defcom1[com "Reverse Incremental Search", bind {C-r}] +@hid[Incremental Search] searches for an occurrence of a string after the +current point. It is known as an incremental search because it reads +key-events form the keyboard one at a time and immediately searches for the +pattern of corresponding characters as you type. This is useful because +it is possible to initially type in a very short pattern and then add more +characters if it turns out that this pattern has too many spurious matches. + +This command dispatches on the following key-events as sub-commands: +@begin[description] +@binding[C-s]@\ + Search forward for an occurrence of the current pattern. This can be used +repeatedly to skip from one occurrence of the pattern to the next, or it can be +used to change the direction of the search if it is currently a reverse search. +If @binding[C-s] is typed when the search string is empty, then a search is +done for the string that was used by the last searching command. + +@binding[C-r]@\ + Similar to @binding[C-s], except that it searches backwards. + +@binding[Delete, Backspace]@\ + Undoes the effect of the last key-event typed. If that key-event simply added +to the search pattern, then this removes the character from the pattern, moving +back to the last match found before entering the removed character. If the +character was a @binding[C-s] or @binding[C-r], then this moves back to the +previous match and possibly reverses the search direction. + +@binding[C-g]@\ + If the search is currently failing, meaning that there is no occurrence of the +search pattern in the direction of search, then @binding[C-g] deletes enough +characters off the end of the pattern to make it successful. If the search +is currently successful, then @binding[C-g] causes the search to be aborted, +leaving the point where it was when the search started. Aborting the search +inhibits the saving of the current search pattern as the last search string. + +@binding[Escape]@\ + Exit at the current position in the text, unless the search string is empty, +in which case a non-incremental string search is entered. + +@binding[C-q]@\ + Search for the character corresponding to the next key-event, rather than +treating it as a command. +@end[description] +Any key-event not corresponding to a graphic character, except those just +described, causes the search to exit. @hemlock then uses the key-event in it +normal command interpretation. + +For example, typing @binding[C-a] will exit the search @i[and] go to the +beginning of the current line. When either of these commands successfully +exits, they push the starting position (before the search) on the mark stack. +If the current region was active when the search started, this foregoes pushing +a mark. +@enddefcom + +@defcom[com "Forward Search", bind (M-s)] +@defcom1[com "Reverse Search", bind (M-r)] +These commands do a normal dumb string search, prompting for the search +string in a normal dumb fashion. One reason for using a non-incremental +search is that it may be faster since it is possible to specify a long +search string from the very start. Since @hemlock uses the Boyer--Moore +search algorithm, the speed of the search increases with the size of the +search string. +When either of these commands successfully exits, they push the starting +position (before the search) on the mark stack. This is inhibited when the +current region is active. +@enddefcom + +@defcom[com "Query Replace", bind (M-%)] +This command prompts in the echo area for a target string and a replacement +string. It then searches for an occurrence of the target after the point. +When it finds a match, it prompts for a key-event indicating what action to +take. The following are valid responses: +@begin[description] +@binding[Space, y]@\ + Replace this occurrence of the target with the replacement string, and search +again. + +@binding[Delete, Backspace, n]@\ + Do not replace this occurrence, but continue the search. + +@binding[!]@\ + Replace this and all remaining occurrences without prompting again. + +@binding[.]@\ + Replace this occurrence and exit. + +@binding[C-r]@\ + Go into a recursive edit (see page @pageref[recursive-edits]) at the current +location. The search will be continued from wherever the point is left when +the recursive edit is exited. This is useful for handling more complicated +cases where a simple replacement will not achieve the desired effect. + +@binding[Escape]@\ + Exit without doing any replacement. + +@binding[Home, C-_, ?, h]@\ + Print a list of all the options available. +@end[description] +Any other key-event causes the command to exit, returning the key-event to the +input stream; thus, @hemlock will interpret it normally for a command binding. + +When the current region is active, this command uses it instead of the region +from point to the end of the buffer. This is especially useful when you expect +to use the @binding[!] option. + +If the replacement string is all lowercase, then a heuristic is used that +attempts to make the case of the replacement the same as that of the +particular occurrence of the target pattern. If "@f[foo]" is being +replaced with "@f[bar]" then "@f[Foo]" is replaced with "@f[Bar]" and +"@f[FOO]" with "@f[BAR]". + +This command may be undone with @hid[Undo], but its undoing may not be undone. +On a successful exit from this command, the starting position (before the +search) is pushed on the mark stack. +@enddefcom + +@defhvar[var "Case Replace", val {t}] +@index[case sensitivity] +If this variable is true then the case preserving heuristic in +@hid[Query Replace] is enabled, otherwise all replacements are done with +the replacement string exactly as specified. +@enddefhvar + +@defcom[com "Replace String"] +This command is the same as @hid[Query Replace] except it operates without ever +querying the user before making replacements. After prompting for a target and +replacement string, it replaces all occurrences of the target string following +the point. If a prefix argument is specified, then only that many occurrences +are replaced. When the current region is active, this command uses it instead +of the region from point to the end of the buffer. +@enddefcom + +@defcom[com "List Matching Lines"] +This command prompts for a search string and displays in a pop-up window all +the lines containing the string that are after the point. If a prefix argument +is specified, then this displays that many lines before and after each matching +line. When the current region is active, this command uses it instead of the +region from point to the end of the buffer. +@enddefcom + +@defcom[com "Delete Matching Lines"] +@defcom1[com "Delete Non-Matching Lines"] +@hid[Delete Matching Lines] prompts for a search string and deletes all lines +containing the string that are after the point. Similarly, @hid[Delete +Non-Matching Lines] deletes all lines following the point that do not contain +the specified string. When the current region is active, these commands uses +it instead of the region from point to the end of the buffer. +@enddefcom + + +@section[Page Commands] +@index[page commands] +Another unit of text recognized by @hemlock is the page. A @i[page] is a piece +of text delimited by formfeeds (@f[^L]'s.) The first non-blank line after the +page marker is the @i[page title]. The page commands are quite useful when +logically distinct parts of a file are put on separate pages. See also +@comref[Count Lines Page]. These commands only recognize @f[^L]'s at the +beginning of a lines, so those quoted in string literals do not get in the way. + +@defcom[com "Previous Page", bind (C-x @bf<]>)] +@defcom1[com "Next Page", bind (C-x [)] +@hid[Previous Page] moves the point to the previous page delimiter, while +@hid[Next Page] moves to the next one. Any page delimiters next to the point +are skipped. The prefix argument is a repeat count. +@enddefcom + +@defcom[com "Mark Page", bind (C-x C-p)] +This command puts the point at the beginning of the current page and the mark +at the end. If given a prefix argument, marks the page that many pages from the +current one. +@enddefcom + +@defcom[com "Goto Page"] +This command does various things, depending on the prefix argument: +@begin[description] +@i[no argument]@\goes to the next page. + +@i[positive argument]@\goes to an absolute page number, moving that many pages +from the beginning of the file. + +@i[zero argument]@\prompts for string and goes to the page with that string in +its title. Repeated invocations in this manner continue searching from the +point of the last find, and a first search with a particular pattern pushes a +buffer mark. + +@i[negative argument]@\moves backward by that many pages, if possible. +@end[description] +@enddefcom + +@defcom[com "View Page Directory"] +@defcom1[com "Insert Page Directory"] +@hid[View Page Directory] uses a pop-up window to display the number and title +of each page in the current buffer. @hid[Insert Page Directory] is the same +except that it inserts the text at the beginning of the buffer. With a prefix +argument, @hid[Insert Page Directory] inserts at the point. +@enddefcom + + +@section[Counting Commands] + +@defcom[com "Count Words"] +This command counts the number of words from the current point to the end of +the buffer, displaying a message in the echo area. When the current region is +active, this uses it instead of the region from the point to the end of the +buffer. Word delimiters are determined by the current major mode. +@enddefcom + +@defcom[com "Count Lines"] +This command counts the number of lines from the current point to the end of +the buffer, displaying a message in the echo area. When the current region is +active, this uses it instead of the region from the point to the end of the +buffer. +@enddefcom + +@defcom[com "Count Lines Page", bind (C-x l)] +This command displays the number of lines in the current page and the number of +lines before and after the point within that page. If given a prefix argument, +the entire buffer is counted instead of just the current page. +@enddefcom + +@defcom[com "Count Occurrences"] +This command prompts for a search string and displays the number of occurrences +of that string in the text from the point to the end of the buffer. When the +current region is active, this uses it instead of the region from the point to +the end of the buffer. +@enddefcom + + +@section[Registers] +@index[registers] +Registers allow you to save a text position or chunk of text associated with a +key-event. This is a convenient way to repeatedly access a commonly-used +location or text fragment. The concept and key bindings should be familiar to +TECO users. + +@defcom[com "Save Position", bind (C-x s)] +@defcom1[com "Jump to Saved Position", bind (C-x j)] +These commands manipulate registers containing textual positions. +@hid[Save Position] prompts for a register and saves the location of the +current point in that register. @hid[Jump to Saved Position] prompts for a +register and moves the point to the position saved in that register. If the +saved position is in a different buffer, then that buffer is made current. +@enddefcom + +@defcom[com "Put Register", bind (C-x x)] +@defcom1[com "Get Register", bind (C-x g)] +These commands manipulate registers containing text. @hid[Put Register] +prompts for a register and puts the text in the current region into the +register. @hid[Get Register] prompts for a register and inserts the text in +that register at the current point. +@enddefcom + +@defcom[com "List Registers"] +@defcom1[com "Kill Register"] +@hid[List Registers] displays a list of all the currently defined registers in +a pop-up window, along with a brief description of their contents. +@hid[Kill Register] prompts for the name of a register and deletes that +register. +@enddefcom Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/intro.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/intro.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/intro.mss (revision 8058) @@ -0,0 +1,1127 @@ +@comment{-*- Dictionary: target:scribe/hem/hem; Mode: spell; Package: Hemlock -*-} +@chap[Introduction] + +@hemlock is a text editor which follows in the tradition of @emacs +and the Lisp Machine editor ZWEI. In its basic form, @hemlock has almost +the same command set as ITS/TOPS-20 @emacs@foot[In this document, "Emacs" +refers to this, the original version, rather than to any of the large +numbers of text editors inspired by it which may go by the same name.], +and similar features such as multiple windows and extended commands, as +well as built in documentation features. The reader should bear in mind +that whenever some powerful feature of @hemlock is described, it has +probably been directly inspired by @emacs. + +This manual describes @hemlock@comment{}'s commands and other user visible +features and then goes on to tell how to make simple customizations. For +complete documentation of the @hemlock primitives with which commands are +written, the @i[Hemlock Command Implementor's Manual] is also available. + + + +@section[The Point and The Cursor] + +@index[point] +@index[cursor] +The @i[point] is the current focus of editing activity. Text typed in by the +user is inserted at the point. Nearly all commands use the point as a +indication of what text to examine or modify. Textual positions in @hemlock +are between characters. This may seem a bit curious at first, but it is +necessary since text must be inserted between characters. Although the point +points between characters, it is sometimes said to point @i[at] a character, in +which case the character after the point is referred to. + +The @i[cursor] is the visible indication of the current focus of attention: a +rectangular blotch under @windows, or the hardware cursor on a terminal. The +cursor is usually displayed on the character which is immediately after the +point, but it may be displayed in other places. Wherever the cursor is +displayed it indicates the current focus of attention. When input is being +prompted for in the echo area, the cursor is displayed where the input is to +go. Under @windows the cursor is only displayed when @hemlock is waiting +for input. + + +@section[Notation] + +There are a number of notational conventions used in this manual which need +some explanation. + + +@subsection[Key-events] + +@label[key-events] +@index[key-events, notation] +@index[bits, key-event] +@index[modifiers, key-event] +The canonical representation of editor input is a @i[key-event]. When you type +on the keyboard, @hemlock receives key-events. Key-events have names for their +basic form, and we refer to this name as a @i[keysym]. This manual displays +keysyms in a @bf[Bold] font. For example, @bf[a] and @bf[b] are the keys that +normally cause the editor to insert the characters @i[a] and @i[b]. + +Key-events have @i[modifiers] or @i[bits] indicating a special interpretation +of the root key-event. Although the keyboard places limitations on what +key-events you can actually type, @hemlock understands arbitrary combinations +of the following modifiers: @i[Control], @i[Meta], @i[Super], @i[Hyper], +@i[Shift], and @i[Lock]. This manual represents the bits in a key-event by +prefixing the keysym with combinations of @bf[C-], @bf[M-], @bf[S-], @bf[H-], +@bf[Shift-], and @bf[Lock]. For example, @bf[a] with both the control and meta +bits set appears as @bf[C-M-a]. In general, ignore the shift and lock +modifiers since this manual never talks about keysyms that explicitly have +these bits set; that is, it may talk about the key-event @bf[A], but it would +never mention @bf[Shift-a]. These are actually distinct key-events, but +typical input coercion turns presents @hemlock with the former, not the latter. + +Key-event modifiers are totally independent of the keysym. This may be new to +you if you are used to thinking in terms of ASCII character codes. For +example, with key-events you can distinctly identify both uppercase and +lowercase keysyms with the control bit set; therefore, @bf[C-a] and @bf[C-A] +may have different meanings to @hemlock. + +Some keysyms' names consist of more than a single character, and these usually +correspond to the legend on the keyboard. For example, some keyboards let you +enter @bf[Home], @bf[Return], @bf[F9], etc. + +In addition to a keyboard, you may have a mouse or pointer device. Key-events +also represent this kind of input. For example, the down and up transitions of +the @i[left button] correspond to the @bf[Leftdown] and @bf[Leftup] keysyms. + +See sections @ref[key-bindings], @ref[using-x], @ref[using-terminals] + + +@subsection[Commands] + +@index[commands]@label[commands]Nearly everything that can be done in +@hemlock is done using a command. Since there are many things worth +doing, @hemlock provides many commands, currently nearly two hundred. +Most of this manual is a description of what commands exist, how they are +invoked, and what they do. This is the format of a command's +documentation: + +@defcom[com "Sample Command", bind (C-M-q, C-`)] +@begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems, +below 0.8 lines] +This command's name is @hid[Sample Command], and it is bound to +@w(@bf(C-M-q)) and @bf[C-`], meaning that typing either of these will +invoke it. After this header comes a description of what the command does: +@end[quotation] + +This command replaces all occurrences following the point of the string +"@f[Pascal]" with the string "@f[Lisp]". If a prefix argument is supplied, +then it is interpreted as the maximum number of occurrences to replace. If +the prefix argument is negative then the replacements are done backwards +from the point. +@comment< +@begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems, +above 0.8 lines, below 0.8 lines] +Toward the end of the description there may be information primarily of +interest to customizers and command implementors. If you don't understand +this information, don't worry, the writer probably forgot to speak English. +@end[quotation] + +@b[Arguments:] +@begin[description] +@i[target]@\The string to replace with "@f[Lisp]". + +@i[buffer]@\The buffer to do the replacement in. If this is @f[:all] then +the replacement is done in all buffers. +@end[description]> +@enddefcom + + +@subsection[Hemlock Variables] + +@index[variables, hemlock]@hemlock variables supply a simple +customization mechanism by permitting commands to be parameterized. For +details see page @pageref[vars]. + +@defhvar[var "Sample Variable", val {36}] +@begin[quotation, facecode i, leftmargin 8ems, below 0.8 lines] +The name of this variable is @hid[Sample Variable] and its initial value is +36. +@end[quotation] +this variable sets a lower limit on the number of replacements that be done +by @hid[Sample Command]. If the prefix argument is supplied, and smaller +in absolute value than @hid[Sample Variable], then the user is prompted as +to whether that small a number of occurrences should be replaced, so as to +avoid a possibly disastrous error. +@enddefhvar + + +@section[Invoking Commands] +@index[invocation, command] +In order to get a command to do its thing, it must be invoked. The user can do +this two ways, by typing the @i[key] to which the command is @i[bound] or by +using an @i[extended command]. Commonly used commands are invoked via their +key bindings since they are faster to type, while less used commands are +invoked as extended commands since they are easier to remember. + + +@subsection[Key Bindings] +@index[bindings, key] +@index[key bindings] +@label[key-bindings] +A key is a sequence of key-events (see section @ref[key-events]) typed on the +keyboard, usually only one or two in length. Sections @ref[using-x] and +@ref[using-terminals] contain information on particular input devices. + +When a command is bound to a key, typing the key causes @hemlock to invoke the +command. When the command completes its job, @hemlock returns to reading +another key, and this continually repeats. + +Some commands read key-events interpreting them however each command desires. +When commands do this, key bindings have no effect, but you can usually abort +@hemlock whenever it is waiting for input by typing @binding[C-g] (see section +@ref[aborting]). You can usually find out what options are available by typing +@binding[C-_] or @binding[Home] (see section @ref[help]). + +The user can easily rebind keys to different commands, bind new keys to +commands, or establish bindings for commands never bound before (see section +@ref[binding-keys]). + +In addition to the key bindings explicitly listed with each command, there are +some implicit bindings created by using key translations@foot[Key translations +are documented in the @i[Hemlock Command Implementor's Manual].]. These +bindings are not displayed by documentation commands such as @hid[Where Is]. +By default, there are only a few key translations. The modifier-prefix +characters @bf[C-^], @bf[Escape], @bf[C-z], or @bf[C-c] may be used when typing +keys to convert the following key-event to a control, meta, control-meta, or +hyper key-event. For example, @bf[C-x Escape b] invokes the same commands as +@bf[C-x M-b], and @bf[C-z u] is the same as @bf[C-M-u]. This allows user to +type more interesting keys on limited keyboards that lack control, meta, and +hyper keys. +@index[bit-prefix key-events] + + +@defhvar[var "Key Echo Delay", val {1.0}] +A key binding may be composed of several key-events, especially when you enter +it using modifier-prefix key-events. @hemlock provides feedback for partially +entered keys by displaying the typed key-events in the echo area. In order to +avoid excessive output and clearing of the echo area, this display is delayed +by @hid[Key Echo Delay] seconds. If this variable is set to @nil, then +@hemlock foregoes displaying initial subsequences of keys. +@enddefhvar + + +@subsection[Extended Commands] + +@index[commands, extended]A command is invoked as an extended command by +typing its name to the @hid[Extended Command] command, which is invoked +using its key binding, @binding[M-x]. + +@defcom[com "Extended Command", bind {M-x}] +This command prompts in the echo area for the name of a command, and then +invokes that command. The prefix argument is passed through to the command +invoked. The command name need not be typed out in full, as long as enough +of its name is supplied to uniquely identify it. Completion is available +using @binding[Escape] and @binding[Space], and a list of possible completions +is given by @binding[Home] or @binding[C-_]. +@enddefcom + + +@section[The Prefix Argument] + +@index[prefix argument]The prefix argument is an integer argument which +may be supplied to a command. It is known as the prefix argument because +it is specified by invoking some prefix argument setting command +immediately before the command to be given the argument. The following +statements about the interpretation of the prefix argument are true: +@begin[itemize] +When it is meaningful, most commands interpret the prefix argument as a +repeat count, causing the same effect as invoking the command that many +times. + +When it is meaningful, most commands that use the prefix argument interpret +a negative prefix argument as meaning the same thing as a positive +argument, but the action is done in the opposite direction. + +Most commands treat the absence of a prefix argument as meaning the same +thing as a prefix argument of one. + +Many commands ignore the prefix argument entirely. + +Some commands do none of the above. +@end[itemize] +The following commands are used to set the prefix argument: + +@defcom[com "Argument Digit", stuff (bound to all control or meta digits)] +Typing a number using this command sets the prefix argument to that number, +for example, typing @binding[M-1 M-2] sets the prefix argument to twelve. +@enddefcom + +@defcom[com "Negative Argument", bind {M--}] +This command negates the prefix argument, or if there is none, sets it to +negative one. For example, typing @binding[M-- M-7] sets the prefix +argument to negative seven. +@enddefcom + +@defcom[com "Universal Argument", bind {C-u}] +@defhvar1[var "Universal Argument Default", val {4}] +This command sets the prefix argument or multiplies it by four. If digits +are typed immediately afterward, they are echoed in the echo area, and the +prefix argument is set to the specified number. If no digits are typed +then the prefix argument is multiplied by four. @binding[C-u - 7] sets the +prefix argument to negative seven. @binding[C-u C-u] sets the prefix +argument to sixteen. @binding[M-4 M-2 C-u] sets the prefix argument to one +hundred and sixty-eight. @binding[C-u M-0] sets the prefix argument to +forty. + +@hid[Universal Argument Default] determines the default value and multiplier +for the @hid[Universal Argument] command. +@enddefcom + + +@section[Modes] + +@label[modes]@index[modes]A mode provides a way to change @hemlock@comment{}'s +behavior by specifying a modification to current key bindings, values of +variables, and other things. Modes are typically used to adjust @hemlock +to suit a particular editing task, e.g. @hid[Lisp] mode is used for editing +@llisp code. + +Modes in @hemlock are not like modes in most text editors; @hemlock is really a +"modeless" editor. There are two ways that the @hemlock mode concept differs +from the conventional one: +@begin[enumerate] +Modes do not usually alter the environment in a very big way, i.e. replace +the set of commands bound with another totally disjoint one. When a mode +redefines what a key does, it is usually redefined to have a slightly +different meaning, rather than a totally different one. For this reason, +typing a given key does pretty much the same thing no matter what modes are +in effect. This property is the distinguishing characteristic of a +modeless editor. + +Once the modes appropriate for editing a given file have been chosen, they +are seldom, if ever, changed. One of the advantages of modeless editors is +that time is not wasted changing modes. +@end[enumerate] + +@index[major mode]A @i[major mode] is used to make some big change in the +editing environment. Language modes such as @hid[Pascal] mode are major +modes. A major mode is usually turned on by invoking the command +@i{mode-name}@hid[ Mode] as an extended command. There is only one major +mode present at a time. Turning on a major mode turns off the one that is +currently in effect. + +@index[minor mode]A @i[minor mode] is used to make a small change in the +environment, such as automatically breaking lines if they get too long. +Unlike major modes, any number of minor modes may be present at once. +Ideally minor modes should do the "right thing" no matter what major and +minor modes are in effect, but this is may not be the case when key +bindings conflict. + +Modes can be envisioned as switches, the major mode corresponding to one big +switch which is thrown into the correct position for the type of editing being +done, and each minor mode corresponding to an on-off switch which controls +whether a certain characteristic is present. + +@defcom[com "Fundamental Mode"] +This command puts the current buffer into @hid[Fundamental] mode. +@hid[Fundamental] mode is the most basic major mode: it's the next best thing +to no mode at all. +@enddefcom + + +@section[Display Conventions] +@index[display conventions] +There are two ways that @hemlock displays information on the screen; one is +normal @i[buffer display], in which the text being edited is shown on the +screen, and the other is a @i[pop-up window]. + + +@subsection[Pop-Up Windows] +@index[pop-up windows] +@index[random typeout] +@label[pop-up] +Some commands print out information that is of little permanent value, and +these commands use a @i[pop-up] window to display the information. It is known +as a @i[pop-up] window because it temporarily appears on the screen overlaying +text already displayed. Most commands of this nature can generate their output +quickly, but in case there is a lot of output, or the user wants to repeatedly +refer to the same output while editing, @hemlock saves the output in a buffer. +Different commands may use different buffers to save their output, and we refer +to these as @i[random typeout] buffers. + +If the amount of output exceeds the size of the pop-up window, @Hemlock +displays the message @w<"@f[--More--]"> after each window full. The following +are valid responses to this prompt: +@Begin[Description] +@bf[Space], @bf[y]@\ + Display the next window full of text. + +@bf[Delete], @bf[Backspace], @bf[n]@\ + Abort any further output. + +@bf[Escape], @bf[!]@\ + Remove the window and continue saving any further output in the buffer. + +@bf[k]@\ + This is the same as @bf[!] or @bf[escape], but @hemlock makes a normal window +over the pop-up window. This only works on bitmap devices. +@End[Description] +Any other input causes the system to abort using the key-event to determine +the next command to execute. + +When the output is complete, @hemlock displays the string @w<"@f[--Flush--]"> +in the pop-up window's modeline, indicating that the user may flush the +temporary display. Typing any of the key-events described above removes the +pop-up window, but typing @bf[k] still produces a window suitable for normal +editing. Any other input also flushes the display, but @hemlock uses the +key-event to determine the next command to invoke. + +@defcom[com "Select Random Typeout Buffer", bind {H-t}] +This command makes the most recently used random typeout buffer the current +buffer in the current window. +@enddefcom + +Random typeout buffers are always in @hid[Fundamental] mode. + + +@subsection[Buffer Display] +@index[buffer, display] +@index[display, buffer] + +If a line of text is too long to fit within the screen width it is @i[wrapped], +with @hemlock displaying consecutive pieces of the text line on as many screen +lines as needed to hold the text. @hemlock indicates a wrapped line by placing +a line-wrap character in the last column of each screen line. Currently, the +line-wrap character is an exclamation point (@f[!]). It is possible for a line +to wrap off the bottom of the screen or on to the top. + +@hemlock wraps screen lines when the line is completely full regardless of the +line-wrap character. Most editors insert the line-wrap character and wrap a +single character when a screen line would be full if the editor had avoided +wrapping the line. In this situation, @hemlock would leave the screen line +full. This means there are always at least two characters on the next screen +line if @hemlock wraps a line of display. When the cursor is at the end of a +line which is the full width of the screen, it is displayed in the last column, +since it cannot be displayed off the edge. + +@hemlock displays most characters as themselves, but it treats some +specially: +@begin[itemize] +Tabs are treated as tabs, with eight character tab-stops. + +Characters corresponding to ASCII control characters are printed as +@f[^]@i[char]; for example, a formfeed is @f[^L]. + +Characters with the most-significant bit on are displayed as +@f[<]@i[hex-code]@f[>]; for example, @f[]. +@end[itemize] +Since a character may be displayed using more than one printing character, +there are some positions on the screen which are in the middle of a character. +When the cursor is on a character with a multiple-character representation, +@hemlock always displays the cursor on the first character. + + +@subsection[Recentering Windows] +@index[recentering windows] +@index[windows, recentering] + +When redisplaying the current window, @hemlock makes sure the current point is +visible. This is the behavior you see when you are entering text near the +bottom of the window, and suddenly redisplay shifts your position to the +window's center. + +Some buffers receive input from streams and other processes, and you might have +windows displaying these. However, if those windows are not the current +window, the output will run off the bottom of the windows, and you won't be +able to see the output as it appears in the buffers. You can change to a +window in which you want to track output and invoke the following command to +remedy this situation. + +@defcom[com "Track Buffer Point"] +This command makes the current window track the buffer's point. This means +that each time Hemlock redisplays, it will make sure the buffer's point is +visible in the window. This is useful for windows that are not current and +that display buffer's that receive output from streams coming from other +processes. +@enddefcom + + +@subsection[Modelines] +@label[modelines] +@index[modeline] +A modeline is the line displayed at the bottom of each window where @hemlock +shows information about the buffer displayed in that window. Here is a typical +modeline: +@begin[programexample] +Hemlock USER: (Fundamental Fill) /usr/slisp/hemlock/user.mss +@end[programexample] +This tells us that the file associated with this buffer is +"@f[/usr/slisp/hemlock/user.mss]", and the @hid[Current Package] for Lisp +interaction commands is the @f["USER"] package. The modes currently present +are @hid[Fundamental] and @hid[Fill]; the major mode is always displayed first, +followed by any minor modes. If the buffer has no associated file, then the +buffer name will be present instead: +@begin[programexample] +Hemlock PLAY: (Lisp) Silly: +@end[programexample] +In this case, the buffer is named @hid[Silly] and is in @hid[Lisp] mode. The +user has set @hid[Current Package] for this buffer to @f["PLAY"]. + +@defhvar[var "Maximum Modeline Pathname Length", val {nil}] +This variable controls how much of a pathname @hemlock displays in a modeline. +Some distributed file systems can have very long pathnames which leads to the +more particular information in a pathname running off the end of a modeline. +When set, the system chops off leading directories until the name is less than +the integer value of this variable. Three dots, @f[...], indicate a truncated +name. The user can establish this variable buffer locally with the +@hid[Defhvar] command. +@enddefhvar + +If the user has modified the buffer since the last time it was read from or +save to a file, then the modeline contains an asterisk (@f[*]) between the +modes list and the file or buffer name: +@begin[programexample] +Hemlock USER: (Fundamental Fill) * /usr/slisp/hemlock/user.mss +@end[programexample] +This serves as a reminder that the buffer should be saved eventually. + +@index[status line] +There is a special modeline known as the @i[status line] which appears as the +@hid[Echo Area]'s modeline. @Hemlock and user code use this area to display +general information not particular to a buffer @dash recursive edits, whether +you just received mail, etc. + + +@section[Use with X Windows] +@label[using-x] +@index[X windows, use with] +You should use @hemlock on a workstation with a bitmap display and a windowing +system since @hemlock makes good use of a non-ASCII device, mouse, and the +extra modifier keys typically associated with workstations. This section +discusses using @hemlock under X windows, the only supported windowing system. + + +@subsection[Window Groups] +@index[window management] +@label[groups] +@hemlock manages windows under X in groups. This allows @hemlock to be more +sophisticated in its window management without being rude in the X paradigm of +screen usage. With window groups, @hemlock can ignore where the groups are, +but within a group, it can maintain the window creation and deletion behavior +users expect in editors without any interference from window managers. + +Initially there are two groups, a main window and the @hid[Echo Area]. If you +keep a pop-up display, see section @ref[pop-up], @hemlock puts the window it +creates in its own group. There are commands for creating new groups. + +@hemlock only links windows within a group for purposes of the @hid[Next +Window], @hid[Previous Window], and @hid[Delete Next Window] commands. To move +between groups, you must use the @hid[Point to Here] command bound to the +mouse. + +Window manager commands can reshape and move groups on the screen. + + +@subsection[Event Translation] +@index[keyboard use under X] +@index[translation of keys under X] +Each X key event is translated into a canonical input representation, a +key-event. The X key event consists of a scan-code and modifier bits, and +these translate to an X keysym. This keysym and the modifier bits map to a +key-event. + +If you type a key with a shift key held down, this typically maps to a distinct +X keysym. For example, the shift of @bf[3] is @bf[#], and these have different +X keysyms. Some keys map to the same X keysym regardless of the shift bit, +such as @bf[Tab], @bf[Space], @bf[Return], etc. When the X lock bit is on, the +system treats this as a caps-lock, only mapping keysyms for lowercase letters +to shifted keysyms. + +The key-event has a keysym and a field of bits. The X keysyms map directly to +the key-event keysyms. There is a distinct mapping for each CLX modifier bit +to a key-event bit. This tends to eliminate shift and lock modifiers, so +key-events usually only have control, meta, hyper, and super bits on. Hyper +and super usually get turned on with prefix key-events that set them on the +following key-event, but you can turn certain keys on the keyboard into hyper +and super keys. See the X manuals and the @i[Hemlock Command Implementor's +Manual] for details. + +The system also maps mouse input to key-events. Each mouse button has distinct +key-event keysyms for whether the user pressed or released it. For +convenience, @hemlock makes use of an odd property of converting mouse events +to key-events. If you enter a mouse event with the shift key held down, +@hemlock sees the key-event keysym for the mouse event, but the key-event has +the super bit turned on. For example, if you press the left button with the +shift key pressed, @hemlock sees @bf[S-Leftdown]. + +Note that with the two button mouse on the IBM RT PC, the only way to to send +@bf[Middledown] is to press both the left and right buttons simultaneously. +This is awkward, and it often confuses the X server. For this reason, the +commands bound to the middle button are also bound to the shifted left button, +@bf[S-Leftdown], which is much easier to type. + + +@subsection[Cut Buffer Commands] +@index[cutting]@index[pasting] These commands allow the X cut buffer to be +used from @hemlock . Although @hemlock can cut arbitrarily large regions, +a bug in the standard version 10 xterm prevents large regions from being +pasted into an xterm window. + +@defcom[com "Region to Cut Buffer", bind {M-Insert}] +@defcom1[com "Insert Cut Buffer", bind {Insert}] +These commands manipulate the X cut buffer. @hid[Region to Cut Buffer] puts +the text in the region into the cut buffer. @hid[Insert Cut Buffer] inserts +the contents of the cut buffer at the point. +@enddefcom + +@subsection[Redisplay and Screen Management] + +These variables control a number of the characteristics of @hemlock bitmap +screen management. + +@defhvar[var "Bell Style", val {:border-flash}] +@defhvar1[var "Beep Border Width", val {20}] +@hid[Bell Style] determines what beeps do in @hemlock. Acceptable values are +@kwd[border-flash], @kwd[feep], @kwd[border-flash-and-feep], @kwd[flash], +@kwd[flash-and-feep], and @nil (do nothing). + +@hid[Beep Border Width] is the width in pixels of the border flashed by border +flash beep styles. +@enddefhvar + +@defhvar[var "Reverse Video", val {nil}] +If this variable is true, then @hemlock paints white on black in window +bodies, black on white in modelines. +@enddefhvar + +@defhvar[var "Thumb Bar Meter", val {t}] +If this variable is true, then windows will be created to be displayed with a +ruler in the bottom border of the window. +@enddefhvar + +@defhvar[var "Set Window Autoraise", val {:echo-only}] +When true, changing the current window will automatically raise the new current +window. If the value is @kwd[echo-only], then only the echo area window will +be raised automatically upon becoming current. +@enddefhvar + +@defhvar[var "Default Initial Window Width", val {80}] +@defhvar1[var "Default Initial Window Height", val {24}] +@defhvar1[var "Default Initial Window X"] +@defhvar1[var "Default Initial Window Y"] +@defhvar1[var "Default Window Height", val {24}] +@defhvar1[var "Default Window Width", val {80}] +@index[window placement] +@Hemlock uses the variables with "@hid[Initial]" in their names when it first +starts up to make its first window. The width and height are specified in +character units, but the x and y are specified in pixels. The other variables +determine the width and height for interactive window creation, such as making +a window with @comref[New Window]. +@enddefhvar + +@defhvar[var "Cursor Bitmap File", val {"library:hemlock.cursor"}] +This variable determines where the mouse cursor bitmap is read from when +@hemlock starts up. The mask is found by merging this name with "@f[.mask]". +This has to be a full pathname for the C routine. +@enddefhvar + + +@defhvar[var "Default Font"] +This variable holds the string name of the font to be used for normal text +display: buffer text, modelines, random typeout, etc. The font is loaded at +initialization time, so this variable must be set before entering @hemlock. +When @nil, the display type is used to choose a font. +@enddefhvar + + +@section[Use With Terminals] +@label[using-terminals]@index[terminals, use with] @hemlock can also be used +with ASCII terminals and terminal emulators. Capabilities that depend on +@windows (such as mouse commands) are not available, but nearly everything else +can be done. + +@subsection[Terminal Initialization] + +@index[terminal speed] +@index[speed, terminal] +@index[slow terminals] +@index[incremental redisplay] +For best redisplay performance, it is very important to set the terminal speed: +@lisp +stty 2400 +@endlisp +Often when running @hemlock using TTY redisplay, Hemlock will actually be +talking to a PTY whose speed is initialized to infinity. In reality, the +terminal will be much slower, resulting in @hemlock@comment{}'s output getting way ahead +of the terminal. This prevents @hemlock from briefly stopping redisplay to +allow the terminal to catch up. See also @hvarref. + +The terminal control sequences are obtained from the termcap database using the +normal Unix conventions. The @f["TERM"] environment variable holds the +terminal type. The @f["TERMCAP"] environment variable can be used to override +the default termcap database (in @f["/etc/termcap"]). The size of the terminal +can be altered from the termcap default through the use of: +@lisp +stty rows @i{height} columns @i{width} +@endlisp + +@subsection[Terminal Input] +@index[ASCII keyboard translation] +@index[bit-prefix key-events] +@index[prefix key-events] +@index[key-event, prefix] +The most important limitation of a terminal is its input capabilities. On a +workstation with function keys and independent control, meta, and shift +modifiers, it is possible to type 800 or so distinct single keystrokes. +Although by default, @hemlock uses only a fraction of these combinations, there +are many more than the 128 key-events available in ASCII. + +On a terminal, @hemlock attempts to translate ASCII control characters into the +most useful key-event: +@begin[itemize] +On a terminal, control does not compose with shift. If the control key is down +when you type a letter keys, the terminal always sends one code regardless of +whether the shift key is held. Since @hemlock primarily binds commands to +key-events with keysyms representing lowercase letters regardless of what bits +are set in the key-event, the system translates the ASCII control codes to a +keysym representing the appropriate lowercase characters. This keysym then +forms a key-event with the control bit set. Users can type @bf[C-c] followed +by an uppercase character to form a key-event with a keysym representing an +uppercase character and bits with the control bit set. + +On a terminal, some of the named keys generate an ASCII control code. For +example, @f[Return] usually sends a @f[C-m]. The system translates these ASCII +codes to a key-event with an appropriate keysym instead of the keysym named by +the character which names the ASCII code. In the above example, typing the +@f[Return] key would generate a key-event with the @bf[Return] keysym and no +bits. It would NOT translate to a key-event with the @bf[m] keysym and the +control bit. +@end[itemize] + +Since terminals have no meta key, you must use the @bf[Escape] and @bf[C-Z] +modifier-prefix key-events to invoke commands bound to key-events with the meta +bit or meta and control bits set. ASCII terminals cannot generate all +key-events which have the control bit on, so you can use the @bf[C-^] +modifier-prefix. The @bf[C-c] prefix sets the hyper bit on the next key-event +typed. + +When running @hemlock from a terminal @f[^\] is the interrupt key-event. +Typing this will place you in the Lisp debugger. + +When using a terminal, pop-up output windows cannot be retained after the +completion of the command. + + +@subsection[Terminal Redisplay] + +Redisplay is substantially different on a terminal. @Hemlock uses different +algorithms, and different parameters control redisplay and screen management. + +Terminal redisplay uses the Unix termcap database to find out how to use a +terminal. @hemlock is useful with terminals that lack capabilities for +inserting and deleting lines and characters, and some terminal emulators +implement these operations very inefficiently (such as xterm). +If you realize poor performance when scrolling, create a termcap entry that +excludes these capabilities. + +@defhvar[var "Scroll Redraw Ratio", val {nil}] +This is a ratio of "inserted" lines to the size of a window. When this ratio +is exceeded, insert/delete line terminal optimization is aborted, and every +altered line is simply redrawn as efficiently as possible. For example, +setting this to 1/4 will cause scrolling commands to redraw the entire window +instead of moving the bottom two lines of the window to the top (typically 3/4 +of the window is being deleted upward and inserted downward, hence a redraw); +however, commands like @hid[New Line] and @hid[Open Line] will still work +efficiently, inserting a line and moving the rest of the window's text +downward. +@enddefhvar + + +@section[The Echo Area] + +@index[echo area] +@index[prompting] +The echo area is the region which occupies the bottom few lines on the screen. +It is used for two purposes: displaying brief messages to the user and +prompting. + +When a command needs some information from the user, it requests it by +displaying a @i[prompt] in the echo area. The following is a typical prompt: +@begin[programexample] +Select Buffer: [hemlock-init.lisp /usr/foo/] +@end[programexample] +The general format of a prompt is a one or two word description of the input +requested, possibly followed by a @i[default] in brackets. The default is a +standard response to the prompt that @hemlock uses if you type @bf[Return] +without giving any other input. + +There are four general kinds of prompts: @comment +@begin[description] +@i[key-event]@\ + The response is a single key-event and no confirming @binding[Return] is +needed. + +@i[keyword]@\ + The response is a selection from one of a limited number of choices. +Completion is available using @binding[Space] and @binding[Escape], and you +only need to supply enough of the keyword to distinguish it from any other +choice. In some cases a keyword prompt accepts unknown input, indicating the +prompter should create a new entry. If this is the case, then you must enter +the keyword fully specified or completed using @binding[Escape]; this +distinguishes entering an old keyword from making a new keyword which is a +prefix of an old one since the system completes partial input automatically. + +@i[file]@\ + The response is the name of a file, which may have to exist. Unlike other +prompts, the default has some effect even after the user supplies some input: +the system @i[merges] the default with the input filename. See page +@pageref(merging) for a description of filename merging. @bf[Escape] and +@bf[Space] complete the input for a file parse. + +@i[string]@\ + The response is a string which must satisfy some property, such as being the +name of an existing file. +@end[description] + +@index[history, echo area] +These key-events have special meanings when prompting: +@begin[description] +@binding[Return]@\ + Confirm the current parse. If no input has been entered, then use the +default. If for some reason the input is unacceptable, @hemlock does two +things: +@Begin[enumerate] +beeps, if the variable @hid[Beep on Ambiguity] set, and + +moves the point to the end of the first word requiring disambiguation. +@End[enumerate] +This allows you to add to the input before confirming the it again. + +@binding[Home, C-_]@\ + Print some sort of help message. If the parse is a keyword parse, then print +all the possible completions of the current input in a pop-up window. + +@binding[Escape]@\ + Attempt to complete the input to a keyword or file parse as far as possible, +beeping if the result is ambiguous. When the result is ambiguous, @hemlock +moves the point to the first ambiguous field, which may be the end of the +completed input. + +@binding[Space]@\ + In a keyword parse, attempt to complete the input up to the next space. This +is useful for completing the names of @hemlock commands and similar things +without beeping a lot, and you can continue entering fields while leaving +previous fields ambiguous. For example, you can invoke @hid[Forward Word] as +an extended command by typing @binding[M-X f Space w Return]. Each time the +user enters space, @Hemlock attempts to complete the current field and all +previous fields. + +@binding[C-i, Tab]@\ + In a string or keyword parse, insert the default so that it may be edited. + +@binding[C-p]@\ + Retrieve the text of the last string input from a history of echo area inputs. +Repeating this moves to successively earlier inputs. + +@binding[C-n]@\ + Go the other way in the echo area history. + +@binding[C-q]@\ + Quote the next key-event so that it is not interpreted as a command. +@end[description] + +@defhvar[var "Ignore File Types"] +This variable is a list of file types (or extensions), represented as a string +without the dot, e.g. @f["fasl"]. Files having any of the specified types will +be considered nonexistent for completion purposes, making an unambiguous +completion more likely. The initial value contains most common binary and +output file types. +@enddefhvar + + +@section[Online Help] + +@label[help] +@index[online help] +@index[documentation, hemlock] +@hemlock has a fairly good online documentation facility. You can get brief +documentation for every command, variable, character attribute, and key +by typing a key. + +@defcom[com "Help", bind (Home, C-_)] +This command prompt for a key-event indicating one of a number of other +documentation commands. The following are valid responses: +@begin[description] +@bf[a]@\ + List commands and other things whose names contain a specified keyword. + +@bf[d]@\ + Give the documentation and bindings for a specified command. + +@bf[g]@\ + Give the documentation for any @hemlock thing. + +@bf[v]@\ + Give the documentation for a @hemlock variable and its values. + +@bf[c]@\ + Give the documentation for a command bound to some key. + +@bf[l]@\ + List the last sixty key-events typed. + +@bf[m]@\ + Give the documentation for a mode followed by a short description of its +mode-specific bindings. + +@bf[p]@\ + Give the documentation and bindings for commands that have at least one +binding involving a mouse/pointer key-event. + +@bf[w]@\ + List all the key bindings for a specified command. + +@bf[t]@\ + Describe a @llisp object. + +@binding[q]@\ + Quit without doing anything. + +@binding[Home, C-_, ?, h]@\ + List all of the options and what they do. +@end[description] +@enddefcom + +@defcom[com "Apropos", bind (Home a, C-_ a)] +This command prints brief documentation for all commands, variables, and +character attributes whose names match the input. This performs a prefix match +on each supplied word separately, intersecting the names in each word's result. +For example, giving @hid[Apropos] "@f[f m]" causes it to tersely describe +following commands and variables: +@Begin[Itemize] +@hid[Auto Fill Mode] + +@hid[Fundamental Mode] + +@hid[Mark Form] + +@hid[Default Modeline Fields] + +@hid[Fill Mode Hook] + +@hid[Fundamental Mode Hook] +@End[Itemize] +Notice @hid[Mark Form] demonstrates that the "@f[f]" words may follow the +"@f[m]" order of the fields does not matter for @hid[Apropos]. + +The bindings of commands and values of variables are printed with the +documentation. +@enddefcom + +@defcom[com "Describe Command", bind (Home d, C-_ d)] +This command prompts for a command and prints its full documentation and all +the keys bound to it. +@enddefcom + +@defcom[com "Describe Key", bind (Home c, C-_ c, M-?)] +This command prints full documentation for the command which is bound to +the specified key in the current environment. +@enddefcom + +@defcom[com "Describe Mode", bind (Home m, C-_ m)] +This command prints the documentation for a mode followed by a short +description of each of its mode-specific bindings. +@enddefcom + +@defcom[com "Show Variable"] +@defcom1[com "Describe and Show Variable"] +@hid[Show Variable] prompts for the name of a variable and displays +the global value of the variable, the value local to the current buffer (if +any), and the value of the variable in all defined modes that have it as a +local variable. @hid[Describe and Show Variable] displays the variable's +documentation in addition to the values. +@enddefcom + +@defcom[com "What Lossage", bind (Home l, C-_ l)] +This command displays the last sixty key-events typed. This can be useful +if, for example, you are curious what the command was that you typed by +accident. +@enddefcom + +@defcom[com "Describe Pointer"] +This command displays the documentation and bindings for commands that have +some binding involving a mouse/pointer key-event. It will not show the +documentation for the @hid[Illegal] command regardless of whether it has a +pointer binding. +@enddefcom + +@defcom[com "Where Is", bind (Home w, C-_ w)] +This command prompts for the name of a command and displays its key +bindings in a pop-up window. If a key binding is not global, the +environment in which it is available is displayed. +@enddefcom + +@defcom[com "Generic Describe", bind (Home g, C-_ g)] +This command prints full documentation for any thing that has +documentation. It first prompts for the kind of thing to document, the +following options being available: +@begin[description] +@i[attribute]@\Describe a character attribute, given its name. + +@i[command]@\Describe a command, given its name. + +@i[key]@\Describe a command, given a key to which it is bound. + +@i[variable]@\Describe a variable, given its name. This is the default. +@end[description] +@enddefcom + + +@section[Entering and Exiting] + +@index[entering hemlock]@hemlock is entered by using the @clisp @f[ed] +function. Simply typing @f[(ed)] will enter @hemlock, leaving you in the state +that you were in when you left it. If @hemlock has never been entered before +then the current buffer will be @hid[Main]. The @f[-edit] command-line switch +may also be used to enter @hemlock: see page @pageref[edit-switch]. + +@f[ed] may optionally be given a file name or a symbol argument. Typing +@f[(ed @i[filename])] will cause the specified file to be read into @hemlock, +as though by @hid[Find File]. Typing @w<@f[(ed @i[symbol])]> will pretty-print +the definition of the symbol into a buffer whose name is obtained by adding +"@f[Edit ]" to the beginning of the symbol's name. + +@defcom[com "Exit Hemlock", bind (C-c, C-x C-z)] +@defcom1[com "Pause Hemlock"] +@index[exiting hemlock]@hid[Exit Hemlock] exits @hemlock, returning @f[t]. +@hid[Exit Hemlock] does not by default save modified buffers, or do +anything else that you might think it should do; it simply exits. At any time +after exiting you may reenter by typing @f[(ed)] to @llisp without losing +anything. Before you quit from @llisp using @f[(quit)], you should +save any modified files that you want to be saved. + +@hid[Pause Hemlock] is similar, but it suspends the @llisp process and returns +control to the shell. When the process is resumed, it will still be running +@hemlock. +@enddefcom + + +@section[Helpful Information] + +@label[aborting] +@index[aborting] +@index[undoing] +@index[error recovery] +This section contains assorted helpful information which may be useful in +staying out of trouble or getting out of trouble. + +@begin[itemize] +It is possible to get some sort of help nearly everywhere by typing +@binding[Home] or @binding[C-_]. + +Various commands take over the keyboard and insist that you type the key-events +that they want as input. If you get in such a situation and want to get out, +you can usually do so by typing @bf[C-g] some small number of times. If this +fails you can try typing @binding[C-x C-z] to exit @hemlock and then "@f[(ed)]" +to re-enter it. + +Before you quit, make sure you have saved all your changes. @binding[C-u C-x +C-b] will display a list of all modified buffers. If you exit using @bf[C-x +M-z], then @hemlock will save all modified buffers with associated files. + +If you lose changes to a file due to a crash or accidental failure to save, +look for backup ("@i[file]@f[.BAK]") or checkpoint ("@i[file]@f[.CKP]") files +in the same directory where the file was. + +If the screen changes unexpectedly, you may have accidentally typed an +incorrect command. Use @binding[Home l] to see what it was. If you are +not familiar with the command, use @binding[Home c] to see what it is so that +you know what damage has been done. Many interesting commands can be found +in this fashion. This is an example of the much-underrated learning +technique known as "Learning by serendipitous malcoordination". Who would +ever think of looking for a command that deletes all files in the current +directory? + +If you accidentally type a "killing" command such as @binding[C-w], you can +get the lost text back using @binding[C-y]. The @hid[Undo] command is also +useful for recovering from this sort of problem. +@end[itemize] + +@defhvar[var "Region Query Size", val {30}] +@index[large region] +Various commands ask for confirmation before modifying a region containing more +than this number of lines. If this is @nil, then these commands refrain from +asking, no matter how large the region is. +@enddefhvar + +@defcom[com "Undo"] +This command undoes the last major modification. Killing commands and some +other commands save information about their modifications, so accidental uses +may be retracted. This command displays the name of the operation to be undone +and asks for confirmation. If the affected text has been modified between the +invocations of @hid[Undo] and the command to be undone, then the result may be +somewhat incorrect but useful. Often @hid[Undo] itself can be undone by +invoking it again. +@enddefcom + + +@section[Recursive Edits] +@label[recursive-edits] +@index[recursive edits] +Some sophisticated commands, such as @hid[Query Replace], can place you in a +@i[recursive edit]. A recursive edit is simply a recursive invocation of +@hemlock done within a command. A recursive edit is useful because it allows +arbitrary editing to be done during the execution of a command without losing +any state that the command might have. When the user exits a recursive edit, +the command that entered it proceeds as though nothing happened. @Hemlock +notes recursive edits in the @hid[Echo Area] modeline, or status line. A +counter reflects the number of pending recursive edits. + +@defcom[com "Exit Recursive Edit", bind (C-M-z)] +This command exits the current recursive edit, returning @nil. If invoked when +not in a recursive edit, then this signals an user error. +@enddefcom + +@defcom[com "Abort Recursive Edit", bind (@bf)] +This command causes the command which invoked the recursive edit to get an +error. If not in a recursive edit, this signals an user error. +@enddefcom + + +@section[User Errors] +@index[beeping] +@index[errors, user] +When in the course of editing, @hemlock is unable to do what it thinks you want +to do, then it brings this to your attention by a beep or a screen flash +(possibly accompanied by an explanatory echo area message such as @w<"@f[No +next line.]">.) Although the exact attention-getting mechanism may vary on the +output device and variable settings, this is always called @i[beeping]. + +Whatever the circumstances, you had best try something else since @hemlock, +being far more stupid than you, is far more stubborn. @hemlock is an +extensible editor, so it is always possible to change the command that +complained to do what you wanted it to do. + +@section[Internal Errors] + +@index[errors, internal]A message of this form may appear in the echo +area, accompanied by a beep: +@begin[programexample] +Internal error: +Wrong type argument, NIL, should have been of type SIMPLE-VECTOR. +@end[programexample] +If the error message is a file related error such as the following, then +you have probably done something illegal which @hemlock did not catch, +but was detected by the file system: +@begin[programexample] +Internal error: +No access to "/lisp2/emacs/teco.mid" +@end[programexample] +Otherwise, you have found a bug. Try to avoid the behavior that resulted +in the error and report the problem to your system maintainer. Since @llisp +has fairly robust error recovery mechanisms, probably no damage has been +done. + +If a truly abominable error from which @hemlock cannot recover occurs, +then you will be thrown into the @llisp debugger. At this point it would be +a good idea to save any changes with @f[save-all-buffers] and then start +a new @llisp. + +@index[save-all-buffers, function]The @llisp function @f[save-all-buffers] may +be used to save modified buffers in a seriously broken @hemlock. To use this, +type "@f[(save-all-buffers)]" to the top-level ("@f[* ]") or debugger +("@f<1] >") prompt and confirm saving of each buffer that should be saved. +Since this function will prompt in the "@f[Lisp]" window, it isn't very useful +when called inside of @hemlock. Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/lisp.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/lisp.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/lisp.mss (revision 8058) @@ -0,0 +1,822 @@ +@comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-} +@chap[Interacting With Lisp] +@index[lisp, interaction with] + +Lisp encourages highly interactive programming environments by requiring +decisions about object type and function definition to be postponed until run +time. @hemlock supports interactive programming in @llisp by providing +incremental redefinition and environment examination commands. @hemlock also +uses Unix TCP sockets to support multiple Lisp processes, each of which may be +on any machine. + + +@section[Eval Servers] +@label[eval-servers] +@index[eval servers] + +@hemlock runs in the editor process and interacts with other Lisp processes +called @i[eval servers]. A user's Lisp program normally runs in an eval +server process. The separation between editor and eval server has several +advantages: +@begin[itemize] +The editor is protected from any bad things which may happen while debugging a +Lisp program. + +Editing may occur while running a Lisp program. + +The eval server may be on a different machine, removing the load from the +editing machine. + +Multiple eval servers allow the use of several distinct Lisp environments. +@end[itemize] +Instead of providing an interface to a single Lisp environment, @hemlock +coordinates multiple Lisp environments. + + +@subsection[The Current Eval Server] +@index[current eval server] +Although @hemlock can be connected to several eval servers simultaneously, one +eval server is designated as the @i[current eval server]. This is the eval +server used to handle evaluation and compilation requests. Eval servers are +referred to by name so that there is a convenient way to discriminate between +servers when the editor is connected to more than one. The current eval server +is normally globally specified, but it may also be shadowed locally in specific +buffers. + +@defcom[com "Set Eval Server"] +@defcom1[com "Set Buffer Eval Server"] +@defcom1[com "Current Eval Server"] +@hid[Set Eval Server] prompts for the name of an eval server and makes it the +the current eval server. @hid[Set Buffer Eval Server] is the same except that +is sets the eval server for the current buffer only. @hid[Current Eval Server] +displays the name of the current eval server in the echo area, taking any +buffer eval server into consideration. See also @comref[Set Compile Server]. +@enddefcom + + +@subsection[Slaves] +@index[slave buffers] +@index[slaves] +For now, all eval servers are @i[slaves]. A slave is a Lisp process that uses +a typescript (see page @pageref[typescripts]) to run its top-level +@f[read-eval-print] loop in a @hemlock buffer. We refer to the buffer that a +slave uses for I/O as its @i[interactive] or @i[slave] buffer. The name of the +interactive buffer is the same as the eval server's name. + +@index[background buffers] +@hemlock creates a @i[background] buffer for each eval server. The background +buffer's name is @w<@hid[Background ]@i{name}>, where @i[name] is the name of +the eval server. Slaves direct compiler warning output to the background +buffer to avoid cluttering up the interactive buffer. + +@hemlock locally sets @hid[Current Eval Server] in interactive and background +buffers to their associated slave. When in a slave or background buffer, eval +server requests will go to the associated slave, regardless of the global value +of @hid[Current Eval Server]. + +@defcom[com "Select Slave", bind (C-M-c)] +This command changes the current buffer to the current eval server's +interactive buffer. If the current eval server is not a slave, then it beeps. +If there is no current eval server, then this creates a slave (see section +@ref[slave-creation]). If a prefix argument is supplied, then this creates a +new slave regardless of whether there is a current eval server. This command +is the standard way to create a slave. + +The slave buffer is a typescript (see page @pageref[typescripts]) the slave +uses for its top-level @f[read-eval-print] loop. +@enddefcom + +@defcom[com "Select Background", bind (C-M-C)] +This command changes the current buffer to the current eval server's background +buffer. If there is no current eval server, then it beeps. +@enddefcom + + +@subsection[Slave Creation and Destruction] +@label[slave-creation] +When @hemlock first starts up, there is no current eval server. If there is no +a current eval server, commands that need to use the current eval server will +create a slave as the current eval server. + +If an eval server's Lisp process terminates, then we say the eval server is +dead. @hemlock displays a message in the echo area, interactive, and +background buffers whenever an eval server dies. If the user deletes an +interactive or background buffer, the associated eval server effectively +becomes impotent, but @hemlock does not try to kill the process. If a command +attempts to use a dead eval server, then the command will beep and display a +message. + +@defhvar[var "Confirm Slave Creation", val {t}] +If this variable is true, then @hemlock always prompts the user for +confirmation before creating a slave. +@enddefhvar + +@defhvar[var "Ask About Old Servers", val {t}] +If this variable is true, and some slave already exists, @hemlock prompts the +user for the name of an existing server when there is no current server, +instead of creating a new one. +@enddefhvar + +@defcom[com "Editor Server Name"] +This command echos the editor server's name, the machine and port of the +editor, which is suitable for use with the Lisp processes -slave switch. +See section @ref[slave-switch]. +@enddefcom + +@defcom[com "Accept Slave Connections"] +This command cause @hemlock to accept slave connections, and it displays the +editor server's name, which is suitable for use with the Lisp processes -slave +switch. See section @ref[slave-switch]. Supplying an argument causes this +command to inhibit slave connections. +@enddefcom + +@defhvar[var "Slave Utility", val {"/usr/misc/.lisp/bin/lisp"}] +@defhvar1[var "Slave Utility Switches"] +A slave is started by running the program @hid[Slave Utility Name] with +arguments specified by the list of strings @hid[Slave Utility Switches]. This +is useful primarily when running customized Lisp systems. For example, +setting @hid[Slave Utility Switches] to @f[("-core" "my.core")] will cause +"@f[/usr/hqb/my.core]" to be used instead of the default core image. + +The @f[-slave] switch and the editor name are always supplied as arguments, and +should remain unspecified in @hid[Slave Utility Switches]. +@enddefhvar + +@defcom[com "Kill Slave"] +@defcom1[com "Kill Slave and Buffers"] +@hid[Kill Slave] prompts for a slave name, aborts any operations in the slave, +tells the slave to @f[quit], and shuts down the connection to the specified +eval server. This makes no attempt to assure the eval server actually dies. + +@hid[Kill Slave and Buffers] is the same as @hid[Kill Slave], but it also +deletes the interactive and background buffers. +@enddefcom + + +@subsection[Eval Server Operations] + +@label[operations] +@index[eval server operations]@index[operations, eval server] +@hemlock handles requests for compilation or evaluation by queuing an +@i[operation] on the current eval server. Any number of operations may be +queued, but each eval server can only service one operation at a time. +Information about the progress of operations is displayed in the echo area. + +@defcom[com "Abort Operations", bind (C-c a)] +This command aborts all operations on the current eval server, either queued or +in progress. Any operations already in the @f[Aborted] state will be flushed. +@enddefcom + +@defcom[com "List Operations", bind (C-c l)] +This command lists all operations which have not yet completed. Along with a +description of the operation, the state and eval server is displayed. The +following states are used: +@begin[description] +@f[Unsent]@\The operation is in local queue in the editor, and hasn't been sent +yet. + +@f[Pending]@\The operation has been sent, but has not yet started execution. + +@f[Running]@\The operation is currently being processed. + +@f[Aborted]@\The operation has been aborted, but the eval server has not yet +indicated termination. +@end[description] +@enddefcom + + +@section[Typescripts] +@label[typescripts] +@index[typescripts] + +Both slave buffers and background buffers are typescripts. The typescript +protocol allows other processes to do stream-oriented interaction in a @hemlock +buffer similar to that of a terminal. When there is a typescript in a buffer, +the @hid[Typescript] minor mode is present. Some of the commands described in +this section are also used by @hid[Eval] mode (page @pageref[eval-mode].) + +Typescripts are simple to use. @hemlock inserts output from the process into +the buffer. To give the process input, use normal editing to insert the input +at the end of the buffer, and then type @bf[Return] to confirm sending the +input to the process. + +@defcom[com "Confirm Typescript Input", + stuff (bound to @bf[Return] in @hid[Typescript] mode)] +@defhvar1[var "Unwedge Interactive Input Confirm", val {t}] +This command sends text that has been inserted at the end of the current buffer +to the process reading on the buffer's typescript. Before sending the text, +@hemlock moves the point to the end of the buffer and inserts a newline. + +Input may be edited as much as is desired before it is confirmed; the result +of editing input after it has been confirmed is unpredictable. For this reason, +it is desirable to postpone confirming of input until it is actually complete. +The @hid[Indent New Line] command is often useful for inserting newlines +without confirming the input. + +If the process reading on the buffer's typescript is not waiting for input, +then the text is queued instead of being sent immediately. Any number of +inputs may be typed ahead in this fashion. @hemlock makes sure that the inputs +and outputs get interleaved correctly so that when all input has been read, the +buffer looks the same as it would have if the input had not been typed ahead. + +If the buffer's point is before the start of the input area, then various +actions can occur. When set, @hid[Unwedge Interactive Input Confirm] causes +@hemlock to ask the user if it should fix the input buffer which typically +results in ignoring any current input and refreshing the input area at the end +of the buffer. This also has the effect of throwing the slave Lisp to top +level, which aborts any pending operations or queued input. This is the only +way to be sure the user is cleanly set up again after messing up the input +region. When this is @nil, @hemlock simply beeps and tells the user in the +@hid[Echo Area] that the input area is invalid. +@enddefcom + +@defcom[com "Kill Interactive Input", + stuff (bound to @bf[M-i] in @hid[Typescript] and @hid[Eval] modes)] +This command kills any input that would have been confirmed by @bf[Return]. +@enddefcom + +@defcom[com "Next Interactive Input", + stuff (bound to @bf[M-n] in @hid[Typescript] and @hid[Eval] modes)] +@defcom1[com "Previous Interactive Input", + stuff (bound to @bf[M-p] in @hid[Typescript] and @hid[Eval] modes)] +@defcom1[com "Search Previous Interactive Input", + stuff (bound to @bf[M-P] in @hid[Typescript] and @hid[Eval] modes)] +@defhvar1[var "Interactive History Length", val {10}] +@defhvar1[var "Minimum Interactive Input Length", val {2}] +@index[history, typescript] +@Hemlock maintains a history of interactive inputs. @hid[Next Interactive +Input] and @hid[Previous Interactive Input] step forward and backward in the +history, inserting the current entry in the buffer. The prefix argument is +used as a repeat count. + +@hid[Search Previous Interactive Input] searches backward through the +interactive history using the current input as a search string. Consecutive +invocations repeat the previous search. + +@hid[Interactive History Length] determines the number of entries with which +@hemlock creates the buffer-specific histories. @Hemlock only adds an input +region to the history if its number of characters exceeds @hid[Minimum +Interactive Input Length]. +@enddefcom + +@defcom[com "Reenter Interactive Input", + stuff (bound to @bf[C-Return] in @hid[Typescript] and @hid[Eval] modes)] + This copies to the end of the buffer the form to the left of the buffer's +point. When the current region is active, this copies it instead. This is +sometimes easier to use to get a previous input that is either so far back that +it has fallen off the history or is visible and more readily @i[yanked] than +gotten with successive invocations of the history commands. +@enddefcom + +@defcom[com "Interactive Beginning of Line", + stuff (bound to @bf[C-a] in @hid[Typescript] and @hid[Eval] modes)] +This command is identical to @hid[Beginning of Line] unless there is no +prefix argument and the point is on the same line as the start of the current +input; then it moves to the beginning of the input. This is useful since it +skips over any prompt which may be present. +@enddefcom + +@defhvar[var "Input Wait Alarm", val {:loud-message}] +@defhvar1[var "Slave GC Alarm", val {:message}] +@hid[Input Wait Alarm] determines what action to take when a slave Lisp goes +into an input wait on a typescript that isn't currently displayed in any +window. @hid[Slave GC Alarm] determines what action to take when a slave +notifies that it is GC'ing. + +The following are legal values: +@begin[description] +@kwd[loud-message]@\Beep and display a message in the echo area indicating +which buffer is waiting for input. + +@kwd[message]@\Display a message, but don't beep. + +@nil@\Don't do anything. +@end[description] +@enddefhvar + +@defcom[com "Typescript Slave BREAK", bind (Typescript: H-b)] +@defcom1[com "Typescript Slave to Top Level", bind (Typescript: H-g)] +@defcom1[com "Typescript Slave Status", bind (Typescript: H-s)] +Some typescripts have associated information which these commands access +allowing @hemlock to control the process which uses the typescript. + +@hid[Typescript Slave BREAK] puts the current process in a break loop so that +you can be debug it. This is similar in effect to an interrupt signal (@f[^C] +or @f[^\] in the editor process). + +@hid[Typescript Slave to Top Level] causes the current process to throw to the +top-level @f[read-eval-print] loop. This is similar in effect to a quit signal +(@f[^\]). + +@hid[Typescript Slave Status] causes the current process to print status +information on @var[error-output]: +@lisp +; Used 0:06:03, 3851 faults. In: SYSTEM:SERVE-EVENT +@endlisp +The message displays the process run-time, the total number of page faults and +the name of the currently running function. This command is useful for +determining whether the slave is in an infinite loop, waiting for input, or +whatever. +@enddefcom + + +@section[The Current Package] +@label[lisp-package] +@index[package] +The current package is the package which Lisp interaction commands use. The +current package is specified on a per-buffer basis, and defaults to "@f[USER]". +If the current package does not exist in the eval server, then it is created. +If evaluation is being done in the editor process and the current package +doesn't exist, then the value of @f[*package*] is used. The current package is +displayed in the modeline (see section @ref[modelines].) Normally the package +for each file is specified using the @f[Package] file option (see page +@pageref[file-options].) + +When in a slave buffer, the current package is controlled by the value of +@var[package] in that Lisp process. Modeline display of the current package +is inhibited in this case. + +@defcom[com "Set Buffer Package"] +This command prompts for the name of a package to make the local package in the +current buffer. If the current buffer is a slave, background, or eval buffer, +then this sets the current package in the associated eval server or editor +Lisp. When in an interactive buffer, do not use @f[in-package]; use this +command instead. +@enddefcom + + +@section[Compiling and Evaluating Lisp Code] + +@index[compilation]@index[evaluation]These commands can greatly speed up +the edit/debug cycle since they enable incremental reevaluation or +recompilation of changed code, avoiding the need to compile and load an +entire file. + +@defcom[com "Evaluate Expression", bind (M-Escape)] +This command prompts for an expression and prints the result of its evaluation +in the echo area. If an error happens during evaluation, the evaluation is +simply aborted, instead of going into the debugger. This command doesn't +return until the evaluation is complete. +@enddefcom + +@defcom[com "Evaluate Defun", bind (C-x C-e)] +@defcom1[com "Evaluate Region"] +@defcom1[com "Evaluate Buffer"] +These commands evaluate text out of the current buffer, reading the current +defun, the region and the entire buffer, respectively. The result of the +evaluation of each form is displayed in the echo area. If the region is +active, then @hid[Evaluate Defun] evaluates the current region, just like +@hid[Evaluate Region]. +@enddefcom + +@defcom[com "Macroexpand Expression", bind (C-M)] +This command shows the macroexpansion of the next expression in the null +environment in a pop-up window. With an argument, it uses @f[macroexpand] +instead of @f[macroexpand-1]. +@enddefcom + +@defcom[com "Re-evaluate Defvar"] +This command is similar to @hid[Evaluate Defun]. It is used for force the +re-evaluation of a @f[defvar] init form. If the current top-level form is a +@f[defvar], then it does a @f[makunbound] on the variable, and evaluates the +form. +@enddefcom + +@defcom[com "Compile Defun", bind (C-x C-c)] +@defcom1[com "Compile Region"] +These commands compile the text in the current defun and the region, +respectively. If the region is active, then @hid[Compile Defun] compiles the +current region, just like @hid[Compile Region]. +@enddefcom + +@defcom[com "Load File"] +@defhvar1[var "Load Pathname Defaults", val {nil}] +This command prompts for a file and loads it into the current eval server using +@f[load]. @hid[Load Pathname Defaults] contains the default pathname for this +command. This variable is set to the file loaded; if it is @nil, then there is +no default. This command also uses the @hid[Remote Compile File] variable. +@enddefcom + + +@section[Compiling Files] +These commands are used to compile source ("@f[.lisp]") files, producing binary +("@f[.fasl]") output files. Note that unlike the other compiling and evalating +commands, this does not have the effect of placing the definitions in the +environment; to do so, the binary file must be loaded. + +@defcom[com "Compile Buffer File", bind (C-x c)] +@defhvar1[var "Compile Buffer File Confirm", val {t}] +This command asks for confirmation, then saves the current buffer (when +modified) and compiles the associated file. The confirmation prompt indicates +intent to save and compile or just compile. If the buffer wasn't modified, and +a comparison of the write dates for the source and corresponding binary +("@f[.fasl]") file suggests that recompilation is unnecessary, the confirmation +also indicates this. A prefix argument overrides this test and forces +recompilation. Since there is a complete log of output in the background +buffer, the creation of the normal error output ("@f[.err]") file is inhibited. + +Setting @hid[Compile Buffer File Confirm] to @nil inhibits confirmation, except +when the binary is up to date and a prefix argument is not supplied. +@enddefcom + +@defcom[com "Compile File"] +This command prompts for a file and compiles that file, providing a convenient +way to compile a file that isn't in any buffer. Unlike +@hid[Compile Buffer File], this command doesn't do any consistency checks such +as checking whether the source is in a modified buffer or the binary is up to +date. +@enddefcom + +@defcom[com "Compile Group"] +@defcom1[com "List Compile Group"] +@label[compile-group-command]@index[group, compilation]@hid[Compile Group] does +a @hid[Save All Files] and then compiles every "@f[.lisp]" file for which the +corresponding "@f[.fasl]" file is older or nonexistent. The files are compiled +in the order in which they appear in the group definition. A prefix argument +forces compilation of all "@f[.lisp]" files. + +@hid[List Compile Group] lists any files that would be compiled by +@hid[Compile Group]. All Modified files are saved before checking to generate +a consistent list. +@enddefcom + +@defcom[com "Set Compile Server"] +@defcom1[com "Set Buffer Compile Server"] +@defcom1[com "Current Compile Server"] +These commands are analogous to @hid[Set Eval Server], @comref[Set Buffer Eval +Server] and @hid[Current Eval Server], but they determine the eval server used +for file compilation requests. If the user specifies a compile server, then +the file compilation commands send compilation requests to that server instead +of the current eval server. + +Having a separate compile server makes it easy to do compilations in the +background while continuing to interact with your eval server and editor. The +compile server can also run on a remote machine relieving your active +development machine of the compilation effort. +@enddefcom + +@defcom[com "Next Compiler Error", bind (H-n)] +@defcom1[com "Previous Compiler Error", bind (H-p)] +These commands provides a convenient way to inspect compiler errors. First it +splits the current window if there is only one window present. @hemlock +positions the current point in the first window at the erroneous source code +for the next (or previous) error. Then in the second window, it displays the +error beginning at the top of the window. Given an argument, this command +skips that many errors. +@enddefcom + +@defcom[com "Flush Compiler Error Information"] +This command relieves the current eval server of all infomation about errors +encountered while compiling. This is convenient if you have been compiling a +lot, but you were ignoring errors and warnings. You don't want to step through +all the old errors, so you can use this command immediately before compiling a +file whose errors you intend to edit. +@enddefcom + + +@defhvar[var "Remote Compile File", val {nil}] +When true, this variable causes file compilations to be done using the RFS +remote file system mechanism by prepending "@f[/../]@i[host]" to the file being +compiled. This allows the compile server to be run on a different machine, but +requires that the source be world readable. If false, commands use source +filenames directly. Do NOT use this to compile files in AFS. +@enddefhvar + + +@section[Querying the Environment] +@index[documentation, lisp] +These commands are useful for obtaining various random information from the +Lisp environment. + +@defcom[com "Describe Function Call", bind (C-M-A)] +@defcom1[com "Describe Symbol", bind (C-M-S)] +@hid[Describe Function Call] uses the current eval server to describe the +symbol found at the head of the currently enclosing list, displaying the output +in a pop-up window. @hid[Describe Symbol] is the same except that it describes +the symbol at or before the point. These commands are primarily useful for +finding the documentation for functions and variables. If there is no +currently valid eval server, then this command uses the editor Lisp's +environment instead of trying to spawn a slave. +@enddefcom + + +@section[Editing Definitions] +The Lisp compiler annotates each compiled function object with the source +file that the function was originally defined from. The definition editing +commands use this information to locate and edit the source for functions +defined in the environment. + +@defcom[com "Edit Definition"] +@defcom1[com "Goto Definition", bind (C-M-F)] +@defcom1[com "Edit Command Definition"] +@hid[Edit Definition] prompts for the name of a function, and then uses the +current eval server to find out in which file the function is defined. If +something other than @f[defun] or @f[defmacro] defined the function, then this +simply reads in the file, without trying to find its definition point within +the file. If the function is uncompiled, then this looks for it in the current +buffer. If there is no currently valid eval server, then this command uses the +editor Lisp's environment instead of trying to spawn a slave. + +@hid[Goto Definition] edits the definition of the symbol at the beginning of +the current list. + +@hid[Edit Command Definition] edits the definition of a @hemlock command. By +default, this command does a keyword prompt for the command name (as in an +extended command). If a prefix argument is specified, then instead prompt for +a key and edit the definition of the command bound to that key. +@enddefcom + +@defcom[com "Add Definition Directory Translation"] +@defcom1[com "Delete Definition Directory Translation"] +The defining file is recorded as an absolute pathname. The definition editing +commands have a directory translation mechanism that allow the sources to be +found when they are not in the location where compilation was originally done. +@hid[Add Definition Directory Translation] prompts for two directory +namestrings and causes the first to be mapped to the second. Longer (more +specific) directory specifications are matched before shorter (more general) +ones. + +@hid[Delete Definition Directory Translation] prompts for a directory +namestring and deletes it from the directory translation table. +@enddefcom + +@defhvar[var "Editor Definition Info", val {nil}] +When this variable is true, the editor Lisp is used to determine definition +editing information, otherwise the current eval server is used. This variable +is true in @hid[Eval] and @hid[Editor] modes. +@enddefhvar + + +@section[Debugging] +These commands manipulate the slave when it is in the debugger and provide +source editing based on the debugger's current frame. These all affect the +@hid[Current Eval Server]. + + +@subsection[Changing Frames] + +@defcom[com "Debug Down", bind (C-M-H-d)] +This command moves down one debugger frame. +@enddefcom + +@defcom[com "Debug Up", bind (C-M-H-u)] +This command moves up one debugger frame. +@enddefcom + +@defcom[com "Debug Top", bind (C-M-H-t)] +This command moves to the top of the debugging stack. +@enddefcom + +@defcom[com "Debug Bottom", bind (C-M-H-b)] +This command moves to the bottom of the debugging stack. +@enddefcom + +@defcom[com "Debug Frame", bind (C-M-H-f)] +This command moves to the absolute debugger frame number indicated by the +prefix argument. +@enddefcom + + +@subsection[Getting out of the Debugger] + +@defcom[com "Debug Quit", bind (C-M-H-q)] +This command throws to top level out of the debugger in the @hid[Current Eval +Server]. +@enddefcom + +@defcom[com "Debug Go", bind (C-M-H-g)] +This command tries the @f[continue] restart in the @hid[Current Eval Server]. +@enddefcom + +@defcom[com "Debug Abort", bind (C-M-H-a)] +This command executes the ABORT restart in the @hid[Current Eval Server]. +@enddefcom + +@defcom[com "Debug Restart", bind (C-M-H-r)] +This command executes the restart indicated by the prefix argument in the +@hid[Current Eval Server]. The debugger enumerates the restart cases upon +entering it. +@enddefcom + + +@subsection[Getting Information] + +@defcom[com "Debug Help", bind (C-M-H-h)] +This command in prints the debugger's help text. +@enddefcom + +@defcom[com "Debug Error", bind (C-M-H-e)] +This command prints the error condition and restart cases displayed upon +entering the debugger. +@enddefcom + +@defcom[com "Debug Backtrace", bind (C-M-H-B)] +This command executes the debugger's @f[backtrace] command. +@enddefcom + +@defcom[com "Debug Print", bind (C-M-H-p)] +This command prints the debugger's current frame in the same fashion as the +frame motion commands. +@enddefcom + +@defcom[com "Debug Verbose Print", bind (C-M-H-P)] +This command prints the debugger's current frame without elipsis. +@enddefcom + +@defcom[com "Debug Source", bind (C-M-H-s)] +This command prints the source form for the debugger's current frame. +@enddefcom + +@defcom[com "Debug Verbose Source"] +This command prints the source form for the debugger's current frame with +surrounding forms for context. +@enddefcom + +@defcom[com "Debug List Locals", bind (C-M-H-l)] +This prints the local variables for the debugger's current frame. +@enddefcom + + +@subsection[Editing Sources] + +@defcom[com "Debug Edit Source", bind (C-M-H-S)] +This command attempts to place you at the source location of the debugger's +current frame. Not all debugger frames represent function's that were compiled +with the appropriate debug-info policy. This beeps with a message if it is +unsuccessful. +@enddefcom + + +@subsection[Miscellaneous] + +@defcom[com "Debug Flush Errors", bind (C-M-H-F)] +This command toggles whether the debugger ignores errors or recursively enters +itself. +@enddefcom + + + + +@section[Manipulating the Editor Process] +When developing @hemlock customizations, it is useful to be able to manipulate +the editor Lisp environment from @hemlock. + +@defcom[com "Editor Describe", bind (Home t, C-_ t)] +This command prompts for an expression, and then evaluates and describes it +in the editor process. +@enddefcom + +@defcom[com "Room"] +Call the @f[room] function in the editor process, displaying information +about allocated storage in a pop-up window. +@enddefcom + +@defcom[com "Editor Load File"] +This command is analogous to @comref[Load File], but loads the file into the +editor process. +@enddefcom + + +@subsection[Editor Mode] +When @hid[Editor] mode is on, alternate versions of the Lisp interaction +commands are bound in place of the eval server based commands. These commands +manipulate the editor process instead of the current eval server. Turning on +editor mode in a buffer allows incremental development of code within the +running editor. + +@defcom[com "Editor Mode"] +This command turns on @hid[Editor] minor mode in the current buffer. If it is +already on, it is turned off. @hid[Editor] mode may also be turned on using +the @f[Mode] file option (see page @pageref[file-options].) +@enddefcom + +@defcom[com "Editor Compile Defun", + stuff (bound to @bf[C-x C-c] in @hid[Editor] mode)] +@defcom1[com "Editor Compile Region"] +@defcom1[com "Editor Evaluate Buffer"] +@defcom1[com "Editor Evaluate Defun", + stuff (bound to @bf[C-x C-e] in @hid[Editor] mode)] +@defcom1[com "Editor Evaluate Region"] +@defcom1[com "Editor Macroexpand Expression", bind (Editor: C-M)] +@defcom1[com "Editor Re-evaluate Defvar"] +@defcom1[com "Editor Describe Function Call", + stuff (bound to @bf[C-M-A] in @hid[Editor] mode)] +@defcom1[com "Editor Describe Symbol", + stuff (bound to @bf[C-M-S] in @hid[Editor] mode)] +These commands are similar to the standard commands, but modify or examine the +Lisp process that @hemlock is running in. Terminal I/O is done on the +initial window for the editor's Lisp process. Output is directed to a pop-up +window or the editor's window instead of to the background buffer. +@enddefcom + +@defcom[com "Editor Compile Buffer File"] +@defcom1[com "Editor Compile File"] +@defcom1[com "Editor Compile Group"] +In addition to compiling in the editor process, these commands differ from the +eval server versions in that they direct output to the the +@hid[Compiler Warnings] buffer. +@enddefcom + +@defcom[com "Editor Evaluate Expression", + stuff (bound to @bf[M-Escape] in @hid[Editor] mode and @bf[C-M-Escape])] +This command prompts for an expression and evaluates it in the editor process. +The results of the evaluation are displayed in the echo area. +@enddefcom + + +@subsection[Eval Mode] +@label[eval-mode] +@index[modes, eval]@hid[Eval] mode is a minor mode that simulates a @f[read] +@f[eval] @f[print] loop running within the editor process. Since Lisp +program development is usually done in a separate eval server process (see page +@pageref[eval-servers]), @hid[Eval] mode is used primarily for debugging code +that must run in the editor process. @hid[Eval] mode shares some commands with +@hid[Typescript] mode: see section @ref[typescripts]. + +@hid[Eval] mode doesn't completely support terminal I/O: it binds +@var[standard-output] to a stream that inserts into the buffer and +@var[standard-input] to a stream that signals an error for all operations. +@hemlock cannot correctly support the interactive evaluation of forms that read +from the @hid[Eval] interactive buffer. + +@defcom[com "Select Eval Buffer"] +This command changes to the @hid[Eval] buffer, creating one if it doesn't +already exist. The @hid[Eval] buffer is created with @hid[Lisp] as the major +mode and @hid[Eval] and @hid[Editor] as minor modes. +@enddefcom + +@defcom[com "Confirm Eval Input", + stuff (bound to @bf[Return] in @hid[Eval] mode)] +This command evaluates all the forms between the end of the last output and +the end of the buffer, inserting the results of their evaluation in the buffer. +This beeps if the form is incomplete. Use @binding[Linefeed] to insert line +breaks in the middle of a form. + +This command uses @hid[Unwedge Interactive Input Confirm] in the same way +@hid[Confirm Interactive Input] does. +@enddefcom + +@defcom[com "Abort Eval Input", + stuff (bound to @bf[M-i] in @hid[Eval] mode)] +This command moves the the end of the buffer and prompts, ignoring any +input already typed in. +@enddefcom + + +@subsection[Error Handling] +@index[error handling] +When an error happens inside of @hemlock, @hemlock will trap the error and +display the error message in the echo area, possibly along with the +"@f[Internal error:]" prefix. If you want to debug the error, type @bf[?]. +This causes the prompt "@f[Debug:]" to appear in the echo area. The following +commands are recognized: +@begin[description] +@bf[d]@\Enter a break-loop so that you can use the Lisp debugger. +Proceeding with "@f[go]" will reenter @hemlock and give the "@f[Debug:]" +prompt again. + +@bf[e]@\Display the original error message in a pop-up window. + +@bf[b]@\Show a stack backtrace in a pop-up window. + +@bf[q, Escape]@\Quit from this error to the nearest command loop. + +@bf[r]@\Display a list of the restart cases and prompt for the number of a +@f[restart-case] with which to continue. Restarting may result in prompting in +the window in which Lisp started. +@end[description] + +Only errors within the editor process are handled in this way. Errors during +eval server operations are handled using normal terminal I/O on a typescript in +the eval server's slave buffer or background buffer (see page +@pageref[operations]). Errors due to interaction in a slave buffer will cause +the debugger to be entered in the slave buffer. + + +@section[Command Line Switches] +@label[slave-switch] +Two command line switches control the initialization of editor and eval servers +for a Lisp process: +@begin[description] +@f<-edit>@\ +@label[edit-switch] +This switch starts up @hemlock. If there is a non-switch command line word +immediately following the program name, then the system interprets it as a file +to edit. For example, given +@Begin[ProgramExample] +lisp file.txt -edit +@End[ProgramExample] +Lisp will go immediately into @hemlock finding the file @f[file.txt]. + +@f<-slave [>@i[name]@f<]>@\ + This switch causes the Lisp process to become a slave of the editor process +@i[name]. An editor Lisp determines @i[name] when it allows connections from +slaves. Once the editor chooses a name, it keeps the same name until the +editor's Lisp process terminates. Since the editor can automatically create +slaves on its own machine, this switch is useful primarily for creating slaves +that run on a different machine. @f[hqb]'s machine is @f[ME.CS.CMU.EDU], and +he wants want to run a slave on @f[SLAVE.CS.CMU.EDU], then he should use the +@hid[Accept Slave Connections] command, telnet to the machine, and invoke Lisp +supplying @f[-slave] and the editor's name. The command displays the editor's +name. +@end[description] Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/mail.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/mail.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/mail.mss (revision 8058) @@ -0,0 +1,1343 @@ +@comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-} +@chap[The Mail Interface] +@section[Introduction to Mail in Hemlock] + +@index[MH interface]@label[introduction] +@hemlock provides an electronic mail handling facility via an interface to the +public domain @i[Rand MH Message Handling System]. This chapter assumes that +the user is familiar with the basic features and operation of @mh, but it +attempts to make allowances for beginners. Later sections of this chapter +discuss setting up @mh, profile components and special files for formatting +outgoing mail headers, and backing up protected mail directories on a +workstation. For more information on @mh, see the @i[Rand MH Message Handling +System Tutorial] and the @i[Rand MH Message Handling System Manual]. + +The @hemlock interface to @mh provides a means for generating header (@f[scan]) +lines for messages and displaying these headers in a @hid[Headers] buffer. +This allows the user to operate on the @i[current message] as indicated by the +position of the cursor in the @hid[Headers] buffer. The user can read, reply +to, forward, refile, or perform various other operations on the current +message. A user typically generates a @hid[Headers] buffer with the commands +@hid[Message Headers] or @hid[Incorporate and Read New Mail], and multiple such +buffers may exist simultaneously. + +Reading a message places its text in a @hid[Message] buffer. In a manner +similar to a @hid[Headers] buffer, this allows the user to operate on that +message. Most @hid[Headers] buffer commands behave the same in a @hid[Message] +buffer. For example, the @hid[Reply to Message] command has the same effect in +both @hid[Headers] mode and @hid[Message] mode. It creates a @hid[Draft] +buffer and makes it the current buffer so that the user may type a reply to the +current message. + +The @hid[Send Message] command originates outgoing mail. It generates a +@hid[Draft] buffer in which the user composes a mail message. Each @hid[Draft] +buffer has an associated pathname, so the user can save the buffer to a file as +necessary. Invoking @hid[Send Message] in a @hid[Headers] or @hid[Message] +buffer associates the @hid[Draft] buffer with a @hid[Message] buffer. This +allows the user to easily refer to the message being replied to with the +command @hid[Goto Message Buffer]. After the user composes a draft message, he +can deliver the message by invoking the @hid[Deliver Message] command in the +@hid[Draft] buffer (which deletes both the this buffer and any associated +@hid[Message] buffer), or he can delay this action. Invoking @hid[Deliver +Message] when not in a @hid[Draft] buffer causes it to prompt for a draft +message ID, allowing previously composed and saved messages to be delivered +(even across distinct Lisp invocations). + +@index[virtual message deletion] +The @hemlock mail system provides a mechanism for @i[virtual message deletion]. +That is, the @hid[Delete Message] command does not immediately delete a message +but merely flags the message for future deletion. This allows the user to +undelete the messages with the @hid[Undelete Message] command. The +@hid[Expunge Messages] command actually removes messages flagged for deletion. +After expunging a deleted message, @hid[Undelete Messages] can no longer +retrieve it. Commands that read messages by sequencing through a @hid[Headers] +buffer typically ignore those marked for deletion, which makes for more fluid +reading if a first pass has been made to delete uninteresting messages. + +After handling messages in a @hid[Headers] buffer, there may be messages +flagged for deletion and possibly multiple @hid[Message] buffers lying around. +There is a variety of commands that help @i[terminate] a mail session. +@hid[Expunge Messages] will flush the messages to be deleted, leaving the +buffer in an updated state. @hid[Delete Headers Buffer and Message Buffers] +will delete the @hid[Headers] buffer and its corresponding @hid[Message] +buffers. @hid[Quit Headers] is a combination of these two commands in that it +first expunges messages and then deletes all the appropriate buffers. + +One does not have to operate only on messages represented in a @hid[Headers] +buffer. This is merely the nominal mode of interaction. There are commands +that prompt for a folder, an @mh message specification (for example, "@f[1 3 6 +last]", "@f[1-3 5 6]", "@f[all]", "@f[unseen]"), and possibly a @f[pick] +expression. @f[Pick] expressions allow messages to be selected based on header +field pattern matching, body text searching, and date comparisons; these can be +specified using either a Unix shell-like/switch notation or a Lisp syntax, +according to one's preference. See section @ref[scanning] for more details. + +A @i[mail-drop] is a file where a Unix-based mail system stores all messages a +user receives. The user's mail handling program then fetches these from the +mail-drop, allowing the user to operate on them. Traditionally one locates his +mail-drop and mail directory on a mainframe machine because the information on +mainframes is backed up on magnetic tape at least once per day. Since @hemlock +only runs under CMU @clisp on workstations, and one's mail directory is not +usually world writable, it is not possible to adhere to a standard arrangement. +Since @mh provides for a remote mail-drop, and CMU's Remote File System has a +feature allowing authentication across a local area network, one can use +@hemlock to fetch his mail from a mainframe mail-drop (where it is backed up +before @hemlock grabs it) and store it on his workstation. Reading mail on a +workstation is often much faster and more comfortable because typically it is a +single user machine. Section @ref[backing-up] describes how to back up one's +mail directory from a workstation to a mainframe. + + +@section[Constraints on MH to use Hemlock's Interface] + +@index[constraints for mail interface]@label[constraints] +There are a couple constaints placed on the user of the @hemlock interface to +@mh. The first is that there must be a draft folder specified in one's @mh +profile to use any command that sends mail. Also, to read new mail, there must +be an @f[Unseen-Sequence:] component in one's @mh profile. The default @mh +profile does not specify these components, so they must be added by the user. +The next section of this chapter describes how to add these components. +Another constraint is that @hemlock requires its own @f[scan] line format to +display headers lines in a @hid[Headers] buffer. See the description of the +variable @hid[MH Scan Line Form] for details. + + +@section[Setting up MH] + +@index[setting up the mail interface]@label[setting-up] +@index[mail profile]@index[MH profile] +Get an @mh default profile and mail directory by executing the @mh @f[folder] +utility in a Unix shell. When it asks if it should make the "@f[inbox]" +folder, answer "@b[yes]". This creates a file called "@f[.mh_profile]" in the +user's home directory and a directory named "@f[Mail]". + +Edit the "@f[.mh_profile]" file inserting two additional lines. To send mail +in @hemlock, the user must indicate a draft folder by adding a +@f[Draft-Folder:] line with a draft folder name @dash "@f[drafts]" is a common +name: +@begin[example] +Draft-Folder: drafts +@end[example] + +Since the mail-drop exists on a remote machine, the following line must +also be added: +@begin[example] +MailDrop: /..//usr/spool/mail/ +@end[example] + +Since the user's mail-drop is on a separate machine from his mail directory +(and where the user runs @hemlock), it is necessary to issue the following +command from the Unix shell (on the workstation). This only needs to be done +once. +@begin[programexample] +/usr/cs/etc/rfslink -host /usr/spool/mail/ +@end[programexample] +Note that @b[] is not a full ARPANET domain-style name. Use an +abbreviated CMU host name (for example, "@b[spice]" not +"@b[spice.cs.cmu.edu]"). + + +@section[Profile Components and Customized Files] + +@subsection[Profile Components] + +@label[Profile] +The following are short descriptions about profile components that are either +necessary to using @hemlock@comment{}'s interface to @mh or convenient for using @mh in +general: + +@begin[description] +@f[Path:]@\ +This specifies the user's mail directory. It can be either a full pathname or +a pathname relative to the user's home directory. This component is +@i[necessary] for using @mh. + +@f[MailDrop:]@\ +This is used to specify one's remote mail-drop. It is @i[necessary] for +@hemlock only when using a mail-drop other than "@f[/usr/spool/mail/]" on +the local machine. + +@f[Folder-Protect:], @f[Msg-Protect:]@\ +These are set to 700 and 600 respectively to keep others from reading one's +mail. At one time the default values were set for public visibility of mail +folders. Though this is no longer true, these can be set for certainty. The +700 protection allows only user read, write, and execute (list access for +directories), and 600 allows only user read and write. These are not necessary +for either @mh or the @hemlock interface. + +@f[Unseen-Sequence:]@\ +When mail is incorporated, new messages are added to this sequence, and as +these messages are read they are removed from it. This allows the user at any +time to invoke an @mh program on all the unseen messges of a folder easily. An +example definition is: +@begin[example] +Unseen-Sequence: unseen +@end[example] +Specifying an unseen-sequence is @i[necessary] to use @hemlock@comment{}'s +interface to @mh. + +@f[Alternate-Mailboxes:]@\ +This is not necessary for either @mh or the @hemlock interface. This +component tells @mh which addresses that it should recognize as the user. This +is used for @f[scan] output formatting when the mail was sent by the user. It +is also used by @f[repl] when it sets up headers to know who the user is for +inclusion or exclusion from @b[cc]: lists. This is case sensitive and takes +wildcards. One example is: +@begin[example] +Alternate-Mailboxes: *FRED*, *Fred*, *fred* +@end[example] + +@f[Draft-Folder:]@\ +This makes multiple draft creation possible and trivial to use. Just supply a +folder name (for example, "@f[drafts]"). Specifying a draft-folder is +@i[necessary] to use @hemlock@comment{}'s interface to @mh. + +@f[repl: -cc all -nocc me -fcc out-copy]@\ +This tells the @f[repl] utility to include everyone but the user in the +@b[cc:] list when replying to mail. It also makes @f[repl] keep an copy of the +message the user sends. This is mentioned because one probably wants to reply +to everyone receiving a piece of mail except oneself. Unlike other utilities +that send mail, @f[repl] stores personal copies of outgoing mail based on a +command line switch. Other @mh utilities use different mechanisms. This line +is not necessary to use either @mh or the @hemlock interface. + +@f[rmmproc: /usr/cs/bin/rm]@\ +This is not necessary to use @hemlock@comment{}'s interface to @mh, but due to +@hemlock@comment{}'s virtual message deletion feature, this causes messages to be deleted +from folder directories in a cleaner fashion when they actually get removed. +Note that setting this makes @f[rmm] more treacherous if used in the Unix +shell. +@end[description] +@; + + +@subsection[Components Files] +@index[components] +@label[components-files] +@i[Components] files are templates for outgoing mail header fields that specify +position and sometimes values for specified fields. Example files are shown +for each one discussed here. These should exist in the user's mail directory. + +For originating mail there is a components file named "@f[components]", and it +is used by the @mh utility @f[comp]. An example follows: +@begin[example] + To: + cc: + fcc: out-copy + Subject: + -------- +@end[example] +This example file differs from the default by including the @f[fcc:] line. +This causes @mh to keep a copy of the outgoing draft message. Also, though it +isn't visible here, the @f[To:], @f[cc:], and @f[Subject:] lines have a space +at the end. + +@index[forwarding components] +The "@f[forwcomps]" components file is a template for the header fields of any +forwarded message. Though it may be different, our example is the same as the +previous one. These are distinct files for @mh@comment{}'s purposes, and it is more +flexible since the user might not want to keep copies of forwarded messages. + +@index[reply components] +The "@f[replcomps]" components file is a template for the header fields of any +draft message composed when replying to a message. An example +follows: +@begin[example] + %(lit)%(formataddr %<{reply-to}%|%<{from}%|%{sender}%>%>)\ + %<(nonnull)%(void(width))%(putaddr To: )\n%>\ + %(lit)%(formataddr{to})%(formataddr{cc})%(formataddr(me))\ + %(formataddr{resent-to})\ + %<(nonnull)%(void(width))%(putaddr cc: )\n%>\ + %<{fcc}Fcc: %{fcc}\n%>\ + %<{subject}Subject: Re: %{subject}\n%>\ + %<{date}In-reply-to: Your message of \ + %<(nodate{date})%{date}%|%(tws{date})%>.%<{message-id} + %{message-id}%>\n%>\ + -------- +@end[example] +This example file differs from the default by including the @b[resent-to:] +field (in addition to the @b[to:] and @b[cc:] fields) of the message being +replied to in the @b[cc:] field of the draft. This is necessary for replying +to all recipients of a distributed message. Keeping a copy of the outgoing +draft message works a little differently with reply components. @mh expects a +switch which the user can put in his profile (see section @ref[Profile] of this +chapter), and using the @mh formatting language, this file tests for the +@f[fcc] value as does the standard file. + + +@section[Backing up the Mail Directory] +@index[backing up mail directories] +@label[backing-up] +The easiest method of backing up a protected mail directory is to copy it into +an Andrew File System (AFS) directory since these are backed up daily as with +mainframes. The only problem with this is that the file servers may be down +when one wants to copy his mail directory since, at the time of this writing, +these servers are still under active development; however, they are becoming +more robust daily. One can read about the current AFS status in the file +@f[/../fac/usr/gripe/doc/vice/status]. + +Using AFS, one could keep his actual mail directory (not a copy thereof) in his +AFS home directory which eliminates the issue of backing it up. This is +additionally beneficial if the user does not use the same workstation everyday +(that is, he does not have his own but shares project owned machines). Two +problems with this arrangement result from the AFS being a distributed file +system. Besides the chance that the server will be down when the user wants to +read mail, performance degrades since messages must always be referenced across +the local area network. + +Facilities' official mechanism for backing up protected directories is called +@f[sup]. This is awkward to use and hard to set up, but a subsection here +describes a particular arrangement suitable for the user's mail directory. + + +@subsection[Andrew File System] +If the user choses to use AFS, he should get copies of @i[Getting Started with +the Andrew File System] and @i[Protecting AFS files and directories]. To use +AFS, send mail to Gripe requesting an account. When Gripe replies with a +password, change it to be the same as the account's password on the +workstation. This causes the user to be authenticated into AFS when he logs +into his workstation (that is, he is automatically logged into his AFS +account). To change the password, first log into the AFS account: +@begin[programexample] +log +@end[programexample] +Then issue the @f[vpasswd] command. + +All of the example command lines in this section assume the user has +@f[/usr/misc/bin] on his Unix shell @f[PATH] environment variable. + +@paragraph[Copy into AFS:] + +Make an AFS directory to copy into: +@begin[programexample] +mkdir /afs/cs.cmu.edu/user//mail-backup +@end[programexample] + +This will be readable by everyone, so protect it with the following: +@begin[programexample] +fs sa /afs/cs.cmu.edu/user//mail-backup System:AnyUser none +@end[programexample] + +Once the AFS account and directory to backup into have been established, the +user needs a means to recursively copy his mail directory updating only those +file that have changed and deleting those that no longer exist. To do this, +issue the following command: +@begin[programexample] +copy -2 -v -R +@end[programexample] +Do not terminate either of these directory specifications with a @f[/]. The +@f[-v] switch causes @f[copy] to output a line for copy and deletion, so this +may be eliminated if the user desires. + +@paragraph[Mail Directory Lives in AFS:] + +Assuming the AFS account has been established, and the user has followed the +directions in @ref[setting-up], now make an AFS directory to serve as the mail +directory: +@begin[programexample] +mkdir /afs/cs.cmu.edu/user//Mail +@end[programexample] + +This will be readable by everyone, so protect it with the following: +@begin[programexample] +fs sa /afs/cs.cmu.edu/user//Mail System:AnyUser none +@end[programexample] + +Tell @mh where the mail directory is by modifying the profile's +"@f[.mh_profile]" (see section @ref[setting-up]) @f[Path:] component (see +section @ref[Profile]): +@begin[programexample] +Path: /afs/cs.cmu.edu/user//Mail +@end[programexample] + + +@subsection[Sup to a Mainframe] +To use @f[sup] the user must set up a directory named "@f[sup]" on the +workstation in the user's home directory. This contains different directories +for the various trees that will be backed up, so there will be a "@f[Mail]" +directory. This directory will contain two files: "@f[crypt]" and "@f[list]". +The "@f[crypt]" file contains one line, terminated with a new line, that +contains a single word @dash an encryption key. "@f[list]" contains one line, +terminated with a new line, that contains two words @dash "@b[upgrade Mail]". + +On the user's mainframe, a file must be created that will be supplied to the +@f[sup] program. It should contain the following line to backup the mail +directory: + +@begin[example] +Mail delete host= hostbase=/usr/ base=/usr/ \ +crypt=WordInCryptFile login= password=LoginPasswordOnWorkstation +@end[example] +Warning: @i[This file contains the user's password and should be +protected appropriately.] + +The following Unix shell command issued on the mainframe will backup the +mail directory: + +@begin[programexample] + sup +@end[programexample] + +As a specific example, assume user "@f[fred]" has a workstation called +"@f[fred]", and his mainframe is the "@f[gpa]" machine where he has another +user account named "@f[fred]". The password on his workstation is +"@f[purple]". On his workstation, he creates the directory +"@f[/usr/fred/sup/Mail/]" with the two files "@f[crypt]" and "@f[list]". +The file "@f[/usr/fred/sup/Mail/crypt]" contains only the encryption key: +@programexample[steppenwolf] +The file "@f[/usr/fred/sup/Mail/list]" contains the command to upgrade the +"@f[Mail]" directory: +@programexample[upgrade Mail] + +On the "@f[gpa]" machine, the file "@f[/usr/fred/supfile]" contains the +following line: +@begin[programexample] +Mail delete host=fred hostbase=/usr/fred base=/usr/fred \ +crypt=steppenwolf login=fred password=purple +@end[programexample] +This file is protected on "@f[gpa]", so others cannot see @f[fred's] password +on his workstation. + +On the gpa-vax, issuing +@begin[programexample] + sup /usr/fred/supfile +@end[programexample] +to the Unix shell will update the @mh mail directory from @f[fred's] +workstation deleting any files that exist on the gpa that do not exist on the +workstation. + +For a more complete description of the features of @f[sup], see the @i[UNIX +Workstation Owner's Guide] and @i[The SUP Software Upgrade Protocol]. + +@section[Introduction to Commands and Variables] + +@index[mail commands]@index[mail variables]@label[mhcommands] +Unless otherwise specified, any command which prompts for a folder name will +offer the user a default. Usually this is @mh@comment{}'s idea of the current folder, +but sometimes it is the folder name associated with the current buffer if there +is one. When prompting for a message, any valid @mh message expression may be +entered (for example, "@f[1 3 6]", "@f[1-3 5 6]", "@f[unseen]", "@f[all]"). +Unless otherwise specified, a default will be offered (usually the current +message). + +Some commands mention specific @mh utilities, so the user knows how the +@hemlock command affects the state of @mh and what profile components and +special formatting files will be used. @hemlock runs the @mh utility programs +from a directory indicated by the following variable: + +@defhvar[var "MH Utility Pathname", val {"/usr/misc/.mh/bin/"}] +@mh utility names are merged with this pathname to find the executable +files. +@enddefhvar + + +@section[Scanning and Picking Messages] +@label[scanning] +As pointed out in the introduction of this chapter, users typically generate +headers or @f[scan] listings of messages with @hid[Message Headers], using +commands that operate on the messages represented by the headers. @hid[Pick +Headers] (bound to @bf[h] in @hid[Headers] mode) can be used to narrow down (or +further select over) the headers in the buffer. + +A @f[pick] expression may be entered using either a Lisp syntax or a Unix +shell-like/switch notation as described in the @mh documentation. The Lisp +syntax is as follows: + +@begin[example] + ::= {(not ) | (and *) | (or *) + | (cc ) | (date ) + | (from ) | (search ) + | (subject ) | (to ) + | (-- ) + | (before ) | (after ) + | (datefield )} + + ::= { | } + + ::= { | } + + ::= { | | } + + ::= +@end[example] + +Anywhere the user enters a @f[], its symbol name is used as a string. +Since @hemlock @f[read]s the expression without evaluating it, single quotes +("@bf[']") are unnecessary. From the @mh documentation, + +@begin[itemize] + A @f[] is a Unix @f[ed] regular expression. When using a string to + input these, remember that @f[\] is an escape character in Common Lisp. + + A @f[] is a header field name (for example, @b[reply-to] or + @b[resent-to]). + + A @f[] is an @i[822]-style specification, a day of the week, + "@b[today]", "@b[yesterday]", "@b[tomorrow]", or a number indicating @i[n] + days ago. The @i[822] standard is basically: + @begin[example] + dd mmm yy hh:mm:ss zzz + @end[example] + which is a two digit day, three letter month (first letter capitalized), two + digit year, two digit hour (@f[00] through @f[23]), two digit minute, two + digit second (this is optional), and a three letter zone (all capitalized). + For + example: + @begin[example] + 21 Mar 88 16:00 EST + @end[example] + + A @f[] is an alternate @f[Date:] field to use with @f[(before + )] and @f[(after )] such as @f[BB-Posted:] or + @f[Delivery-Date:]. + + Using @f[(before )] and @f[(after )] causes date field parsing, + while @f[(date )] does string pattern matching. +@end[itemize] + +Since a @f[] may be a symbol or string, it should be noted that the +symbol name is probably all uppercase characters, and @mh will match these +only against upper case. @mh will match lowercase characters against lower +and upper case. Some examples are: +@begin[example] + ;;; All messages to Gripe. + (to "gripe") + + ;;; All messages to Gripe or about Hemlock. + (or (to "gripe") (subject "hemlock")) + + ;;; All messages to Gripe with "Hemlock" in the body. + (and (to "gripe") (search "hemlock")) +@end[example] + +Matching of @f[] fields is case sensitive, so this example will +@f[pick] over all messages that have been replied to. +@example[(or (-- "replied" "") (-- "Replied" ""))] + + +@defhvar[var "MH Scan Line Form", val {"library:mh-scan"}] +This is a pathname of a file containing an @mh format expression used for +header lines. + +The header line format must display the message ID as the first non-whitespace +item. If the user uses the virtual message deletion feature which is on by +default, there must be a space three characters to the right of the message ID. +This location is used on header lines to note that a message is flagged for +deletion. The second space after the message ID is used for notating answered +or replied-to messages. +@enddefhvar + +@defcom[com "Message Headers", bind (C-x r)] +This command prompts for a folder, message (defaulting to "@b[all]"), and an +optional @f[pick] expression. Typically this will simply be used to generate +headers for an entire folder or sequence, and the @f[pick] expression will not +be used. A new @hid[Headers] buffer is made, and the output of @f[scan] on the +messages indicated is inserted into the buffer. The current window is used, +the buffer's point is moved to the first header, and the @hid[Headers] buffer +becomes current. The current value of the @hemlock @hid[Fill Column] variable +is supplied to @f[scan] as the @f[-width] switch. The buffer name is set to a +string of the form @w<"@f[Headers ]">, so the +modeline will show what is in the buffer. If no @f[pick] expression was +supplied, none will be shown in the buffer's name. As described in the +introduction to this section, the expression may be entered using either a Lisp +syntax or a Unix shell-like/switch notation. +@enddefcom + +@defhvar[var "MH Lisp Expression", val {t}] +When this is set, @mh expression prompts are read in a Lisp syntax. Otherwise, +the input is of the form of a Unix shell-like/switch notation as described in +the @mh documentation. +@enddefhvar + +@defcom[com "Pick Headers", stuff (bound to @bf[h] in @hid[Headers] mode) ] +This command is only valid in a @hid[Headers] buffer. It prompts for a +@f[pick] expression, and the messages shown in the buffer are supplied to +@f[pick] with the expression. The resulting messages are @f[scan]'ed, deleting +the previous contents of the buffer. The current value of @hid[Fill Column] is +used for the @f[scan]'ing. The buffer's point is moved to the first header. +The buffer's name is set to a string of the form @w<"@f[Headers ]">, so the modeline will show what is in the +buffer. As described in the introduction to this section, the expression may +be entered using either a Lisp syntax or a Unix shell-like/switch notation. +@enddefcom + +@defcom[com "Headers Help", bind (Headers: ?)] +This command displays documentation on @hid[Headers] mode. +@enddefcom + + +@section[Reading New Mail] + +@index[reading new mail]@label[reading-new-mail] + +@defcom[com "Incorporate and Read New Mail", stuff (bound to @bf[C-x i] globally and @bf[i] in @hid[Headers] and @hid[Message] modes) ] +This command incorporates new mail into @hid[New Mail Folder] and creates a +@hid[Headers] buffer with the new messages. An unseen-sequence must be define +in the user's @mh profile to use this. Any headers generated due to +@hid[Unseen Headers Message Spec] are inserted as well. The buffer's point is +positioned on the headers line representing the first unseen message of the +newly incorporated mail. +@enddefcom + +@defcom[com "Incorporate New Mail" ] +This command incorporates new mail into @hid[New Mail Folder], displaying +@f[inc] output in a pop-up window. This is similar to @hid[Incorporate and +Read New Mail] except that no @hid[Headers] buffer is generated. +@enddefcom + +@defhvar[var "New Mail Folder", val {"+inbox"}] +This is the folder into which @mh incorporates new mail. +@enddefhvar + +@defhvar[var "Unseen Headers Message Spec", val {nil}] +This is an @mh message specification that is suitable for any message prompt. +When incorporating new mail and after expunging messages, @hemlock uses this +specification in addition to the unseen-sequence name that is taken from the +user's @mh profile to generate headers for the unseen @hid[Headers] buffer. +This value is a string. +@enddefhvar + +@defhvar[var "Incorporate New Mail Hook", val {nil}] +This is a list of functions which are invoked immediately after new mail is +incorporated. The functions should take no arguments. +@enddefhvar + +@defhvar[var "Store Password", val {nil}] +When this is set, the user is only prompted once for his password, and the +password is stored for future use. +@enddefhvar + +@defhvar[var "Authenticate Incorporation", val {nil}] +@defhvar1[var "Authentication User Name", val {nil}] +When @hid[Authenticate Incorporation] is set, incorporating new mail prompts +for a password to access a remote mail-drop. + +When incorporating new mail accesses a remote mail-drop, @hid[Authentication +User Name] is the user name supplied for authentication on the remote machine. +If this is @nil, @hemlock uses the local name. +@enddefhvar + + +@section[Reading Messages] +@index[reading messages] +@label[reading-messages] +This section describes basic commands that show the current, next, and previous +messages, as well as a couple advanced commands. @hid[Show Message] (bound to +@bf[SPACE] in @hid[Headers] mode) will display the message represented by the +@f[scan] line the @hemlock cursor is on. Deleted messages are considered +special, and the more conveniently bound commands for viewing the next and +previous messages (@hid[Next Undeleted Message] bound to @bf[n] and +@hid[Previous Undeleted Message] bound to @bf[p], both in @hid[Headers] and +@hid[Message] modes) will ignore them. @hid[Next Message] and @hid[Previous +Message] (bound to @bf[M-n] and @bf[M-p] in @hid[Headers] and @hid[Message] +modes) may be invoked if reading a message is desired regardless of whether it +has been deleted. + + +@defcom[com "Show Message", stuff (bound to @bf[SPACE] and @bf[.] in @hid[Headers] mode) ] + This command, when invoked in a @hid[Headers] buffer, displays the current +message (the message the cursor is on), by replacing any previous message that +has not been preserved with @hid[Keep Message]. The current message is also +removed from the unseen sequence. The @hid[Message] buffer becomes the current +buffer using the current window. The buffer's point will be moved to the +beginning of the buffer, and the buffer's name will be set to a string of the +form @w<"@f[Message ]">. + +The @hid[Message] buffer is read-only and may not be modified. The command +@hid[Goto Headers Buffer] issued in the @hid[Message] buffer makes the +associated @hid[Headers] buffer current. + +When not in a @hid[Headers] buffer, this command prompts for a folder and +message. A unique @hid[Message] buffer is obtained, and its name is set to a +string of the form @w<"@f[Message ]">. The buffer's point is +moved to the beginning of the buffer, and the current window is used to display +the message. + +Specifying multiple messages inserts all the messages into the same buffer. If +the user wishes to show more than one message, it is expected that he will +generate a @hid[headers] buffer with the intended messages, and then use the +message sequencing commands described below. +@enddefcom + +@defcom[com "Next Message", stuff (bound to @bf[M-n] in @hid[Headers] and @hid[Message] modes) ] + This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] +buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the +point is moved to the next message, and if there is one, it is shown as +described in the @hid[Show Message] command. + +In a @hid[Message] buffer, the message after the currently visible message is +displayed. This clobbers the buffer's contents. Note, if the @hid[Message] +buffer is associated with a @hid[Draft] buffer, invoking this command breaks +that association. Using @hid[Keep Message] preserves the @hid[Message] buffer +and any association with a @hid[Draft] buffer. + +The @hid[Message] buffer's name is set as described in the @hid[Show Message] +command. +@enddefcom + +@defcom[com "Previous Message", stuff (bound to @bf[M-p] in @hid[Headers] and @hid[Message] modes) ] + This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] +buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the +point is moved to the previous message, and if there is one, it is shown as +described in the @hid[Show Message] command. + +In a @hid[Message] buffer, the message before the currently visible message is +displayed. This clobbers the buffer's contents. Note, if the @hid[Message] +buffer is associated with a @hid[Draft] buffer, invoking this command breaks +that association. Using @hid[Keep Message] preserves the @hid[Message] buffer +and any association with a @hid[Draft] buffer. + +The @hid[Message] buffer's name is set as described in the @hid[Show Message] +command. +@enddefcom + +@defcom[com "Next Undeleted Message", stuff (bound to @bf[n] in @hid[Headers] and @hid[Message] modes) ] + This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] +buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the +point is moved to the next undeleted message, and if there is one, it is shown +as described in the @hid[Show Message] command. + +In a @hid[Message] buffer, the first undeleted message after the currently +visible message is displayed. This clobbers the buffer's contents. Note, if +the @hid[Message] buffer is associated with a @hid[Draft] buffer, invoking this +command breaks that association. The @hid[Keep Message] command preserves the +@hid[Message] buffer and any association with a @hid[Draft] buffer. + +The @hid[Message] buffer's name is set as described in the @hid[Show Message] +command. +@enddefcom + +@defcom[com "Previous Undeleted Message", stuff (bound to @bf[p] in @hid[Headers] and @hid[Message] modes) ] + This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] +buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the +point is moved to the previous undeleted message, and if there is one, it is +shown as described in the @hid[Show Message] command. + +In a @hid[Message] buffer, the first undeleted message before the currently +visible message is displayed. This clobbers the buffer's contents. Note, if +the @hid[Message] buffer is associated with a @hid[Draft] buffer, invoking this +command breaks that association. The @hid[Keep Message] command preserves the +@hid[Message] buffer and any association with a @hid[Draft] buffer. + +The @hid[Message] buffer's name is set as described in the @hid[Show Message] +command. +@enddefcom + +@defcom[com "Scroll Message", stuff (bound to @bf[SPACE] and @bf[C-v] in @hid[Message] mode) ] +@defhvar1[var "Scroll Message Showing Next", val {t}] + This command scrolls the current window down through the current message. If +the end of the message is visible and @hid[Scroll Message Showing Next] is not +@nil, then show the next undeleted message. +@enddefcom + +@defcom[com "Keep Message" ] +This command can only be invoked in a @hid[Message] buffer. It causes the +@hid[Message] buffer to continue to exist when the user invokes commands to +view other messages either within the kept @hid[Message] buffer or its +associated @hid[Headers] buffer. This is useful for getting two messages into +different buffers. It is also useful for retaining @hid[Message] buffers which +would otherwise be deleted when an associated draft message is delivered. +@enddefcom + +@defcom[com "Message Help", bind (Message: ?)] +This command displays documentation on @hid[Message] mode. +@enddefcom + + +@section[Sending Messages] +@index[sending messages] +@label[sending-messages] +The most useful commands for sending mail are @hid[Send Message] (bound to +@bf[m] and @bf[s] in @hid[Headers] and @hid[Message] modes), @hid[Reply to +Message] (bound to @bf[r] in @hid[Headers] mode), and @hid[Reply to Message in +Other Window] (bound to @bf[r] in @hid[Message] mode). These commands set up a +@hid[Draft] buffer and associate a @hid[Message] buffer with the draft when +possible. To actually deliver the message to its recipient(s), use +@hid[Deliver Message] (bound to @bf[H-s] in @hid[Draft] mode). To abort +sending mail, use @hid[Delete Draft and Buffer] (bound to @bf[H-q] in +@hid[Draft] mode). If one wants to temporarily stop composing a draft with the +intention of finishing it later, then the @hid[Save File] command (bound to +@bf[C-x C-s]) will save the draft to the user's draft folder. + +@hid[Draft] buffers have a special @hemlock minor mode called @hid[Draft] mode. +The major mode of a @hid[Draft] buffer is taken from the @hid[Default Modes] +variable. The user may wish to arrange that @hid[Text] mode (and possibly +@hid[Fill] mode or @hid[Save] mode) be turned on whenever @hid[Draft] mode is +set. For a further description of how to manipulate modes in @hemlock see the +@i[Hemlock Command Implementor's Manual]. + + +@defcom[com "Send Message", stuff (bound to @bf[s] and @bf[m] in @hid[Headers] and @hid[Message] modes and @bf[C-x m] globally) ] + This command, when invoked in a @hid[Headers] buffer, creates a unique +@hid[Draft] buffer and a unique @hid[Message] buffer. The current message is +inserted in the @hid[Message] buffer, and the @hid[Draft] buffer is displayed +in the current window. The @hid[Draft] buffer's point is moved to the end of +the line containing @f[To:] if it exists. The name of the draft message file +is used to produce the buffer's name. A pathname is associated with the +@hid[Draft] buffer so that @hid[Save File] can be used to incrementally save a +composition before delivering it. The @f[comp] utility will be used to +allocate a draft message in the user's @mh draft folder and to insert the +proper header components into the draft message. Both the @hid[Draft] and +@hid[Message] buffers are associated with the @hid[Headers] buffer, and the +@hid[Draft] buffer is associated with the @hid[Message] buffer. + +When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is created, +and these two buffers are associated. If the @hid[Message] buffer is +associated with a @hid[Headers] buffer, this association is propagated to the +@hid[Draft] buffer. Showing other messages while in this @hid[Headers] buffer +will not affect this @hid[Message] buffer. + +When not in a @hid[Headers] or @hid[Message] buffer, this command does the same +thing as described in the previous two cases, but there are no @hid[Message] or +@hid[Headers] buffer manipulations. + +@hid[Deliver Message] will deliver the draft to its intended recipient(s). + +The @hid[Goto Headers Buffer] command, when invoked in a @hid[Draft] or +@hid[Message] buffer, makes the associated @hid[Headers] buffer current. The +@hid[Goto Message Buffer] command, when invoked in a @hid[Draft] buffer, makes +the associated @hid[Message] buffer current. +@enddefcom + +@defcom[com "Reply to Message", stuff (bound to @bf[r] in @hid[Headers] mode) ] +@defcom1[com "Reply to Message in Other Window", stuff (bound to @bf[r] in @hid[Message] mode) ] +@defhvar1[var "Reply to Message Prefix Action"] + @hid[Reply to Message], when invoked in a @hid[Headers] buffer, creates a +unique @hid[Draft] buffer and a unique @hid[Message] buffer. The current +message is inserted in the @hid[Message] buffer, and the @hid[Draft] buffer is +displayed in the current window. The draft components are set up in reply to +the message, and the @hid[Draft] buffer's point is moved to the end of the +buffer. The name of the draft message file is used to produce the buffer's +name. A pathname is associated with the @hid[Draft] buffer so that @hid[Save +File] can be used to incrementally save a composition before delivering it. +The @f[repl] utility will be used to allocate a draft message file in the +user's @mh draft folder and to insert the proper header components into the +draft message. Both the @hid[Draft] and @hid[Message] buffers are associated +with the @hid[Headers] buffer, and the @hid[Draft] buffer is associated with +the @hid[Message] buffer. + +When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is set up +using the message in the buffer as the associated message. Any previous +association between the @hid[Message] buffer and a @hid[Draft] buffer is +removed. Any association of the @hid[Message] buffer with a @hid[Headers] +buffer is propagated to the @hid[Draft] buffer. + +When not in a @hid[Headers] buffer or @hid[Message] buffer, this command +prompts for a folder and message to reply to. This message is inserted into a +unique @hid[Message] buffer, and a unique @hid[Draft] buffer is created as in +the previous two cases. There is no association of either the @hid[Message] +buffer or the @hid[Draft] buffer with a @hid[Headers] buffer. + +When a prefix argument is supplied, @hid[Reply to Message Prefix Action] is +considered with respect to supplying carbon copy switches to @f[repl]. This +variable's value is one of @b[:cc-all], :@b[no-cc-all], or @nil. See section +@ref[Styles] for examples of how to use this. + +@hid[Reply to Message in Other Window] is identical to @hid[Reply to Message], +but the current window is split showing the @hid[Draft] buffer in the new +window. The split window displays the @hid[Message] buffer. + +@hid[Deliver Message] will deliver the draft to its intended recipient(s). + +The @hid[Goto Headers Buffer] commmand, when invoked in a @hid[Draft] or +@hid[Message] buffer, makes the associated @hid[Headers] buffer current. The +@hid[Goto Message Buffer] command, when invoked in a @hid[Draft] buffer, makes +the associated @hid[Message] buffer current. +@enddefcom + +@defcom[com "Forward Message", stuff (bound to @bf[f] in @hid[Headers] and @hid[Message] modes) ] + This command, when invoked in a @hid[Headers] buffer, creates a unique +@hid[Draft] buffer. The current message is inserted in the draft by using the +@f[forw] utility, and the @hid[Draft] buffer is shown in the current window. +The name of the draft message file is used to produce the buffer's name. A +pathname is associated with the @hid[Draft] buffer so that @hid[Save File] can +be used to incrementally save a composition before delivering it. The +@hid[Draft] buffer is associated with the @hid[Headers] buffer, but no +@hid[Message] buffer is created since the message is already a part of the +draft. + +When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is set up +inserting the message into the @hid[Draft] buffer. The @hid[Message] buffer is +not associated with the @hid[Draft] buffer because the message is already a +part of the draft. However, any association of the @hid[Message] buffer with a +@hid[Headers] buffer is propagated to the @hid[Draft] buffer. + +When not in a @hid[Headers] buffer or @hid[Message] buffer, this command +prompts for a folder and message to forward. A @hid[Draft] buffer is created +as described in the previous two cases. + +@hid[Deliver Message] will deliver the draft to its intended recipient(s). +@enddefcom + +@defcom[com "Deliver Message", stuff (bound to @bf[H-s] and @bf[H-c] in @hid[Draft] mode) ] +@defhvar1[var "Deliver Message Confirm", val {nil}] + This command, when invoked in a @hid[Draft] buffer, saves the file and uses +the @mh @f[send] utility to deliver the draft. If the draft is a reply to some +message, then @f[anno] is used to annotate that message with a "@f[replied]" +component. Any @hid[Headers] buffers containing the replied-to message are +updated with an "@b[A]" placed in the appropriate headers line two characters +after the message ID. Before doing any of this, confirmation is asked for +based on @hid[Deliver Message Confirm]. + +When not in a @hid[Draft] buffer, this prompts for a draft message ID and +invokes @f[send] on that draft message to deliver it. Sending a draft in this +way severs any association that draft may have had with a message being replied +to, so no annotation will occur. +@enddefcom + +@defcom[com "Delete Draft and Buffer", stuff (bound to @bf[H-q] in @hid[Draft] mode) ] +This command, when invoked in a @hid[Draft] buffer, deletes the draft message +file and the buffer. This also deletes any associated message buffer unless +the user preserved it with @hid[Keep Message]. +@enddefcom + +@defcom[com "Remail Message", stuff (bound to @bf[H-r] in @hid[Headers] and @hid[Message] modes) ] + This command, when invoked in a @hid[Headers] or @hid[Message] buffer, prompts +for resend @f[To:] and resend @f[Cc:] addresses, remailing the current message. +When invoked in any other kind of buffer, this command prompts for a folder and +message as well. @mh@comment{}'s @f[dist] sets up a draft folder message which is then +modified. The above mentioned addresses are inserted on the @f[Resent-To:] and +@f[Resent-Cc:] lines. Then the message is delivered. + +There is no mechanism for annotating messages as having been remailed. +@enddefcom + +@defcom[com "Draft Help", bind (Draft: H-?)] +This command displays documentation on @hid[Draft] mode. +@enddefcom + + +@section[Convenience Commands for Message and Draft Buffers] +@index[message buffer commands] +@index[draft buffer commands] +@index[convenience commands for mail interface] +@label[convenience-coms] +This section describes how to switch from a @hid[Message] or @hid[Draft] buffer +to its associated @hid[Headers] buffer, or from a @hid[Draft] buffer to its +associated @hid[Message] buffer. There are also commands for various styles of +inserting text from a @hid[Message] buffer into a @hid[Draft] buffer. + +@defcom[com "Goto Headers Buffer", stuff (bound to @bf[^] in @hid[Message] mode and @bf[H-^] in @hid[Draft] mode) ] +This command, when invoked in a @hid[Message] or @hid[Draft] buffer with an +associated @hid[Headers] buffer, places the associated @hid[Headers] buffer in +the current window. + +The cursor is moved to the headers line of the associated message. +@enddefcom + +@defcom[com "Goto Message Buffer", stuff (bound to @bf[H-m] in @hid[Draft] mode) ] +This command, when invoked in a @hid[Draft] buffer with an associated +@hid[Message] buffer, places the associated @hid[Message] buffer in the current +window. +@enddefcom + +@defcom[com "Insert Message Region", stuff (bound to @bf[H-y] in appropriate modes) ] +@defhvar1[var "Message Insertion Prefix", val {" "}] +@defhvar1[var "Message Insertion Column", val {75}] +This command, when invoked in a @hid[Message] or @hid[News-Message] (where it +is bound) buffer that has an associated @hid[Draft] or @hid[Post] buffer, +copies the current active region into the @hid[Draft] or @hid[Post] buffer. It +is filled using @hid[Message Insertion Prefix] (which defaults to three spaces) +and @hid[Message Insertion Column]. If an argument is supplied, the filling is +inhibited. +@enddefcom + +@defcom[com "Insert Message Buffer", stuff (bound to @bf[H-y] in appropriate modes) ] +@defhvar1[var "Message Buffer Insertion Prefix", val {" "}] +This command, when invoked in a @hid[Draft] or @hid[Post] (where it is bound) +buffer with an associated @hid[Message] or @hid[News-Message] buffer, or when +in a @hid[Message] (or @hid[News-Message]) buffer that has an associated +@hid[Draft] buffer, inserts the @hid[Message] buffer into the @hid[Draft] (or +@hid[Post]) buffer. Each inserted line is modified by prefixing it with +@hid[Message Buffer Insertion Prefix] (which defaults to four spaces) . If an +argument is supplied, the prefixing is inhibited. +@enddefcom + +@defcom[com "Edit Message Buffer", stuff (bound to @bf[e] in @hid[Message] mode) ] +This command puts the current @hid[Message] buffer in @hid[Text] mode and makes +it writable (@hid[Message] buffers are normally read-only). The pathname of +the file which the message is in is associated with the buffer making saving +possible. A recursive edit is entered, and the user is allowed to make changes +to the message. When the recursive edit is exited, if the buffer is modified, +the user is asked if the changes should be saved. The buffer is marked +unmodified, and the pathname is disassociated from the buffer. The buffer +otherwise returns to its previous state as a @hid[Message] buffer. If the +recursive edit is aborted, the user is not asked to save the file, and the +buffer remains changed though it is marked unmodified. +@enddefcom + + +@section[Deleting Messages] +@index[deleting messages] +@label[deleting] +The main command described in this section is @hid[Headers Delete Message] +(bound to @bf[k] in @hid[Headers] and @hid[Message] modes). A useful command +for reading new mail is @hid[Delete Message and Show Next] (bound to @bf[d] in +@hid[Message] mode) which deletes the current message and shows the next +undeleted message. + +Since messages are by default deleted using a virtual message deletion +mechanism, @hid[Expunge Messages] (bound to @bf[!] in @hid[Headers] mode) +should be mentioned here. This is described in section @ref[terminating]. + + +@defhvar[var "Virtual Message Deletion", val {t}] +When set, @hid[Delete Message] adds a message to the "@f[hemlockdeleted]" +sequence; otherwise, @f[rmm] is invoked on the message immediately. +@enddefhvar + +@defcom[com "Delete Message" ] +This command prompts for a folder, messages, and an optional @f[pick] +expression. When invoked in a @hid[Headers] buffer of the specified folder, +the prompt for a message specification will default to the those messages in +that @hid[Headers] buffer. + +When the variable @hid[Virtual Message Deletion] is set, this command merely +flags the messages for deletion by adding them to the "@f[hemlockdeleted]" +sequence. Then this updates any @hid[Headers] buffers representing the folder. +It notates each headers line referring to a deleted message with a "@b[D]" in +the third character position after the message ID. + +When @hid[Virtual Message Deletion] is not set, @f[rmm] is invoked on the +message, and each headers line referring to the deleted message is deleted from +its buffer +@enddefcom + +@defcom[com "Headers Delete Message", stuff (bound to @bf[k] in @hid[Headers] and @hid[Message] modes) ] +This command, when invoked in a @hid[Headers] buffer, deletes the message on +the current line as described in @hid[Delete Message]. + +When invoked in a @hid[Message] buffer, the message displayed in it is deleted +as described in @hid[Delete Message]. +@enddefcom + +@defcom[com "Delete Message and Show Next", stuff (bound to @bf[k] in @hid[Headers] and @hid[Message] modes) ] +This command is only valid in a @hid[Headers] buffer or a @hid[Message] buffer +associated with some @hid[Headers] buffer. The current message is deleted as +with the @hid[Delete Message] command. Then the next message is shown as with +@hid[Next Undeleted Message]. +@enddefcom + +@defcom[com "Delete Message and Down Line", stuff (bound to @bf[d] in @hid[Headers mode])] +This command, when invoked in a @hid[Headers] buffer, deletes the message on +the current line. Then the point is moved to the next non-blank line. +@enddefcom + +@defcom[com "Undelete Message" ] +This command is only meaningful when @hid[Virtual Message Deletion] is set. +This prompts for a folder, messages, and an optional @f[pick] expression. When +in a @hid[Headers] buffer of the specified folder, the messages prompt defaults +to those messages in the buffer. All @hid[Headers] buffers representing the +folder are updated. Each headers line referring to an undeleted message is +notated by replacing the "@b[D]" in the third character position after the +message ID with a space. +@enddefcom + +@defcom[com "Headers Undelete Message", stuff (bound to @bf[u] in @hid[Headers] and @hid[Message] modes) ] +This command is only meaningful when @hid[Virtual Message Deletion] is set. +When invoked in a @hid[Headers] buffer, the message on the current line is +undeleted as described in @hid[Undelete Message]. + +When invoked in a @hid[Message] buffer, the message displayed in it is +undeleted as described in @hid[Undelete Message]. +@enddefcom + + +@section[Folder Operations] + +@index[folder operations]@label[folder] +@defcom[com "List Folders" ] +This command displays a list of all current mail folders in the user's +top-level mail directory in a @hemlock pop-up window. +@enddefcom + +@defcom[com "Create Folder"] +This command prompts for and creates a folder. If the folder already exists, +an error is signaled. +@enddefcom + +@defcom[com "Delete Folder" ] +This command prompts for a folder and uses @f[rmf] to delete it. Note that no +confirmation is asked for. +@enddefcom + + +@section[Refiling Messages] + +@index[refiling messages]@label[refiling] +@defcom[com "Refile Message" ] +This command prompts for a folder, messages, an optional @f[pick] expression, +and a destination folder. When invoked in a @hid[Headers] buffer of the +specified folder, the message prompt offers a default of those messages in the +buffer. If the destination folder does not exist, the user is asked to create +it. The resulting messages are refiled with the @f[refile] utility. All +@hid[Headers] buffers for the folder are updated. Each line referring to a +refiled message is deleted from its buffer. +@enddefcom + +@defcom[com "Headers Refile Message", stuff (bound to @bf[o] in @hid[Headers] and @hid[Message] modes) ] +This command, when invoked in a @hid[Headers] buffer, prompts for a destination +folder, refiling the message on the current line with @f[refile]. If the +destination folder does not exist, the user is asked to create it. Any +@hid[Headers] buffers containing messages for that folder are updated. Each +headers line referring to the refiled message is deleted from its buffer. + +When invoked in a @hid[Message] buffer, that message is refiled as described +above. +@enddefcom + + +@section[Marking Messages] +@index[marking messages] +@label[marking] +@defcom[com "Mark Message" ] +This command prompts for a folder, message, and sequence and adds (deletes) the +message specification to (from) the sequence. By default this adds the +message, but if an argument is supplied, this deletes the message. When +invoked in a @hid[Headers] buffer or @hid[Message] buffer, this only prompts +for a sequence and uses the current message. +@enddefcom + + +@section[Terminating Headers Buffers] +@label[terminating] +The user never actually @i[exits] the mailer. He can leave mail buffers lying +around while conducting other editing tasks, selecting them and continuing his +mail handling whenever. There still is a need for various methods of +terminating or cleaning up @hid[Headers] buffers. The two most useful commands +in this section are @hid[Expunge Messages] and @hid[Quit Headers]. + + +@defhvar[var "Expunge Messages Confirm", val {t}] +When this is set, @hid[Quit Headers] and @hid[Expunge Messages] will ask for +confirmation before expunging messages and packing the folder's message ID's. +@enddefhvar + +@defhvar[var "Temporary Draft Folder", val {nil}] +This is a folder name where @mh @f[fcc:] messages are kept with the intention +that this folder's messages will be deleted and expunged whenever messages from +any folder are expunged (for example, when @hid[Expunge Messages] or @hid[Quit +Headers] is invoked. +@enddefhvar + +@defcom[com "Expunge Messages", stuff (bound to @bf[!] in @hid[Headers] mode) ] +This command deletes messages @f[mark]'ed for deletion, and compacts the +folder's message ID's. If there are messages to expunge, ask the user for +confirmation, displaying the folder name. This can be inhibited by setting +@hid[Expunge Messages Confirm] to @nil. When @hid[Temporary Draft Folder] is +not @nil, this command deletes and expunges that folder's messages regardless +of the folder in which the user invokes it, and a negative response to the +request for confirmation inhibits this. + +When invoked in a @hid[Headers] buffer, the messages in that folder's +"@f[hemlockdeleted]" sequence are deleted by invoking @f[rmm]. Then the ID's +of the folder's remaining messages are compacted using the @f[folder] utility. +Since headers must be regenerated due to renumbering or reassigning message +ID's, and because @hid[Headers] buffers become inconsistent after messages are +deleted, @hemlock must regenerate all the headers for the folder. Multiple +@hid[Headers] buffers for the same folder are then collapsed into one buffer, +deleting unnecessary duplicates. Any @hid[Message] buffers associated with +these @hid[Headers] buffers are deleted. + +If there is an unseen @hid[Headers] buffer for the folder, it is handled +separately from the @hid[Headers] buffers described above. @hemlock tries to +update it by filling it only with remaining unseen message headers. +Additionally, any headers generated due to @hid[Unseen Headers Message Spec] +are inserted. If there are no headers, unseen or otherwise, the buffer is left +blank. + +Any @hid[Draft] buffer set up as a reply to a message in the folder is affected +as well since the associated message has possibly been deleted. When a draft +of this type is delivered, no message will be annotated as having been replied +to. + +When invoked in a @hid[Message] buffer, this uses its corresponding folder as +the folder argument. The same updating as described above occurs. + +In any other type of buffer, a folder is prompted for. +@enddefcom + +@defcom[com "Quit Headers", stuff (bound to @bf[q] in @hid[Headers] and @hid[Message] modes) ] +This command affects the current @hid[Headers] buffer. When there are deleted +messages, ask the user for confirmation on expunging the messages and packing +the folder's message ID's. This prompting can be inhibited by setting +@hid[Expunge Messages Confirm] to @nil. After deleting and packing, this +deletes the buffer and all its associated @hid[Message] buffers. + +Other @hid[Headers] buffers regarding the same folder are handled as described +in @hid[Expunge Messages], but the buffer this command is invoked in is always +deleted. + +When @hid[Temporary Draft Folder] is not @nil, this folder's messages are +deleted and expunged regardless of the folder in which the user invokes this +command. A negative response to the above mentioned request for confirmation +inhibits this. +@enddefcom + +@defcom[com "Delete Headers Buffer and Message Buffers" ] +This command prompts for a @hid[Headers] buffer to delete along with its +associated @hid[Message] buffers. Any associated @hid[Draft] buffers are left +intact, but their corresponding @hid[Message] buffers will be deleted. When +invoked in a @hid[Headers] buffer or a @hid[Message] buffer associated with a +@hid[Headers] buffer, that @hid[Headers] buffer is offered as a default. +@enddefcom + + +@section[Miscellaneous Commands] +@label[miscellaneous mail commands] +@label[miscellaneous] + +@defcom[com "List Mail Buffers", stuff (bound to @bf[l] in @hid[Headers] and @hid[Message] modes @bf[H-l] in @hid[Draft] mode) ] +This command shows a list of all mail @hid[Message], @hid[Headers], and +@hid[Draft] buffers. + +If a @hid[Message] buffer has an associated @hid[Headers] buffer, it is +displayed to the right of the @hid[Message] buffer's name. + +If a @hid[Draft] buffer has an associated @hid[Message] buffer, it is displayed +to the right of the @hid[Draft] buffer's name. If a @hid[Draft] buffer has no +associated @hid[Message] buffer, but it is associated with a @hid[Headers] +buffer, then the name of the @hid[Headers] buffer is displayed to the right of +the @hid[Draft] buffer. + +For each buffer listed, if it is modified, then an asterisk is displayed before +the name of the buffer. +@enddefcom + + +@section[Styles of Usage] +@index[styles of mail interface usage] +@label[Styles] +This section discusses some styles of usage or ways to make use of some of the +features of @hemlock@comment{}'s interface to @mh that might not be obvious. In each +case, setting some variables and/or remembering an extra side effect of a +command will lend greater flexibility and functionality to the user. + +@subsection[Unseen Headers Message Spec] +The unseen @hid[Headers] buffer by default only shows unseen headers which is +adequate for one folder, simple mail handling. Some people use their @hid[New +Mail Folder] only for incoming mail, refiling or otherwise dispatching a +message immediately. Under this mode it is easy to conceive of the user not +having time to respond to a message, but he would like to leave it in this +folder to remind him to take care of it. Using the @hid[Unseen Headers Message +Spec] variable, the user can cause all the messages the @hid[New Mail Folder] to +be inserted into the unseen @hid[Headers] buffer whenever just unseen headers +would be. This way he sees all the messages that require immediate attention. + +To achieve the above effect, @hid[Unseen Headers Message Spec] should be set to +the string @f["all"]. This variable can be set to any general @mh message +specification (see section @ref[mhcommands] of this chapter), so the user can +include headers of messages other than those that have not been seen without +having to insert all of them. For example, the user could set the variable to +@f["flagged"] and use the @hid[Mark Message] command to add messages he's +concerned about to the @f["flagged"] sequence. Then the user would see new +mail and interesting mail in his unseen @hid[Headers] buffer, but he doesn't +have to see everything in his @hid[New Mail Folder]. + + +@subsection[Temporary Draft Folder] +Section @ref[components-files] of this chapter discusses how to make @mh keep +personal copies of outgoing mail. The method described will cause a copy of +every outgoing message to be saved forever and requires the user to go through +his @f[Fcc:] folder, weeding out those he does not need. The @hid[Temporary +Draft Folder] variable can name a folder whose messages will be deleted and +expunged whenever any folder's messages are expunged. By naming this folder in +the @mh profile and components files, copies of outgoing messages can be saved +temporarily. They will be cleaned up automatically, but the user still has a +time frame in which he can permanently save a copy of an outgoing message. +This folder can be visited with @hid[Message Headers], and messages can be +refiled just like any other folder. + + +@subsection[Reply to Message Prefix Action] +Depending on the kinds of messages one tends to handle, the user may find +himself usually replying to everyone who receives a certain message, or he may +find that this is only desired occasionally. In either case, the user +can set up his @mh profile to do one thing by default, using the @hid[Reply +to Message Prefix Action] variable in combination with a prefix argument to the +@hid[Reply to Message] command to get the other effect. + +For example, the following line in one's @mh profile will cause @mh to reply to +everyone receiving a certain message (except for the user himself since he +saves personal copies with the @f[-fcc] switch): +@begin[programexample] +repl: -cc all -nocc me -fcc out-copy +@end[programexample] +This user can set @hid[Reply to Message Prefix Action] to be @f[:no-cc-all]. +Then whenever he invokes @hid[Reply to Message] with a prefix argument, instead +of replying to everyone, the draft will be set up in reply only to the person +who sent the mail. + +As an alternative example, not specifying anything in one's @mh profile and +setting this variable to @f[:cc-all] will have a default effect of replying +only to the sender of a piece of mail. Then invoking @hid[Reply to Message] +with a prefix argument will cause everyone who received the mail to get a copy +of the reply. If the user does not want a @f[cc:] copy, then he can add +@f[-nocc me] as a default switch and value in his @mh profile. + + +@newpage +@section[Wallchart] + +@tabclear +@tabdivide(3) + +@begin[format, spacing 1.5] + +@Begin[Center] @b[Global bindings:] @End[Center] + +@hid[Incorporate and Read New Mail]@\@\@bf[C-x i] +@hid[Send Message]@\@\@bf[C-x m] +@hid[Message Headers]@\@\@bf[C-x r] + + +@Begin[Center] @b[Headers and Message modes bindings:] @End[Center] + +@hid[Next Undeleted Message]@\@\@bf[n] +@hid[Previous Undeleted Message]@\@\@bf[p] +@hid[Send Message]@\@\@bf[s], @bf[m] +@hid[Forward Message]@\@\@bf[f] +@hid[Headers Delete Message]@\@\@bf[k] +@hid[Headers Undelete Message]@\@\@bf[u] +@hid[Headers Refile Message]@\@\@bf[o] +@hid[List Mail Buffers]@\@\@bf[l] +@hid[Quit Headers]@\@\@bf[q] +@hid[Incorporate and Read New Mail]@\@\@bf[i] +@hid[Next Message]@\@\@bf[M-n] +@hid[Previous Message]@\@\@bf[M-p] +@hid[Beginning of Buffer]@\@\@bf[<] +@hid[End of Buffer]@\@\@bf[>] + + +@Begin[Center] @b[Headers mode bindings:] @End[Center] + +@hid[Delete Message and Down Line]@\@\@bf[d] +@hid[Pick Headers]@\@\@bf[h] +@hid[Show Message]@\@\@bf[space], @bf[.] +@hid[Reply to Message]@\@\@bf[r] +@hid[Expunge Messages]@\@\@bf[!] + + +@Begin[Center] @b[Message mode bindings:] @End[Center] + +@hid[Delete Message and Show Next]@\@\@bf[d] +@hid[Goto Headers Buffer]@\@\@bf[^] +@hid[Scroll Message]@\@\@bf[space] +@hid[Scroll Message]@\@\@bf[C-v] +@hid[Scroll Window Up]@\@\@bf[backspace], @bf[delete] +@hid[Reply to Message in Other Window]@\@bf[r] +@hid[Edit Message Buffer]@\@\@bf[e] +@hid[Insert Message Region]@\@\@bf[H-y] + + +@Begin[Center] @b[Draft mode bindings:] @End[Center] + +@hid[Goto Headers Buffer]@\@\@bf[H-^] +@hid[Goto Message Buffer]@\@\@bf[H-m] +@hid[Deliver Message]@\@\@bf[H-s], @bf[H-c] +@hid[Insert Message Buffer]@\@\@bf[H-y] +@hid[Delete Draft and Buffer]@\@\@bf[H-q] +@hid[List Mail Buffers]@\@\@bf[H-l] + +@end[format] +@tabclear Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/netnews.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/netnews.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/netnews.mss (revision 8058) @@ -0,0 +1,488 @@ +@comment{-*- Dictionary: /afs/cs/project/clisp/docs/hem/hem; Mode: spell; Package: Hemlock -*-} + +@chap[The Hemlock Netnews Interface] +@section[Introduction to Netnews in Hemlock] + + +@hemlock provides a facility for reading bulletin boards through the +NetNews Transfer Protocol (NNTP). You can easily read Netnews, reply to +news posts, post messages, etc. The news reading interface is consistent +with that of the @hemlock mailer, and most Netnews commands function in the +same manner as their mailer counterparts. + +Netnews can be read in one of two different modes. The first mode, invoked +by the @hid(Netnews) command, allows the user to read new messages in +groups which the user has specified. This method of reading netnews will +track the highest numbered message in each newsgroup and only show new +messages which have arrived since then. The @hid(Netnews Browse) command +invokes the other method of reading netnews. This mode displays a list of +all newsgroups, and the user may choose to read messages in any of them. +By default, the news reader will not track the latest message read when +browsing, and it will always display the last few messages. + + +@section[Setting Up Netnews] + +To start reading bulletin boards from @hemlock you probably need to create a +file containing the newsgroups you want to read. + +@defhvar[var "Netnews Group File", val {".hemlock-groups"}] + When you invoke the @hid(Netnews) command, @hemlock merges the value of + this variable with your home directory and looks there for a list of + groups (one per line) to read. +@enddefhvar + +@defhvar[var "Netnews Database File", val{".hemlock-netnews"}] +When you invoke the @hid(Netnews) command, @hemlock merges the value of +this variable with your home directory. This file maintains a pointer to +the highest numbered message read in each group in @hid(Netnews Group +File). +@enddefhvar + +@defcom[com "List All Groups"] + When you invoke this command, @hemlock creates a buffer called + @hid(Netnews Groups) and inserts the names of all accessible Netnews + groups into it alphabetically. You may find this useful if you choose to set + up your @hid(Netnews Group File) manually. +@enddefcom + +@defhvar[var "Netnews NNTP Server", val{"netnews.srv.cs.cmu.edu"}] +This variable stores the host name of the machine which @hemlock will use +as the NNTP server. +@enddefhvar + +@defhvar[var "Netnews NNTP Timeout Period", val{30}] +This is the number of seconds @hemlock will wait trying to connect to the +NNTP server. If a connection is not made within this time period, the +connection will time out and an error will be signalled. +@enddefhvar + +@subsection[News-Browse Mode] + + @hid(News-Browse) mode provides an easy method of adding groups to + your @hid(Netnews Group File). + +@defcom[com "Netnews Browse"] + This command sets up a buffer in @hid{News-Browse} mode with all + available groups listed one per line. Groups may be read or added + to your group file using various commands in this mode. +@enddefcom + +@defcom[com "Netnews Browse Add Group To File", stuff (bound to @bf[a] in @hid[News-Browse] mode)] +@defcom1[com "Netnews Browse Pointer Add Group to File"] +@hid(Netnews Browse Add Group to File) adds the group under the point to +your group file, and @hid(Netnews Browse Pointer Add Group To File) adds +the group under the mouse pointer without moving the point. +@enddefcom + +@defcom[com "Netnews Browse Read Group", stuff (bound to @bf[space] in @hid[News-Browse] mode)] +@defcom1[com "Netnews Browse Pointer Read Group"] +@hid(Netnews Browse Read Group) and @hid(Netnews Browse Pointer Read Group) +read the group under the cursor and the group under the mouse pointer, +respectively. These commands neither use nor modify the contents of your +@hid(Netnews Database File); they will always present the last few messages +in the newsgroup, regardless of the last message read. @hid(Netnews Browse +Pointer Read Group) does not modify the position of the point. +@enddefcom + +@defcom[com "Netnews Quit Browse"] + This command exits @hid(News-Browse) mode. +@enddefcom + +The @hid(Next Line) and @hid(Previous Line) commands are conveniently bound to +@bf[n] and @bf[p] in this mode. + +@section[Starting Netnews] + +Once your @hid(Netnews Group File) is set up, you may begin reading netnews. + +@defcom[com "Netnews"] + This command is the main entry point for reading bulletin boards in + @hemlock. Without an argument, the system looks for what bulletin boards to + read in the value of @hid(Netnews Group File) and reads each of them in + succession. @hemlock keeps a pointer to the last message you read in each + of these groups in your @hid(Netnews Database File). Bulletin boards may + be added to your @hid(Netnews Group File) manually or by using + the @hid(Netnews Browse) facility. With an argument, @hemlock prompts the + user for the name of a bulletin board and reads it. +@enddefcom + +@defcom[com "Netnews Look at Group"] + This command prompts for a group and reads it, ignoring the information + in your @hid(Netnews Database File). +@enddefcom + +When you read a group, @hemlock creates a buffer that contains important +header information for the messages in that group. There are four fields +in each header, one each for the @i(date), @i(lines), @i(from), and +@i(subject). The @i(date) field shows when the message was sent, the +@i(lines) field displays how long the message is in lines, the @i(from) +field shows who sent the message, and the @i(subject) field displays the +subject of this message. If a field for a message is not available, @f(NA) +will appear instead. You may alter the length of each of these fields by +modifying the following @hemlock variables: + +@defhvar[var "Netnews Before Date Field Pad", val 1] + How many spaces should be inserted before the date in @hid(News-Headers) + buffers. +@enddefhvar + +@defhvar[var "Netnews Date Field Length", val 6] +@defhvar1[var "Netnews Line Field Length", val 3] +@defhvar1[var "Netnews From Field Length", val 20] +@defhvar1[var "Netnews Subject Field Length", val 43] + These variables control how long the @i(date), @i(line), @i(from), and + @i(subject) fields should be in @hid{News-Headers} buffers. +@enddefhvar + +@defhvar[var "Netnews Field Padding", val 2] + How many spaces should be left between the Netnews @i(date), @i(from), + @i(lines), and @i(subject) fields after padding to the required length. +@enddefhvar + +For increased speed, @hemlock only inserts headers for a subset of the +messages in each group. If you have never read a certain group, and the +value of @hid(Netnews New Group Style) is @f(:from-end) (the default), +@hemlock inserts some number of the last messages in the group, determined +by the value of @hid(Netnews Batch Count). If the value of @hid(Netnews +New Group Style) is @f(:from-start), @hemlock will insert the first batch +of messages in the group. If you have read a group before, @hemlock will +insert the batch of messages following the highest numbered message that +you had read previously. + +@defhvar[var "Netnews Start Over Threshold", val {350}] + If the number of new messages in a group exceeds the value of this + variable and @hid(Netnews New Group Style) is @f(:from-end), @hemlock asks + if you would like to start reading this group from the end. +@enddefhvar + +You may at any time go beyond the messages that are visible using the +@hid(Netnews Next Line), @hid(Netnews Previous Line), +@hid(Netnews Headers Scroll Window Up), and +@hid(Netnews Headers Scroll Down) commands in @hid(News-Headers) mode, +or the @hid(Netnews Next Article) and @hid(Netnews Previous Article) +commands in @hid(News-Message) mode. + +@defhvar[var "Netnews Fetch All Headers", val {nil}] +This variable determines whether Netnews will fetch all headers immediately +upon entering a new group. +@enddefhvar + +@defhvar[var "Netnews Batch Count", val {50}] + This variable determines how many headers the Netnews facility will fetch + at a time. +@enddefhvar + +@defhvar[var "Netnews New Group Style", val {:from-end}] +This variable determines what happens when you read a group that you have +never read before. When it is @f(:from-start), the @hid(Netnews) command +will read from the beginning of a new group forward. When it is @f(:from-end), +the default, @hid(Netnews) will read the group from the end backward. +@enddefhvar + +@section[Reading Messages] + +From a @hid{News-Headers} buffer, you may read messages, reply to messages +via the @hemlock mailer, or reply to messages via post. Some commands are +also bound to ease getting from one header to another. + +@defcom[com "Netnews Show Article", stuff (bound to @bf[space] in @hid{News-Headers} mode)] +@defhvar1[var "Netnews Read Style", val {:multiple}] +@defhvar1[var "Netnews Headers Proportion", val {0.25}] +This command puts the body of the message header under the current point +into a @hid{News-Message} buffer. If the value of @hid(Netnews Read +Style) is @f(:single), @hemlock changes to the @hid{News-Message} +buffer. If it is @f(:multiple), then @hemlock splits the current window +into two windows, one for headers and one for message bodies. The headers +window takes up a proportion of the current window based on the value of +@hid(Netnews Headers Proportion). If the window displaying the +@hid(News-Headers) buffer has already been split, and the message +currently displayed in the @hid(News-Message) window is the same as the +one under the current point, this command behaves just like @hid(Netnews +Message Scroll Down). +@enddefcom + +@defhvar[var "Netnews Message Header Fields", val {nil}] + When this variable is @nil, all available fields are displayed in the + header of a message. Otherwise, this variable should containt a list of + fields to include in message headers. If an element of this + list is an atom, then it should be the string name of a field. If it is + a cons, then the car should be the string name of a field, and the cdr + should be the length to which this field should be limited. Any string + name is acceptable, and fields that do not exist are ignored. +@enddefhvar + +@defcom[com "Netnews Show Whole Header", stuff (bound to @bf[w] in @hid{News-Headers} and @hid{News-Message} modes.)] +This command displays the entire header for the message currently being +read. This is to undo the effects of @hid{Netnews Message Header Fields} +for the current message. +@enddefcom + +@defcom[com "Netnews Next Line", stuff (bound to @bf[C-n] and @bf[Downarrow] in @hid{News-Headers} mode)] +@defhvar1[var "Netnews Last Header Style", val {:next-headers}] +This command moves the current point to the next line. If you are on the +last visible message, and there are more in the current group, headers for +these messages will be inserted. If you are on the last header and there +are no more messages in this group, then @hemlock will take some action +based on the value of @hid(Netnews Last Header Style). If the value of +this variable is @f(:feep), @hemlock feeps you indicating there are no +more messages. If the value is @f(:next-headers), @hemlock reads in the +headers for the next group in your @hid(Netnews Group File). If the value +is @f(:next-article), @hemlock goes on to the next group and shows you +the first unread message. +@enddefcom + +@defcom[com "Netnews Previous Line", stuff (bound to @bf[C-p] and @bf[Uparrow] in @hid{News-Headers} mode)] +This command moves the current point to the previous line. If you are on +the first visible header, and there are more previous messages, @hemlock +inserts the headers for these messages. +@enddefcom + +@defcom[com "Netnews Headers Scroll Window Down", stuff (bound to @bf[C-v] in @hid{News-Headers} mode)] +@defcom1[com "Netnews Headers Scroll Window Up", stuff (bound to @bf[M-v] in @hid{News-Headers} mode)] + These commands scroll the headers window up or down one screenfull. If the + end of the buffer is visible, @hemlock inserts the next batch of headers. +@enddefcom + +@defcom[com "Netnews Next Article", stuff (bound to @bf[n] in @hid{News-Message} and @hid{News-Headers} modes)] +@defcom1[com "Netnews Previous Article", stuff (bound to @bf[p] in @hid{News-Message} and @hid{News-Headers} modes)] + These commands insert the next or previous message into a message buffer. +@enddefcom + +@defcom[com "Netnews Message Scroll Down", stuff (bound to @bf[space] in @hid{News-Message} mode)] +@defhvar1[var "Netnews Scroll Show Next Message", val {t}] +If the end of the current message is visible, @hemlock feeps the user if +the value of @hid(Netnews Scroll Show Next Message) is non-@nil, or it +inserts the next message into this message buffer if that variable is @nil. +If the end of the message is not visible, then @hemlock shows the next +screenfull of the current message. +@enddefcom + +@defcom[com "Netnews Message Quit", stuff (bound to @bf[q] in @hid{News-Message} mode)] + This command deletes the current message buffer and makes the associated + @hid{News-Headers} buffer current. +@enddefcom + +@defcom[com "Netnews Goto Headers Buffer", stuff (bound to @bf[H-h] in @hid{News-Message} mode)] + This command, when invoked from a @hid(News-Message) buffer with an + associated @hid(News-Headers) buffer, places the associated + @hid(News-Headers) buffer into the current window. +@enddefcom + +@defcom[com "Netnews Message Keep Buffer", stuff (bound to @bf[k] in @hid{News-Message} mode)] + By default, @hemlock uses one buffer to display all messages in a group, + one at a time. This command tells @hemlock to keep the current message + buffer intact and start reading messages in another buffer. +@enddefcom + +@defcom[com "Netnews Select Message Buffer", stuff (bound to @bf[H-m] in @hid{News-Headers} and @hid{Post} modes.)] + In @hid{News-Headers} mode, this command selects the buffer + containing the last message read. In @hid{Post} mode, it selects the + associated @hid{News-Message} buffer, if there is one. +@enddefcom + +@defcom[com "Netnews Append to File", stuff (bound to @bf[a] in @hid{News-Headers} and @hid{News-Message} modes.)] +@defhvar1[var "Netnews Message File", val {"netnews-messages.txt"}] +This command prompts for a file which the current message will be appended +to. The default file is the value of @hid(Netnews Message File) merged +with your home directory. +@enddefcom + +@defcom[com "Netnews Headers File Message", stuff (bound to @bf[o] in @hid{News-Headers} mode)] +This command prompts for a mail folder and files the message under the +point into it. If the folder does not exist, @hemlock will ask if it should +be created. +@enddefcom + +@defcom[com "Netnews Message File Message", stuff (bound to @bf[o] in @hid{News-Message} mode)] +This command prompts for a mail folder and files the current message there. +If the folder does not exist, @hemlock will ask if it should be created. +@enddefcom + +@defcom[com "Fetch All Headers", stuff (bound to @bf[f] in @hid{Netnews Headers} mode)] + In a forward reading @hid(Netnews headers) buffer, this command inserts + all headers after the last visible one into the headers buffer. If + @hemlock is reading this group backward, the system inserts all headers + before the first visible one into the headers buffer. +@enddefcom + +@defcom[com "Netnews Go to Next Group", stuff (bound to @bf[g] in @hid{News-Headers} and @hid{News-Message} modes.)] +This command goes to the next group in your @hid(Netnews Group File). +Before going on, it sets the group pointer in @hid(Netnews Database +Filename) to the last message you read. With an argument, the command does +not modify the group pointer for the current group. +@enddefcom + +@defcom[com "Netnews Quit Starting Here", stuff (bound to @bf[.] in @hid{News-Headers} and @hid{News-Message} modes)] + This command goes to the next group in your @hid(Netnews Group File), + setting the netnews pointer for this group to the message before the one + under the current point, so the next time you read this group, the message + indicated by the point will appear first. +@enddefcom + +@defcom[com "Netnews Group Punt Messages", stuff (bound to @bf[G] in @hid{News-Headers} mode)] + This command goes on to the next bulletin board in your group + file. Without an argument, the system sets the pointer for the current + group to the last message. With an argument, @hemlock sets the + pointer to the last visible message in the group. +@enddefcom + +@defcom[com "Netnews Exit", stuff (bound to @bf[q] in @hid{News-Headers} mode)] +@defhvar1[var "Netnews Exit Confirm", val {t}] + This command cleans up and deletes the @hid(News-Headers) buffer and + all associated @hid(News-Message) buffers. If the value of + @hid(Netnews Exit Confirm) is @nil, then @hemlock will not prompt before + exiting. +@enddefcom + +@section[Replying to Messages] + +The @hemlock Netnews interface also provides an easy way of replying to +messages through the @hemlock Mailer or via @hid{Post} mode. + +@defcom[com "Netnews Reply to Sender"] + When you invoke this command, @hemlock creates a @hid(Draft) buffer and + tries to fill in the @i(to) and @i(subject) fields of the draft. For + the @i(to) field, @hemlock looks at the @i(reply-to) field of the + message you are replying to, or failing that, the @i(from) field. If + the @i(subject) field does not start with @f(Re:), @hemlock inserts this + string, signifying that this is a reply. +@enddefcom + +@defcom[com "Netnews Reply to Sender in Other Window", stuff (bound to @bf[r] in @hid{News-Headers} and @hid{News-Message}.)] +This command splits the current window, placing the message you are +replying to in the top window and a new @hid{Draft} buffer in the bottom +one. This command fills in the header fields in the same manner as +@hid(Netnews Reply to Sender). +@enddefcom + +@defcom[com "Netnews Reply to Group"] +This command creates a @hid{Post} buffer with the @i(newsgroups) field set +to the current group and the @i(subject) field constructed in the same way +as in @hid(Netnews Reply to Sender). +@enddefcom + +@defcom[com "Netnews Reply to Group in Other Window", stuff (bound to @bf[R] in @hid{News-Headers} and @hid{News-Message}.)] + This command splits the current window, placing the message you are + replying to in the top window and a new @hid{Post} buffer in the bottom + one. This command will fill in the header fields in the same manner as + @hid(Netnews Reply to Group). +@enddefcom + +@defcom[com "Netnews Post Message", stuff (bound to @bf[C-x P])] + This command creates a @hid{Post} buffer. If you are in a + @hid(News-Headers) or @hid{News-Message} buffer, @hemlock fills in the + @i(newsgroups) field with the current group. +@enddefcom + +@defcom[com "Netnews Forward Message", stuff (bound to @bf[f] in @hid{News-Headers} and @hid{News-Message} modes.)] +This command creates a @hid{Post} buffer. If you are in a @hid{Netnews +Headers} or @hid{News-Message} buffer, @hemlock will put the text of the +current message into the buffer along with lines delimiting the forwarded +message. +@enddefcom + +@defcom[com "Netnews Goto Post Buffer", stuff (bound to @bf[H-p] in @hid{News-Message} mode)] + This command, when invoked in a @hid(News-Message) or @hid(Draft) buffer + with an associated @hid(News-Headers) buffer, places the associated + @hid(News-Headers) buffer into the current window. +@enddefcom + +@defcom[com "Netnews Goto Draft Buffer", stuff (bound to @bf[H-d] in @hid{News-Message} mode)] + This command, when invoked in a @hid(News-Message) buffer with an + associated @hid(Draft) buffer, places the @hid(Draft) buffer into the + current window. +@enddefcom + +@section[Posting Messages] + +@defcom[com "Netnews Deliver Post", stuff (bound to @bf[H-s] in @hid{Post} mode)] +@defhvar1[var "Netnews Deliver Post Confirm", val "t"] +This command delivers the contents of a @hid(Post) buffer to the NNTP +server. If @hid(Netnews Deliver Post Confirm) is @f(t), @hemlock will ask for +confirmation before posting the message. @hemlock feeps you if NNTP does +not accept the message. +@enddefcom + +@defcom[com "Netnews Abort Post", stuff (bound to @bf[H-q] in @hid{Post} mode)] + This command deletes the current @hid(Post) buffer. +@enddefcom + + +As in the mailer, when replying to a message you can be excerpt sections of +it using @hid(Insert Message Buffer) and @hid(Insert Message Region) in +@hid(Post) and @hid(News-Message) modes, respectively. You can also use +these commands when replying to a message via mail in a @hid(Draft) buffer. +In all cases, the same binding is used: @bf[H-y]. + +@newpage +@section[Wallchart] + +@tabclear +@tabdivide(5) + +@begin[format, spacing 1.5] + + +@Begin[Center] @b[Global bindings:] @End[Center] + +@hid[Netnews Post Message]@\@\@bf[C-x P] + + +@Begin[Center] @b[News-Headers and News-Message modes bindings:] @End[Center] + +@hid[Netnews Next Article]@\@\@\@bf[n] +@hid[Netnews Previous Article]@\@\@bf[p] +@hid[Netnews Go to Next Group]@\@\@bf[g] +@hid[Netnews Group Punt Messages]@\@\@bf[G] +@hid[List All Groups]@\@\@\@bf[l] +@hid[Netnews Append to File]@\@\@bf[a] +@hid[Netnews Forward Message]@\@\@bf[f] +@hid[Netnews Reply to Sender in Other Window]@\@\@bf[r] +@hid[Netnews Reply to Group in Other Window]@\@\@bf[R] +@hid[Netnews Quit Starting Here]@\@\@bf[.] + +@Begin[Center] @b[News-Headers mode bindings:] @End[Center] + +@hid[Netnews Show Article]@\@\@bf[Space] +@hid[Netnews Previous Line]@\@\@bf[C-p], @bf[Uparrow] +@hid[Netnews Next Line]@\@\@\@bf[C-n], @bf[Downarrow] +@hid[Netnews Headers Scroll Window Down]@\@\@bf[C-v] +@hid[Netnews Headers Scroll Window Up]@\@\@bf[M-v] +@hid[Netnews Select Message Buffer]@\@\@bf[H-m] +@hid[Netnews Exit]@\@\@\@bf[q] +@hid[Netnews Headers File Message]@\@\@bf[o] + + +@Begin[Center] @b[News-Message mode bindings:] @End[Center] + +@hid[Netnews Message Scroll Down]@\@\@bf[Space] +@hid[Scroll Window Up]@\@\@\@bf[Backspace] +@hid[Netnews Goto Headers Buffer]@\@\@bf[H-h], @bf[^] +@hid[Netnews Message Keep Buffer]@\@\@bf[k] +@hid[Netnews Message Quit]@\@\@bf[q] +@hid[Netnews Message File Message]@\@\@bf[o] +@hid[Netnews Goto Post Buffer]@\@\@bf[H-p] +@hid[Netnews Goto Draft Buffer]@\@\@bf[H-d] +@hid[Insert Message Region]@\@\@bf[H-y] + + +@Begin[Center] @b[Post mode bindings:] @End[Center] + +@hid[Netnews Select Message Buffer]@\@\@bf[H-m] +@hid[Netnews Deliver Post]@\@\@bf[H-s] +@hid[Netnews Abort Post]@\@\@\@bf[H-q] +@hid[Insert Message Buffer]@\@\@bf[H-y] + + +@Begin[Center] @b[News-Browse mode bindings:] @End[Center] + +@hid[Netnews Quit Browse]@\@\@bf[q] +@hid[Netnews Browse Add Group To File]@\@\@bf[a] +@hid[Netnews Browse Read Group]@\@\@bf[Space] +@hid[Next Line]@\@\@\@bf[n] +@hid[Previous Line]@\@\@\@bf[p] + + +@end[format] +@tabclear Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/special-modes.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/special-modes.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/special-modes.mss (revision 8058) @@ -0,0 +1,738 @@ +@comment{-*- Dictionary: bld:scribe/hem/hem; Mode: spell; Package: Hemlock -*-} +@chap[Special Modes] + +@section[Dired Mode] +@label[dired] +@index[directory editing] + +@hemlock provides a directory editing mechanism. The user can flag files and +directories for deletion, undelete flagged files, and with a keystroke read in +files and descend into directories. In some implementations, it also supports +copying, renaming, and a simple wildcard feature. + + +@subsection[Inspecting Directories] +@defcom[com "Dired", bind (C-x C-M-d)] +This command prompts for a directory and fills a buffer with a verbose listing +of that directory. When the prefix argument is supplied, this includes Unix +dot files. If a dired buffer already exists for the directory, this switches +to the buffer and makes sure it displays dot files if appropriate. +@enddefcom + +@defcom[com "Dired with Pattern", bind (C-x C-M-d)] +This command prompts for a directory and a pattern that may contain at most one +wildcard, an asterisk, and it fills a buffer with a verbose listing of the +files in the directory matching the pattern. When the prefix argument is +supplied, this includes Unix dot files. If a dired buffer already exists for +this directory, this switches to the buffer and makes sure it displays dot +files if appropriate. +@enddefcom + +@defcom[com "Dired from Buffer Pathname"] +This command invokes @hid[Dired] on the directory name of the current buffer's +pathname. +@enddefcom + +@defcom[com "Dired Help", bind (Dired: ?)] +This command pops up a help window listing the various @hid[Dired] commands. +@enddefcom + +@defcom[com "Dired View File", bind (Dired: Space)] +@defcom1[com "Dired Edit File", bind (Dired: e)] +These command read in the file on the current line with the point. If the line +describes a directory instead of a file, then this command effectively invokes +@hid[Dired] on the specification. This associates the file's buffer with the +@hid[Dired] buffer. + +@hid[Dired View File] reads in the file as if by @hid[View File], and +@hid[Dired Edit File] as if by @hid[Find File]. + +@hid[Dired View File] always reads into a newly created buffer, warning if the +file already exists in some buffer. +@enddefcom + +@defcom[com "Dired Up Directory", bind (Dired: ^)] +This command invokes @hid[Dired] on the directory up one level from the current +@hid[Dired] buffer. This is useful for going backwards after repeatedly +invoking @hid[Dired View File] and descending into a series of subdirectories. +Remember, @hid[Dired] only generates directory listings when no buffer contains +a dired for the specified directory. +@enddefcom + +@defcom[com "Dired Update Buffer", bind (Dired: H-u)] +This command is useful when the user knows the directory in the current +@hid[Dired] buffer has changed. @hemlock cannot know the directory structure +has changed, but the user can explicitly update the buffer with this command +instead of having to delete it and invoke @hid[Dired] again. +@enddefcom + +@defcom[com "Dired Next File"] +@defcom1[com "Dired Previous File"] +These commands move to next or previous undeleted file. +@enddefcom + + +@subsection[Deleting Files] +@defcom[com "Dired Delete File and Down Line", bind (Dired: d)] +This command marks for deletion the file on the current line with the point and +moves point down a line. +@enddefcom + +@defcom[com "Dired Delete File with Pattern", bind (Dired: D)] +This command prompts for a name pattern that may contain at most one wildcard, +an asterisk, and marks for deletion all the names matching the pattern. +@enddefcom + +@defcom[com "Dired Delete File", bind (Dired: C-d)] +This command marks for deletion the file on the current line with the point +without moving the point. +@enddefcom + + +@subsection[Undeleting Files] +@defcom[com "Dired Undelete File and Down Line", bind (Dired: u)] +This command unmarks for deletion the file on the current line with the point +and moves point down a line. +@enddefcom + +@defcom[com "Dired Undelete File with Pattern", bind (Dired: U)] +This command prompts for a name pattern that may contain at most one wildcard, +an asterisk, and unmarks for deletion all the names matching the pattern. +@enddefcom + +@defcom[com "Dired Undelete File", bind (Dired: C-u)] +This command unmarks for deletion the file on the current line with the point +without moving the point. +@enddefcom + + +@subsection[Expunging and Quitting] +@defcom[com "Dired Expunge Files", bind (Dired: !)] +@defhvar1[var "Dired File Expunge Confirm", val {t}] +@defhvar1[var "Dired Directory Expunge Confirm", val {t}] +This command deletes files marked for deletion, asking the user for +confirmation once for all the files flagged. It recursively deletes any marked +directories, asking the user for confirmation once for all those marked. +@hid[Dired File Expunge Confirm] and @hid[Dired Directory Expunge Confirm] when +set to @nil individually inhibit the confirmation prompting for the appropriate +deleting. +@enddefcom + +@defcom[com "Dired Quit", bind (Dired: q)] +This command expunges any marked files or directories as if by @hid[Expunge +Dired Files] before deleting the @hid[Dired] buffer. +@enddefcom + + +@subsection[Copying Files] +@defcom[com "Dired Copy File", bind (Dired: c)] +This command prompts for a destination specification and copies the file on the +line with the point. When prompting, the current line's specification is the +default, which provides some convenience in supplying the destination. The +destination is either a directory specification or a file name, and when it is +the former, the source is copied into the directory under its current file name +and extension. +@enddefcom + +@defcom[com "Dired Copy with Wildcard", bind (Dired: C)] +This command prompts for a name pattern that may contain at most one wildcard, +an asterisk, and copies all the names matching the pattern. When prompting for +a destination, this provides the @hid[Dired] buffer's directory as a default. +The destination is either a directory specification or a file name with a +wildcard. When it is the former, all the source files are copied into the +directory under their current file names and extensions. When it is the later, +each sources file's substitution for the wildcard causing it to match the first +pattern replaces the wildcard in the destination pattern; for example, you +might want to copy @f["*.txt"] to @f["*.text"]. +@enddefcom + +@defhvar[var "Dired Copy File Confirm", val {t}] +@label[copy-confirm] +This variable controls interaction with the user when it is not obvious what +the copying process should do. This takes one of the following values: +@Begin[Description] +@true@\ +When the destination specification exists, the copying process stops and asks +the user if it should overwrite the destination. + +@nil@\ +The copying process always copies the source file to the destination +specification without interacting with the user. + +@kwd[update]@\ +When the destination specification exists, and its write date is newer than +the source's write date, then the copying process stops and asks the user if it +should overwrite the destination. +@End[Description] +@enddefhvar + + +@subsection[Renaming Files] +@defcom[com "Dired Rename File", bind (Dired: r)] +Rename the file or directory under the point +@enddefcom + +@defcom[com "Dired Rename with Wildcard", bind (Dired: R)] +Rename files that match a pattern containing ONE wildcard. +@enddefcom + +@defhvar[var "Dired Rename File Confirm", val {t}] +When non-nil, @hid[Dired] will query before clobbering an existing file. +@enddefhvar + + +@section[View Mode] +@hid[View] mode provides for scrolling through a file read-only, terminating +the buffer upon reaching the end. + +@defcom[com "View File"] +This command reads a file into a new buffer as if by "Visit File", but +read-only. Bindings exist for scrolling and backing up in a single key stroke. +@enddefcom + +@defcom[com "View Help", bind (View: ?)] +This command shows a help message for @hid[View] mode. +@enddefcom + +@defcom[com "View Edit File", bind (View: e)] +This commands makes a buffer in @hid[View] mode a normal editing buffer, +warning if the file exists in another buffer simultaneously. +@enddefcom + +@defcom[com "View Scroll Down", bind (View: Space)] +@defhvar1[var "View Scroll Deleting Buffer", val {t}] +This command scrolls the current window down through its buffer. If the end of +the file is visible, then this deletes the buffer if @hid[View Scroll Deleting +Buffer] is set. If the buffer is associated with a @hid[Dired] buffer, this +returns there instead of to the previous buffer. +@enddefcom + +@defcom[com "View Return", bind (View: ^)] +@defcom1[com "View Quit", bind (View: q)] +These commands invoke a function that returns to the buffer that created the +current buffer in @hid[View] mode. Sometimes this function does nothing, but +it is useful for returning to @hid[Dired] buffers and similar @hemlock +features. + +After invoking the viewing return function if there is one, @hid[View Quit] +deletes the buffer that is current when the user invokes it. +@enddefcom + +Also, bound in @hid[View] mode are the following commands: +@Begin[Description] +@binding[backspace], @binding[delete]@\Scrolls the window up. + +@binding[<]@\Goes to the beginning of the buffer. + +@binding[>]@\Goes to the end of the buffer. +@End[Description] + + +@section[Process Mode] +@Label[process] +@Index[shells] +@Index[processes] + +@hid[Process] mode allows the user to execute a Unix process within a @hemlock +buffer. These commands and default bindings cater to running Unix shells in +buffers. For example, @hid[Stop Buffer Subprocess] is bound to @binding[H-z] +to stop the process you are running in the shell instead of binding @hid[Stop +Main Process] to this key which would stop the shell itself. + +@defcom[com "Shell", bind (C-M-s)] +@defhvar1[var "Shell Utility", val {"/bin/csh"}] +@defhvar1[var "Shell Utility Switches", val {@nil}] +@defhvar1[var "Current Shell"] +@defhvar1[var "Ask about Old Shells"] +This command executes the process determined by the values of @hid(Shell +Utility) and @hid(Shell Utility Switches) in a new buffer named @f["Shell n"] +where @f["n"] is some distinguishing integer. + +@hid[Current Shell] is a @hemlock variable that holds to the current shell +buffer. When @hid[Shell] is invoked, if there is a @hid[Current Shell], the +command goes to that buffer. + +When there is no @hid[Current Shell], but shell buffers do exist, if @hid[Ask +about Old Shells] is set, the @hid[Shell] command prompts for one of them, +setting @hid[Current Shell] to the indicated shell, and goes to the buffer. + +Invoking @hid[Shell] with an argument forces the creation of a new shell +buffer. + +@hid[Shell Utility] is the string name of the process to execute. + +@hid[Shell Utility Switches] is a string containing the default command line +arguments to @hid[Shell Utility]. This is a string since the utility is +typically @f["/bin/csh"], and this string can contain I/O redirection and other +shell directives. +@enddefcom + +@defcom[com "Shell Command Line in Buffer"] +This command prompts for a buffer and a shell command line. It then runs a +shell, giving it the command line, in the buffer. +@enddefcom + +@defcom[com "Set Current Shell"] +This command sets the value of @hid[Current Shell]. +@enddefcom + +@defcom[com "Stop Main Process"] +This command stops the process running in the current buffer by sending a +@f[:SIGTSTP] to that process. With an argument, stops the process using +@f[:SIGSTOP]. +@enddefcom + +@defcom[com "Continue Main Process"] +If the process in the current buffer is stopped, this command continues it. +@enddefcom + +@defcom[com "Kill Main Process"] +@defhvar1[var "Kill Process Confirm", val {t}] +This command prompts for confirmation and kills the process running in the +current buffer. + +Setting this variable to @nil inhibits @hemlock@comment{}'s prompting for confirmation. +@enddefcom + +@defcom[com "Stop Buffer Subprocess", stuff (bound to @bf[H-z] in @hid[Process] mode)] +This command stops the foreground subprocess of the process in the current +buffer, similar to the effect of @binding[C-Z] in a shell. +@enddefcom + +@defcom[com "Kill Buffer Subprocess"] +This command kills the foreground subprocess of the process in the current +buffer. +@enddefcom + +@defcom[com "Interrupt Buffer Subprocess", stuff (bound to @bf[H-c] in @hid[Process] mode)] +This command interrupts the foreground subprocess of the process in the +current buffer, similar to the effect of @binding[C-C] in a shell. +@enddefcom + +@defcom[com "Quit Buffer Subprocess", stuff (bound to @bf[H-\] in @hid[Process] mode)] +This command dumps the core of the foreground subprocess of the processs in +the current buffer, similar to the effect of @binding[C-\] in a shell. +@enddefcom + +@defcom[com "Send EOF to Process", stuff (bound to @bf[H-d] in @hid[Process] mode)] +This command sends the end of file character to the process in the current +buffer, similar to the effect of @binding[C-D] in a shell. +@enddefcom + +@defcom[com "Confirm Process Input", stuff (bound to @bf[Return] in @hid[Process] mode)] +This command sends the text the user has inserted at the end of a process +buffer to the process in that buffer. Resulting output is inserted at the end +of the process buffer. +@enddefcom + +The user may edit process input using commands that are shared with +@hid[Typescript] mode, see section @ref[typescripts]. + + +@section[Bufed Mode] +@hemlock provides a mechanism for managing buffers as an itemized list. +@hid[Bufed] supports conveniently deleting several buffers at once, saving +them, going to one, etc., all in a key stroke. + +@defcom[com "Bufed", bind (C-x C-M-b)] +This command creates a list of buffers in a buffer supporting operations such +as deletion, saving, and selection. If there already is a @hid[Bufed] buffer, +this just goes to it. +@enddefcom + +@defcom[com "Bufed Help"] +This command pops up a display of @hid[Bufed] help. +@enddefcom + +@defcom[com "Bufed Delete", bind (Bufed: C-d, C-D, D, d)] +@defhvar1[var "Virtual Buffer Deletion", val {t}] +@defhvar1[var "Bufed Delete Confirm", val {t}] +@hid[Bufed Delete] deletes the buffer on the current line. + +When @hid[Virtual Buffer Deletion] is set, this merely flags the buffer for +deletion until @hid[Bufed Expunge] or @hid[Bufed Quit] executes. + +Whenever these commands actually delete a buffer, if @hid[Bufed Delete Confirm] +is set, then @hemlock prompts the user for permission; if more than one buffer +is flagged for deletion, this only prompts once. For each modified buffer, +@hemlock asks to save the buffer before deleting it. +@enddefcom + +@defcom[com "Bufed Undelete", bind (Bufed: U, u)] +This command undeletes the buffer on the current line. +@enddefcom + +@defcom[com "Bufed Expunge", bind (Bufed: !)] +This command expunges any buffers marked for deletion regarding @hid[Bufed +Delete Confirm]. +@enddefcom + +@defcom[com "Bufed Quit", bind (Bufed: q)] +This command kills the @hid[Bufed] buffer, expunging any buffers marked for +deletion. +@enddefcom + +@defcom[com "Bufed Goto", bind (Bufed: Space)] +This command selects the buffer on the current line, switching to it. +@enddefcom + +@defcom[com "Bufed Goto and Quit", bind (Bufed: S-leftdown)] +This command goes to the buffer under the pointer, quitting @hid[Bufed]. It +supplies a function for @hid[Generic Pointer Up] which is a no-op. +@enddefcom + +@defcom[com "Bufed Save File", bind (Bufed: s)] +This command saves the buffer on the current line. +@enddefcom + + +@section[Completion] +This is a minor mode that saves words greater than three characters in length, +allowing later completion of those words. This is very useful for the often +long identifiers used in Lisp programs. As you type a word, such as a Lisp +symbol when in @hid[Lisp] mode, and you progress to typing the third letter, +@hemlock displays a possible completion in the status line. You can then +rotate through the possible completions or type some more letters to narrow +down the possibilities. If you choose a completion, you can also rotate +through the possibilities in the buffer instead of in the status line. +Choosing a completion or inserting a character that delimits words moves the +word forward in the ring of possible completions, so the next time you enter +its initial characters, @hemlock will prefer it over less recently used +completions. + +@defcom[com "Completion Mode"] +This command toggles @hid[Completion] mode in the current buffer. +@enddefcom + +@defcom[com "Completion Self Insert"] +This command is like @hid[Self Insert], but it also checks for possible +completions displaying any result in the status line. This is bound to most of +the key-events with corresponding graphic characters. +@enddefcom + +@defcom[com "Completion Complete Word", bind (Completion: End)] +This command selects the currently displayed completion if there is one, +guessing the case of the inserted text as with @hid[Query Replace]. Invoking +this immediately in succession rotates through possible completions in the +buffer. If there is no currently displayed completion on a first invocation, +this tries to find a completion from text immediately before the point and +displays the completion if found. +@enddefcom + +@defcom[com "Completion Rotate Completions", bind (Completion: M-End)] +This command displays the next possible completion in the status line. If +there is no currently displayed completion, this tries to find a completion +from text immediately before the point and displays the completion if found. +@enddefcom + +@defcom[com "List Possible Completions"] +This command lists all the possible completions for the text immediately before +the point in a pop-up display. Sometimes this is more useful than rotating +through several completions to see if what you want is available. +@enddefcom + +@defhvar[var "Completion Bucket Size", val {20}] +Completions are stored in buckets determined by the first three letters of a +word. This variable limits the number of completions saved for each combination +of the first three letters of a word. If you have many identifier in some +module beginning with the same first three letters, you'll need increase this +variable to accommodate all the names. +@enddefhvar + + +@defcom[com "Save Completions"] +@defcom1[com "Read Completions"] +@defhvar1[var "Completion Database Filename", val {nil}] +@hid[Save Completions] writes the current completions to the file +@hid[Completion Database Filename]. It writes them, so @hid[Read Completions] +can read them back in preserving the most-recently-used order. If the user +supplies an argument, then this prompts for a pathname. + +@hid[Read Completions] reads completions saved in @hid[Completion Database +Filename]. It moves any current completions to a less-recently-used status, +and it removes any in a given bucket that exceed the limit @hid[Completion +Bucket Size]. +@enddefcom + +@defcom[com "Parse Buffer for Completions"] +This command passes over the current buffer putting each valid completion word +into the database. This is a good way of picking up many useful completions +upon visiting a new file for which there are no saved completions. +@enddefcom + + +@section[CAPS-LOCK Mode] + +@hid[CAPS-LOCK] is a minor mode in which @hemlock that inserts all alphabetic +characters as uppercase letters. + +@defcom[com "Caps Lock Mode"] +This command toggles @hid[CAPS-LOCK] mode for the current buffer; it is most +useful when bound to a key, so you can enter and leave @hid[CAPS-LOCK] mode +casually. +@enddefcom + +@defcom[com "Self Insert Caps Lock"] +This command inserts the uppercase version of the character corresponding to +the last key-event typed. +@enddefcom + + + +@section[Overwrite Mode] + +@hid[Overwrite] mode is a minor mode which is useful for creating figures and +tables out of text. In this mode, typing a key-event with a corresponding +graphic character replaces the character at the point instead of inserting the +character. @hid[Quoted Insert] can be used to insert characters normally. + +@defcom[com "Overwrite Mode"] +This command turns on @hid[Overwrite] mode in the current buffer. If it is +already on, then it is turned off. A positive argument turns @hid[Overwrite] +mode on, while zero or a negative argument turns it off. +@enddefcom + +@defcom[com "Self Overwrite"] +This command replaces the next character with the character corresponding to +the key-event used to invoke the command. After replacing the character, this +moves past it. If the next character is a tab, this first expands the tab into +the appropriate number of spaces, replacing just the next space character. +At the end of the line, it inserts the +character instead of clobbering the newline. + +This is bound to key-events with corresponding graphic characters in +@hid[Overwrite] mode. +@enddefcom + +@defcom[com "Overwrite Delete Previous Character", + stuff (bound to @bf[Delete] and @bf[Backspace] in @hid[Overwrite] mode)] +This command replaces the previous character with a space and moves backwards. +This deletes tabs and newlines. +@enddefcom + + +@section[Word Abbreviation] +@index[word abbreviation] +Word abbreviation provides a way to speed the typing of frequently used words +and phrases. When in @hid[Abbrev] mode, typing a word delimiter causes the +previous word to be replaced with its @i[expansion] if there is one currently +defined. The expansion for an abbrev may be any string, so this mode can be +used for abbreviating programming language constructs and other more obscure +uses. For example, @hid[Abbrev] mode can be used to automatically correct +common spelling mistakes and to enforce consistent capitalization of +identifiers in programs. + +@i[Abbrev] is an abbreviation for @i[abbreviation], which is used for +historical reasons. Obviously the original writer of @hid[Abbrev] mode hated +to type long words and could hardly use @hid[Abbrev] mode while writing +@hid[Abbrev] mode. + +A word abbrev can be either global or local to a major mode. A global word +abbrev is defined no matter what the current major mode is, while a mode word +abbrev is only defined when its mode is the major mode in the current buffer. +Mode word abbrevs can be used to prevent abbrev expansion in inappropriate +contexts. + + +@subsection[Basic Commands] + +@defcom[com "Abbrev Mode"] +This command turns on @hid[Abbrev] mode in the current buffer. If @hid[Abbrev] +mode is already on, it is turned off. @hid[Abbrev] mode must be on for the +automatic expansion of word abbrevs to occur, but the abbreviation commands are +bound globally and may be used at any time. +@enddefcom + +@defcom[com "Abbrev Expand Only", + stuff (bound to word-delimiters in @hid[Abbrev] mode)] +This is the word abbrev expansion command. If the word before the point is a +defined word abbrev, then it is replaced with its expansion. The replacement +is done using the same case-preserving heuristic as is used by +@hid[Query Replace]. This command is globally bound to @binding[M-Space] so +that abbrevs can be expanded when @hid[Abbrev] mode is off. An undesirable +expansion may be inhibited by using @binding[C-q] to insert the delimiter. +@enddefcom + +@defcom[com "Inverse Add Global Word Abbrev", bind (C-x -)] +@defcom1[com "Inverse Add Mode Word Abbrev", bind (C-x C-h, C-x Backspace)] +@hid[Inverse Add Global Word Abbrev] prompts for a string and makes it the +global word abbrev expansion for the word before the point. + +@hid[Inverse Add Mode Word Abbrev] is identical to +@hid[Inverse Add Global Word Abbrev] except that it defines an expansion which +is local to the current major mode. +@enddefcom + +@defcom[com "Make Word Abbrev"] +This command defines an arbitrary word abbreviation. It prompts for the mode, +abbreviation and expansion. If the mode @f["Global"] is specified, then it +makes a global abbrev. +@enddefcom + +@defcom[com "Add Global Word Abbrev", bind (C-x +)] +@defcom1[com "Add Mode Word Abbrev", bind (C-x C-a)] +@hid[Add Global Word Abbrev] prompts for a word and defines it to be a global +word abbreviation. The prefix argument determines which text is used as the +expansion: +@begin[description] +@i[no prefix argument]@\The word before the point is used as the expansion of +the abbreviation. + +@i[zero prefix argument]@\The text in the region is used as the expansion of the +abbreviation. + +@i[positive prefix argument]@\That many words before the point are made the +expansion of the abbreviation. + +@i[negative prefix argument]@\Do the same thing as +@hid[Delete Global Word Abbrev] instead of defining an abbreviation. +@end[description] + +@hid[Add Mode Word Abbrev] is identical to @hid[Add Global Word Abbrev] except +that it defines or deletes mode word abbrevs in the current major mode. +@enddefcom + +@defcom[com "Word Abbrev Prefix Mark", bind (M-")] +This command allows @hid[Abbrev Expand Only] to recognize abbreviations when +they have prefixes attached. First type the prefix, then use this command. A +hyphen (@f[-]) will be inserted in the buffer. Now type the abbreviation and +the word delimiter. @hid[Abbrev Expand Only] will expand the abbreviation and +remove the hyphen. + +Note that there is no need for a suffixing command, since +@hid[Abbrev Expand Only] may be used explicitly by typing @binding[M-Space]. +@enddefcom + +@defcom[com "Unexpand Last Word", bind (C-x u)] +This command undoes the last word abbrev expansion. If repeated, undoes its +own effect. +@enddefcom + + +@subsection[Word Abbrev Files] +A word abbrev file is a file which holds word abbrev definitions. Word abbrev +files allow abbrevs to be saved so that they may be used across many editing +sessions. + +@defhvar[var "Abbrev Pathname Defaults", val {(pathname "abbrev.defns")}] +This is sticky default for the following commands. When they prompt for a file +to write, they offer this and set it for the next time one of them executes. +@enddefhvar + +@defcom[com "Read Word Abbrev File"] +This command reads in a word abbrev file, adding all the definitions to those +currently defined. If a definition in the file is different from the current +one, the current definition is replaced. +@enddefcom + +@defcom[com "Write Word Abbrev File"] +This command prompts for a file and writes all currently defined word abbrevs +out to it. +@enddefcom + +@defcom[com "Append to Word Abbrev File"] +This command prompts for a word abbrev file and appends any new definitions to +it. An abbrev is new if it has been defined or redefined since the last use of +this command. Definitions made by reading word abbrev files are not +considered. +@enddefcom + + +@subsection[Listing Word Abbrevs] +@defcom[com "List Word Abbrevs"] +@defcom1[com "Word Abbrev Apropos"] +@hid[List Word Abbrevs] displays a list of each defined word abbrev, with its +mode and expansion. + +@hid[Word Abbrev Apropos] is similar, except that it only displays abbrevs +which contain a specified string, either in the definition, expansion or mode. +@enddefcom + +@subsection[Editing Word Abbrevs] +Word abbrev definition lists are edited by editing the text representation +of the definitions. Word abbrev files may be edited directly, like any other +text file. The set of abbrevs currently defined in @hemlock may be edited +using the commands described in this section. + +The text representation of a word abbrev is fairly simple. Each definition +begins at the beginning of a line. Each line has three fields which are +separated by ASCII tab characters. The fields are the abbreviation, the mode +of the abbreviation and the expansion. The mode is represented as the mode +name inside of parentheses. If the abbrev is global, then the mode field is +empty. The expansion is represented as a quoted string since it may contain +any character. The string is quoted with double-quotes (@f["]); double-quotes +in the expansion are represented by doubled double-quotes. The expansion may +contain newline characters, in which case the definition will take up more than +one line. + +@defcom[com "Edit Word Abbrevs"] +This command inserts the current word abbrev definitions into the +@hid[Edit Word Abbrevs] buffer and then enters a recursive edit on the buffer. +When the recursive edit is exited, the definitions in the buffer become the new +current abbrev definitions. +@enddefcom + +@defcom[com "Insert Word Abbrevs"] +This command inserts at the point the text representation of the currently +defined word abbrevs. +@enddefcom + +@defcom[com "Define Word Abbrevs"] +This command interprets the text of the current buffer as a word abbrev +definition list, adding all the definitions to those currently defined. +@enddefcom + + +@subsection[Deleting Word Abbrevs] +The user may delete word abbrevs either individually or collectively. +Individual abbrev deletion neutralizes single abbrevs which have outlived their +usefulness; collective deletion provides a clean slate from which to initiate +abbrev definitions. + +@defcom[com "Delete All Word Abbrevs"] +This command deletes all word abbrevs which are currently defined. +@enddefcom + +@defcom[com "Delete Global Word Abbrev"] +@defcom1[com "Delete Mode Word Abbrev"] +@hid[Delete Global Word Abbrev] prompts for a word abbreviation and deletes its +global definition. If given a prefix argument, deletes all global abbrev +definitions. + +@hid[Delete Mode Word Abbrev] is identical to @hid[Delete Global Word Abbrev] +except that it deletes definitions in the current major mode. +@enddefcom + + +@section[Lisp Library] +This is an implementation dependent feature. The Lisp library is a collection +of local hacks that users can submit and share that is maintained by the Lisp +group. These commands help peruse the catalog or description files and figure +out how to load the entries. + +@defcom[com "Lisp Library"] +This command finds all the library entries and lists them in a buffer. The +following commands describe and load those entries. +@enddefcom + +@defcom[com "Describe Library Entry", bind (Lisp-Lib: space)] +@defcom1[com "Describe Pointer Library Entry", bind (Lisp-Lib: leftdown)] +@defcom1[com "Load Library Entry", bind (Lisp-Lib: rightdown)] +@defcom1[com "Load Pointer Library Entry", bind (Lisp-Lib: l)] +@defcom1[com "Editor Load Library Entry"] +@defcom1[com "Editor Load Pointer Library Entry"] +@hid[Load Library Entry] and @hid[Load Pointer Library Entry] load the library +entry indicated by the line on which the point lies or where the user clicked +the pointer, respectively. These load the entry into the current slave Lisp. + +@hid[Editor Load Library Entry] and @hid[Editor Load Pointer Library Entry] are +the same, but they load the entry into the editor Lisp. +@enddefcom + +@defcom[com "Exit Lisp Library", bind (Lisp-Lib: q)] +This command deletes the @hid[Lisp Library] buffer. +@enddefcom + +@defcom[com "Lisp Library Help", bind (Lisp-Lib: ?)] +This command pops up a help window listing @hid[Lisp-Lib] commands. +@enddefcom Index: /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/user.mss =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/user.mss (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/doc/user/user.mss (revision 8058) @@ -0,0 +1,2003 @@ +@Make[Manual] @comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-} +@Device[postscript] +@Style(Spacing = 1.2 lines) +@Style(StringMax = 5000) +@Use(Database "/afs/cs/project/clisp/docs/database/") +@Style(FontFamily=TimesRoman) +@Style(Date="March 1952") +@style(DOUBLESIDED) +@Libraryfile[ArpaCredit] +@libraryfile[hem] +@Libraryfile[Spice] +@Libraryfile[Uttir] + +@String(REPORTTITLE "Hemlock User's Manual") + +@comment<@begin[TitlePage] +@begin[TitleBox] +> +@blankspace(1.3inches) +@heading[Hemlock User's Manual] + +@center[@b +@b + + +@b<@value[date]> + +@b +] +@comment<@end[TitleBox]> +@blankspace(2lines) +@begin[Center] +School of Computer Science +Carnegie Mellon University +Pittsburgh, PA 15213 +@end[Center] +@blankspace[2lines] + +@begin[Center] +This is a revised version of Technical Report CMU-CS-87-158. +@end[Center] + +@heading +@begin(Text, indent 0) +This document describes the @Hemlock text editor, version M3.2. @Hemlock is a +customizable, extensible text editor whose initial command set closely +resembles that of ITS/TOPS-20 @Emacs. @Hemlock is written in CMU Common Lisp +and has been ported to other implementations. +@end(Text) + +@begin[ResearchCredit] +@ArpaCredit[Contract=Basic87-90] +@end[ResearchCredit] +@comment<@end[TitlePage]> + + +@commandstring(mh = "@f1(MH)") +@commandstring(dash = "@Y[M]") + +@comment[This tabclear is necessary since the definition macros don't + take care of the own tabbing needs] +@tabclear + + +@comment[@chap (Introduction)] +@include(intro) + + +@comment[@chap (Basic Commands)] +@include(commands) + + + +@chap[Files, Buffers, and Windows] + +@section[Introduction] + +@index[files] +@index[buffers] +@index[windows] +@hemlock provides three different abstractions which are used in combination to +solve the text-editing problem, while other editors tend to mash these ideas +together into two or even one. +@begin[description] +File@\A file provides permanent storage of text. @hemlock has commands +to read files into buffers and write buffers out into files. + +Buffer@\A buffer provides temporary storage of text and a capability to +edit it. A buffer may or may not have a file associated with it; if it +does, the text in the buffer need bear no particular relation to the text +in the file. In addition, text in a buffer may be displayed in any number +of windows, or may not be displayed at all. + +Window@\A window displays some portion of a buffer on the screen. There +may be any number of windows on the screen, each of which may display any +position in any buffer. It is thus possible, and often useful, to have +several windows displaying different places in the same buffer. +@end[description] + + +@section[Buffers] +In addition to some text, a buffer has several other user-visible attributes: +@begin[description] +A name@\ +A buffer is identified by its name, which allows it to be selected, destroyed, +or otherwise manipulated. + +A collection of modes@\ +The modes present in a buffer alter the set of commands available and +otherwise alter the behavior of the editor. For details see page +@pageref[modes]. + +A modification flag @\ +This flag is set whenever the text in a buffer is modified. It is often +useful to know whether a buffer has been changed, since if it has it should +probably be saved in its associated file eventually. + +A write-protect flag @\ +If this flag is true, then any attempt to modify the buffer will result in an +error. +@end[description] + +@defcom[com "Select Buffer", bind (C-x b)] +This command prompts for the name of a existing buffer and makes that buffer +the @i[current buffer]. The newly selected buffer is displayed in the +current window, and editing commands now edit the text in that buffer. +Each buffer has its own point, thus the point will be in the place it was +the last time the buffer was selected. When prompting for the buffer, the +default is the buffer that was selected before the current one. +@enddefcom + +@defcom[com "Select Previous Buffer", bind (C-M-l)] +@defcom1[com "Circulate Buffers", bind (C-M-L)] +With no prefix argument, @hid[Select Previous Buffer] selects the buffer that +has been selected most recently, similar to @binding[C-x b Return]. If given a +prefix argument, then it does the same thing as @hid[Circulate Buffers]. + +@hid[Circulate Buffers] moves back into successively earlier buffers in the +buffer history. If the previous command was not @hid[Circulate Buffers] or +@hid[Select Previous Buffer], then it does the same thing as +@hid[Select Previous Buffer], otherwise it moves to the next most recent +buffer. The original buffer at the start of the excursion is made the previous +buffer, so @hid[Select Previous Buffer] will always take you back to where you +started. + +These commands are generally used together. Often @hid[Select Previous Buffer] +will take you where you want to go. If you don't end up there, then using +@hid[Circulate Buffers] will do the trick. +@enddefcom + +@defcom[com "Create Buffer", bind (C-x M-b)] +This command is very similar to @hid[Select Buffer], but the buffer need not +already exist. If the buffer does not exist, a new empty buffer is created +with the specified name. +@enddefcom + +@defcom[com "Kill Buffer", bind (C-x k)] +This command is used to make a buffer go away. There is no way to restore +a buffer that has been accidentally deleted, so the user is given a chance +to save the hapless buffer if it has been modified. This command is poorly +named, since it has nothing to do with killing text. +@enddefcom + +@defcom[com "List Buffers", bind (C-x C-b)] +This command displays a list of all existing buffers in a pop-up window. A +"@f[*]" is displayed before the name of each modified buffer. A buffer with no +associated file is represented by the buffer name followed by the number of +lines in the buffer. A buffer with an associated file are is represented by +the name and type of the file, a space, and the device and directory. If the +buffer name doesn't match the associated file, then the buffer name is also +displayed. When given a prefix argument, this command lists only the modified +buffers. +@enddefcom + +@defcom[com "Buffer Not Modified", bind (M-~)] +This command resets the current buffer's modification flag @dash @i[it does not +save any changes]. This is primarily useful in cases where a user accidentally +modifies a buffer and then undoes the change. Resetting the modified flag +indicates that the buffer has no changes that need to be written out. +@enddefcom + +@defcom[com "Check Buffer Modified", bind (C-x ~)] +This command displays a message indicating whether the current buffer is modified. +@enddefcom + +@defcom[com "Set Buffer Read-Only"] +This command changes the flag that allows the current buffer to be modified. +If a buffer is read-only, any attempt to modify it will result in an error. The +buffer may be made writable again by repeating this command. +@enddefcom + +@defcom[com "Set Buffer Writable"] +This command ensures the current buffer is modifiable. +@enddefcom + +@defcom[com "Insert Buffer"] +This command prompts for the name of a buffer and inserts its contents at the +point, pushing a buffer mark before inserting. The buffer inserted is +unaffected. +@enddefcom + +@defcom[com "Rename Buffer"] +This command prompts for a new name for the current buffer, which defaults +to a name derived from the associated filename. +@enddefcom + + +@section[Files] +@index[files] +These commands either read a file into the current buffer or write it out to +some file. Various other bookkeeping operations are performed as well. + +@defcom[com "Find File", bind (C-x C-f)] +This is the command normally used to get a file into @hemlock. It prompts +for the name of a file, and if that file has already been read in, selects +that buffer; otherwise, it reads file into a new buffer whose name is +derived from the name of the file. If the file does not exist, then the +buffer is left empty, and @w<"@f[(New File)]"> is displayed in the echo area; +the file may then be created by saving the buffer. + +The buffer name created is in the form @w<"@i[name] @i[type] @i[directory]">. +This means that the filename "@f[/sys/emacs/teco.mid]" has +@w<"@f[Teco Mid /Sys/Emacs/]"> as its the corresponding buffer name. The +reason for rearranging the fields in this fashion is that it facilitates +recognition since the components most likely to differ are placed first. If +the buffer cannot be created because it already exists, but has another file in +it (an unlikely occurrence), then the user is prompted for the buffer to use, +as by @hid[Create Buffer]. + +@hid[Find File] takes special action if the file has been modified on disk +since it was read into @hemlock. This usually happens when several people are +simultaneously editing a file, an unhealthy circumstance. If the buffer is +unmodified, @hid[Find File] just asks for confirmation before reading in the +new version. If the buffer is modified, then @hid[Find File] beeps and prompts +for a single key-event to indicate what action to take. It recognizes +the following key-events: +@begin[description] +@binding[Return, Space, y]@\ + Prompt for a file in which to save the current buffer and then read in the +file found to be modified on disk. + +@binding[Delete, Backspace, n]@\ + Forego reading the file. + +@binding[r]@\ + Read the file found to be modified on disk into the buffer containing the +earlier version with modifications. This loses all changes you had in the +buffer. +@end[description] +@enddefcom + +@defcom[com "Save File", bind (C-x C-s)] +This command writes the current buffer out to its associated file and +resets the buffer modification flag. If there is no associated file, then +the user is prompted for a file, which is made the associated file. If +the buffer is not modified, then the user is asked whether to actually +write it or not. + +If the file has been modified on disk since the last time it was read, +@hid[Save File] prompts for confirmation before overwriting the file. +@enddefcom + +@defcom[com "Save All Files", bind (C-x C-m)] +@defcom1[com "Save All Files and Exit", bind (C-x M-z)] +@defhvar1[var "Save All Files Confirm", val {t}] +@hid[Save All Files] does a @hid[Save File] on all buffers which have an +associated file. @hid[Save All Files and Exit] does the same thing and then +exits @hemlock. + +When @hid[Save All Files Confirm] is true, these commands will ask for +confirmation before saving a file. +@enddefcom + +@defcom[com "Visit File", bind (C-x C-v)] +This command prompts for a file and reads it into the current buffer, +setting the associated filename. Since the old contents of the buffer are +destroyed, the user is given a chance to save the buffer if it is modified. +As for @hid[Find File], the file need not actually exist. This command warns +if some other buffer also contains the file. +@enddefcom + +@defcom[com "Write File", bind (C-x C-w)] This command prompts for a file +and writes the current buffer out to it, changing the associated filename +and resetting the modification flag. When the buffer's associated file is +specified this command does the same thing as @hid[Save File]. @enddefcom + +@defcom[com "Backup File"] +This command is similar to @hid[Write File], but it neither sets the +associated filename nor clears the modification flag. This is useful for +saving the current state somewhere else, perhaps on a reliable machine. + +Since @hid[Backup File] doesn't update the write date for the buffer, +@hid[Find File] and @hid[Save File] will get all upset if you back up +a buffer on any file that has been read into @hemlock. +@enddefcom + +@defcom[com "Revert File"] +@defhvar1[var "Revert File Confirm", val {t}] +This command replaces the text in the current buffer with the contents of the +associated file or the checkpoint file for that file, whichever is more recent. +The point is put in approximately the same place that it was before the file +was read. If the original file is reverted to, then clear the modified flag, +otherwise leave it set. If a prefix argument is specified, then always revert +to the original file, ignoring any checkpoint file. + +If the buffer is modified and @hid[Revert File Confirm] is true, then the user +is asked for confirmation. +@enddefcom + +@defcom[com "Insert File", bind (C-x C-r)] +This command prompts for a file and inserts it at the point, pushing a buffer +mark before inserting. +@enddefcom + +@defcom[com "Write Region"] +This command prompts for a file and writes the text in the region out to it. +@enddefcom + +@defhvar[var "Add Newline at EOF on Writing File", val {:ask-user}] +This variable controls whether some file writing commands add a newline at the +end of the file if the last line is non-empty. +@begin[description] +@f[:ask-user]@\Ask the user whether to add a newline. + +@f[t]@\Automatically add a newline and inform the user. + +@nil@\Never add a newline and do not ask. +@end[description] +Some programs will lose the text on the last line or get an +error when the last line does not have a newline at the end. +@enddefhvar + +@defhvar[var "Keep Backup Files", val {nil}] +Whenever a file is written by @hid[Save File] and similar commands, the old +file is renamed by appending "@f[.BAK]" to the name, ensuring that some version +of the file will survive a system crash during the write. If set to true, this +backup file will not deleted even when the write successfully completes. +@enddefhvar + + +@subsection[Auto Save Mode] + +@hid[Save] mode protects against loss of work in system crashes by periodically +saving modified buffers in checkpoint files. + +@defcom[com "Auto Save Mode"] +This command turns on @hid[Save] mode if it is not on, and turns off when it is +on. @hid[Save] mode is on by default. +@enddefcom + +@defhvar[var "Auto Save Checkpoint Frequency", val {120}] +@defhvar1[var "Auto Save Key Count Threshold", val {256}] +These variables determine how often modified buffers in @hid[Save] mode will be +checkpointed. Checkpointing is done after +@hid[Auto Save Checkpoint Frequency] seconds, or after +@hid[Auto Save Key Count Threshold] keystrokes that modify the buffer +(whichever comes first). Either kind of checkpointing may be disabled by +setting the corresponding variable to @nil. +@enddefhvar + +@defhvar[var "Auto Save Cleanup Checkpoints", val {t}] +If this variable is true, then any checkpoint file for a buffer will be deleted +when the buffer is successfully saved in its associated file. +@enddefhvar + +@defhvar[var "Auto Save Filename Pattern", val {"~A~A.CKP"}] +@defhvar1[var "Auto Save Pathname Hook", val {make-unique-save-pathname}] +These variables determine the naming of checkpoint files. +@hid[Auto Save Filename Pattern] is a format string used to name the checkpoint +files for buffers with associated files. Format is called with two arguments: +the directory and file namestrings of the associated file. + +@hid[Auto Save Pathname Hook] is a function called by @hid[Save] mode to get a +checkpoint pathname when there is no pathname associated with a buffer. It +should take a buffer as its argument and return either a pathname or @nil. If +a pathname is returned, then it is used as the name of the checkpoint file. If +the function returns @nil, or if the hook variable is @nil, then @hid[Save] +mode is turned off in the buffer. The default value for this variable returns +a pathname in the default directory of the form "@w<@f[save-]@i[number]>", +where @i[number] is a number used to make the file unique. +@enddefhvar + + +@subsection[Filename Defaulting and Merging] +@index[merging, filename] +@index[defaulting, filename] +@index[filename defaulting] +@label[merging] +@index[pathnames] +When @hemlock prompts for the name of a file, it always offers a default. +Except for a few commands that have their own defaults, filename defaults are +computed in a standard way. If it exists, the associated file for the current +buffer is used as the default, otherwise a more complex mechanism creates a +default. + +@defhvar[var "Pathname Defaults", val {(pathname "gazonk.del")}] +@defhvar1[var "Last Resort Pathname Defaults Function"] +@defhvar1[var "Last Resort Pathname Defaults", val {(pathname "gazonk")}] +These variables control the computation of default filename defaults when the +current buffer has no associated file. + +@hid[Pathname Defaults] holds a "sticky" filename default. Commands that +prompt for files set this to the file specified, and the value is used as a +basis for filename defaults. It is undesirable to offer the unmodified value +as a default, since it is usually the name of an existing file that we don't +want to overwrite. If the current buffer's name is all alphanumeric, then the +default is computed by substituting the buffer name for the the name portion of +@hid[Pathname Defaults]. Otherwise, the default is computed by calling +@hid[Last Resort Pathname Defaults Function] with the buffer as an argument. + +The default value of @hid[Last Resort Pathname Defaults Function] merges +@hid[Last Resort Pathname Defaults] with @hid[Pathname Defaults]. +Unlike @hid[Pathname Defaults], @hid[Last Resort Pathname Defaults] is not +modified by file commands, so setting it to a silly name ensures that real +files aren't inappropriately offered as defaults. +@enddefhvar + +When a default is present in the prompt for a file, @hemlock @i[merges] the +given input with the default filename. The semantics of merging, described in +the Common Lisp manual, is somewhat involved, but @hemlock has a few rules it +uses: +@begin[enumerate] +If @hemlock can find the user's input as a file on the @f["default:"] search +list, then it forgoes merging with the displayed default. Basically, the +system favors the files in your current working directory over those found by +merging with the defaults offered in the prompt. + +Merging comes in two flavors, just merge with the displayed default's directory +or just merge with the displayed default's @f[file-namestring]. If the user +only responds with a directory specification, without any name or type +information, then @hemlock merges the default's @f[file-namestring]. If the +user responds with any name or type information, then @hemlock only merges with +the default's directory. Specifying relative directories in this second +situation coordinates with the displayed defaults, not the current working +directory. +@end[enumerate] + + +@subsection[Type Hooks and File Options] +@index[mode comment] +@index[type hooks] +When a file is read either by @hid[Find File] or @hid[Visit File], @hemlock +attempts to guess the correct mode in which to put the buffer, based on the +file's @i[type] (the part of the filename after the last dot). Any default +action may be overridden by specifying the mode in the file's @i[file +options].@index[modes]@index[package] + +@label[file-options]@index[file options] +The user specifies file options with a special syntax on the first line of a +file. If the first line contains the string "@f[-*-]", then @hemlock +interprets the text between the first such occurrence and the second, which +must be contained in one line , as a list of @w{"@f<@i[option]: @i[value]>"} +pairs separated by semicolons. The following is a typical example: +@begin[programexample] +;;; -*- Mode: Lisp, Editor; Package: Hemlock -*- +@end[programexample] + +These options are currently defined: +@begin[description] +Dictionary@\The argument is the filename of a spelling dictionary associated +with this file. The handler for this option merges the argument with the +name of this file. See @comref[Set Buffer Spelling Dictionary]. + +Log@\The argument is the name of the change log file associated with this file +(see page @pageref[log-files]). The handler for this option merges the +argument with the name of this file. + +Mode@\The argument is a comma-separated list of the names of modes to turn on +in the buffer that the file is read into. + +Package@\The argument is the name of the package to be used for reading code in +the file. This is only meaningful for Lisp code (see page +@pageref[lisp-package].) + +Editor@\The handler for this option ignores its argument and turns on +@hid[Editor] mode (see @comref[Editor Mode]). + +@end[description] +If the option list contains no "@f[:]" then the entire string is used as +the name of the major mode for the buffer. + +@defcom[com "Process File Options"] +This command processes the file options in the current buffer as described +above. This is useful when the options have been changed or when a file is +created. +@enddefcom + + +@section[Windows] +@index[windows] + +@hemlock windows display a portion of a buffer's text. See the section on +@i[window groups], @ref[groups], for a discussion of managing windows on bitmap +device. + +@defcom[com "New Window", bind (C-x C-n)] +This command prompts users for a new window which they can place anywhere on +the screen. This window is in its own group. This only works with bitmap +devices. +@enddefcom + +@defcom[com "Split Window", bind (C-x 2)] +This command splits the current window roughly in half to make two windows. If +the current window is too small to be split, the command signals a user error. +@enddefcom + +@defcom[com "Next Window", bind (C-x n)] +@defcom1[com "Previous Window", bind (C-x p)] +These commands make the next or previous window the new current window, often +changing the current buffer in the process. When a window is created, it is +arbitrarily made the next window of the current window. The location of the +next window is, in general, unrelated to that of the current window. +@enddefcom + +@defcom[com "Delete Window", bind (C-x C-d, C-x d)] +@defcom1[com "Delete Next Window", bind (C-x 1)] +@hid[Delete Window] makes the current window go away, making the next window +current. @hid[Delete Next Window] deletes the next window, leaving the current +window unaffected. + +On bitmap devices, if there is only one window in the group, either command +deletes the group, making some window in another group the current window. If +there are no other groups, they signal a user error. +@enddefcom + +@defcom[com "Go to One Window"] +This command deletes all window groups leaving one with the @hid[Default +Initial Window X], @hid[Default Initial Window Y], @hid[Default Initial Window +Width], and @hid[Default Initial Window Height]. This remaining window +retains the contents of the current window. +@enddefcom + +@defcom[com "Line to Top of Window", bind (M-!)] +@defcom1[com "Line to Center of Window", bind (M-#)] +@index[scrolling]@hid[Line to Top of Window] scrolls the current window up +until the current line is at the top of the screen. + +@hid[Line to Center of Window] attempts to scroll the current window so that +the current line is vertically centered. +@enddefcom + +@defcom[com "Scroll Next Window Down", bind (C-M-v)] +@defcom1[com "Scroll Next Window Up", bind (C-M-V)] +These commands are the same as @hid[Scroll Window Up] and +@hid[Scroll Window Down] except that they operate on the next window. +@enddefcom + +@defcom[com "Refresh Screen", bind {C-l}] +This command refreshes all windows, which is useful if the screen got trashed, +centering the current window about the current line. When the user supplies a +positive argument, it scrolls that line to the top of the window. When the +argument is negative, the line that far from the bottom of the window is moved +to the bottom of the window. In either case when an argument is supplied, this +command only refreshes the current window. +@enddefcom + + +@chap[Editing Documents] +@index[documents, editing] +Although @hemlock is not dedicated to editing documents as word processing +systems are, it provides a number of commands for this purpose. If @hemlock is +used in conjunction with a text-formatting program, then its lack of complex +formatting commands is no liability. + + +@defcom[com "Text Mode"] +This commands puts the current buffer into "Text" mode. +@enddefcom + + +@section[Sentence Commands] +@index[sentence commands] +A sentence is defined as a sequence of characters ending with a period, +question mark or exclamation point, followed by either two spaces or a newline. +A sentence may also be terminated by the end of a paragraph. Any number of +closing delimiters, such as brackets or quotes, may be between the punctuation +and the whitespace. This somewhat complex definition of a sentence is used so +that periods in abbreviations are not misinterpreted as sentence ends. + +@defcom[com "Forward Sentence", bind {M-a}] +@defcom1[com "Backward Sentence", bind {M-e}] +@index[motion, sentence]@hid[Forward Sentence] moves the point forward +past the next sentence end. @hid[Backward Sentence] moves to the beginning +of the current sentence. A prefix argument may be used as a repeat count. +@enddefcom + +@defcom[com "Forward Kill Sentence", bind {M-k}] +@defcom1[com "Backward Kill Sentence", bind (C-x Delete, C-x Backspace)] +@index[killing, sentence]@hid[Forward Kill Sentence] kills text from the +point through to the end of the current sentence. @hid[Backward Kill Sentence] +kills from the point to the beginning of the current sentence. A +prefix argument may be used as a repeat count. +@enddefcom + +@defcom[com "Mark Sentence"] +This command puts the point at the beginning and the mark at the end of the +next or current sentence. +@enddefcom + + +@section[Paragraph Commands] + +@index[paragraph commands]A paragraph may be delimited by a blank line or a +line beginning with "@f[']" or "@f[.]", in which case the delimiting line is +not part of the paragraph. Other characters may be paragraph delimiters in +some modes. A line with at least one leading whitespace character may also +introduce a paragraph and is considered to be part of the paragraph. Any +fill-prefix which is present on a line is disregarded for the purpose of +locating a paragraph boundary. + +@defcom[com "Forward Paragraph", bind (@bf)] +@defcom1[com "Backward Paragraph", bind (M-[)] +@index[motion, paragraph]@index[paragraph, motion]@hid[Forward Paragraph] +moves to the end of the current or next paragraph. @hid[Backward Paragraph] +moves to the beginning of the current or previous paragraph. A prefix +argument may be used as a repeat count. +@enddefcom + +@defcom[com "Mark Paragraph", bind {M-h}] +This command puts the point at the beginning and the mark at the end of the +current paragraph. +@enddefcom + +@defhvar[var "Paragraph Delimiter Function", val {default-para-delim-function}] +This variable holds a function that takes a mark as its argument and returns +true when the line it points to should break the paragraph. +@enddefhvar + +@section[Filling] + +@index[filling]@index[formatting]Filling is a coarse text-formatting +process which attempts to make all the lines roughly the same length, but +doesn't vary the amount of space between words. Editing text may leave +lines with all sorts of strange lengths; filling this text will return it +to a moderately aesthetic form. + +@defcom[com "Set Fill Column", bind (C-x f)] +This command sets the fill column to the column that the point is currently at, +or the one specified by the absolute value of prefix argument, if it is +supplied. The fill column is the column past which no text is permitted to +extend. +@enddefcom + +@defcom[com "Set Fill Prefix", bind (C-x .)] +This command sets the fill prefix to the text from the beginning of the +current line to the point. The fill-prefix is a string which filling commands +leave at the beginning of every line filled. This feature is useful for +filling indented text or comments. +@enddefcom + +@defhvar[var "Fill Column", val {75}] +@defhvar1[var "Fill Prefix", val {nil}] +These variables hold the value of the fill prefix and fill column, thus +setting these variables will change the way filling is done. If +@hid[Fill Prefix] is @nil, then there is no fill prefix. +@enddefcom + +@defcom[com "Fill Paragraph", bind {M-q}] +@index[paragraph, filling]This command fills the text in the current or next +paragraph. The point is not moved. +@enddefcom + +@defcom[com "Fill Region", bind {M-g}] +@index[region, filling]This command fills the text in the region. Since +filling can mangle a large quantity of text, this command asks for confirmation +before filling a large region (see @hid[Region Query Size].) +@enddefcom + + +@defcom[com "Auto Fill Mode"] +@index[modes, auto fill]This command turns on or off the @hid[Fill] +minor mode in the current buffer. When in @hid[Fill] mode, @bf[Space], +@bf[Return] and @bf[Linefeed] are rebound to commands that check whether +the point is past the fill column and fill the current line if it is. +This enables typing text without having to break the lines manually. + +If a prefix argument is supplied, then instead of toggling, the sign +determines whether @hid[Fill] mode is turned off; a positive argument +argument turns in on, and a negative one turns it off. +@enddefcom + +@defcom[com "Auto Fill Linefeed", stuff (bound to @bf[Linefeed] in @hid[Fill] mode)] +@defcom1[com "Auto Fill Return", stuff (bound to @bf[Return] in @hid[Fill] mode)] +@hid[Auto Fill Linefeed] fills the current line if it needs it and then goes to +a new line and inserts the fill prefix. @hid[Auto Fill Return] is similar, but +does not insert the fill prefix on the new line. +@enddefcom + +@defcom[com "Auto Fill Space", stuff (bound to @bf[Space] in @hid[Fill] mode)] +If no prefix argument is supplied, this command inserts a space and +fills the current line if it extends past the fill column. If the argument is +zero, then it fills the line if needed, but does not insert a space. If the +argument is positive, then that many spaces are inserted without filling. +@enddefcom + +@defhvar[var "Auto Fill Space Indent", val {nil}] +This variable determines how lines are broken by the auto fill commands. If it +is true, new lines are created using the @hid[Indent New Comment Line] command, +otherwise the @hid[New Line] command is used. Language modes should define +this variable to be true so that auto fill mode can be used on code. +@enddefhvar + + +@section[Scribe Mode] + +@hid[Scribe] mode provides a number of facilities useful for editing Scribe +documents. It is also sufficiently parameterizable to be adapted to other +similar syntaxes. + +@defcom[com "Scribe Mode"] +@index[modes, scribe]This command puts the current buffer in @hid[Scribe] mode. +Except for special Scribe commands, the only difference between @hid[Scribe] +mode and @hid[Text] mode is that the rules for determining paragraph breaks are +different. In @hid[Scribe] mode, paragraphs delimited by Scribe commands are +normally placed on their own line, in addition to the normal paragraph breaks. +The main reason for doing this is that it prevents @hid[Fill Paragraph] from +mashing these commands into the body of a paragraph. +@enddefcom + +@defcom[com "Insert Scribe Directive", stuff (@bf[C-h] in @hid[Scribe] mode)] +This command prompts for a key-event to determine which Scribe directive to +insert. Directives are inserted differently depending on their kind: +@begin[description] +@i[environment]@\ +The current or next paragraph is enclosed in a begin-end pair: +@f<@@begin[@i{directive}]> @i[paragraph] @f<@@end[@i{directive}]>. If the +current region is active, then this command encloses the region instead of the +paragraph it would otherwise chose. + +@i[command]@\ +The previous word is enclosed by @f<@@@i[directive][@i[word]]>. If the +previous word is already enclosed by a use of the same command, then the +beginning of the command is extended backward by one word. +@end[description] + +Typing @bf[Home] or @bf[C-_] to this command's prompt will display a list of +all the defined key-events on which it dispatches. +@enddefcom + +@defcom[com "Add Scribe Directive"] +This command adds to the database of directives recognized by the +@hid[Insert Scribe Directive] command. It prompts for the directive's name, +the kind of directive (environment or command) and the key-event on which to +dispatch. +@enddefcom + +@defcom[com "Add Scribe Paragraph Delimiter"] +@defcom1[com "List Scribe Paragraph Delimiters"] +@hid[Add Scribe Paragraph Delimiter] prompts for a string to add to the list of +formatting commands that delimit paragraphs in @hid[Scribe] mode. If the user +supplies a prefix argument, then this command removes the string as a +delimiter. + +@hid[List Scribe Paragraph Delimiters] displays in a pop-up window the Scribe +commands that delimit paragraphs. +@enddefcom + +@defhvar[var "Escape Character", val {#\@@}] +@defhvar1[var "Close Paren Character", val {#\]}] +@defhvar1[var "Open Paren Character", val {#\[}] +These variables determine the characters used when a Scribe directive is +inserted. +@enddefhvar + +@defcom[com "Scribe Insert Bracket"] +@defhvar1[var "Scribe Bracket Table"] +@hid[Scribe Insert Bracket] inserts a bracket (@bf[>], @bf[}], @bf[)], or +@bf<]>), that caused its invocation, and then shows the matching bracket. + +@hid[Scribe Bracket Table] holds a @f[simple-vector] indexed by character +codes. If a character is a bracket, then the entry for its @f[char-code] +should be the opposite bracket. If a character is not a bracket, then the +entry should be @nil. +@enddefcom + + +@section[Spelling Correction] +@index[spelling correction] +@hemlock has a spelling correction facility based on the dictionary for the ITS +spell program. This dictionary is fairly small, having only 45,000 word or so, +which means it fits on your disk, but it also means that many reasonably common +words are not in the dictionary. A correct spelling for a misspelled word will +be found if the word is in the dictionary and is only erroneous in that it has +a wrong character, a missing character, an extra character or a transposition +of two characters. + + +@defcom[com "Check Word Spelling", bind (M-$)] +This command looks up the previous or current word in the dictionary and +attempts to correct the spelling if it is misspelled. There are four possible +results of invoking this command: +@begin[enumerate] +This command displays the message "@f[Found it.]" in the echo area. This means +it found the word in the dictionary exactly as given. + +This command displays the message "@f[Found it because of @i[word].]", where +@i[word] is some other word with the same root but a different ending. The +word is no less correct than if the first message is given, but an additional +piece of useless information is supplied to make you feel like you are using a +computer. + +The command prompts with "@f[Correction choice:]" in the echo area and lists +possible correct spellings associated with numbers in a pop-up display. Typing +a number selects the corresponding correction, and the command replaces the +erroneous word, preserving case as though by @hid[Query Replace]. Typing +anything else rejects all the choices. + +This commands displays the message "@f[Word not found.]". The word is not in +the dictionary and possibly spelled correctly anyway. Furthermore, no +similarly spelled words were found to offer as possible corrections. If this +happens, it is worth trying some alternate spellings since one of them might +be close enough to some known words that this command could display. +@end[enumerate] +@enddefcom + +@defcom[com "Correct Buffer Spelling"] +This command scans the entire buffer looking for misspelled words and offers to +correct them. It creates a window into the @hid[Spell Corrections] buffer, and +in this buffer it maintains a log of any actions taken by the user. When this +finds an unknown word, it prompts for a key-event. The user has the following +options: +@begin[description] +@bf[a]@\ + Ignore this word. If the command finds the word again, it will prompt again. + +@bf[i]@\ + Insert this word in the dictionary. + +@bf[c]@\ + Choose one of the corrections displayed in the @hid[Spell Corrections] window +by specifying the correction number. If the same misspelling is encountered +again, then the command will make the same correction automatically, leaving a +note in the log window. + +@bf[r]@\ + Prompt for a word to use instead of the misspelled one, remembering the +correction as with @bf[c]. + +@binding[C-r]@\ + Go into a recursive edit at the current position, and resume checking when the +recursive edit is exited. +@end[description] +After this command completes, it deletes the log window leaving the buffer +around for future reference. +@enddefcom + +@defhvar[var "Spell Ignore Uppercase", val {nil}] +@index[case sensitivity] +If this variable is true, then @hid[Auto Check Word Spelling] and @hid[Correct +Buffer Spelling] will ignore unknown words that are all uppercase. This is +useful for acronyms and cryptic formatter directives. +@enddefhvar + +@defcom[com "Add Word to Spelling Dictionary", bind (C-x $)] +This command adds the previous or current word to the spelling dictionary. +@enddefcom + +@defcom[com "Remove Word from Spelling Dictionary"] +This command prompts for a word to remove from the spelling dictionary. Due to +the dictionary representation, removal of a word in the initial spelling +dictionary will remove all words with the same root. The user is asked for +confirmation before removing a root word with valid suffix flags. +@enddefcom + +@defcom[com "List Incremental Spelling Insertions"] +This command displays the incremental spelling insertions for the current +buffer's associated spelling dictionary file. +@enddefcom + +@defcom[com "Read Spelling Dictionary"] +This command adds some words from a file to the spelling dictionary. The +format of the file is a list of words, one on each line. +@enddefcom + +@defcom[com "Save Incremental Spelling Insertions"] +This command appends incremental dictionary insertions to a file. Any words +added to the dictionary since the last time this was done will be appended to +the file. Except for @hid[Augment Spelling Dictionary], all the commands that +add words to the dictionary put their insertions in this list. The file is +prompted for unless @hid[Set Buffer Spelling Dictionary] has been executed in +the buffer. +@enddefcom + +@defcom[com "Set Buffer Spelling Dictionary"] +This command Prompts for the dictionary file to associate with the current +buffer. If the specified dictionary file has not been read for any other +buffer, then it is read. Incremental spelling insertions from this buffer +can be appended to this file with @hid[Save Incremental Spelling +Insertions]. If a buffer has an associated spelling dictionary, then +saving the buffer's associated file also saves any incremental dictionary +insertions. The @w<"@f[Dictionary: ]@i[file]"> file option may also be +used to specify the dictionary for a buffer (see section +@ref[file-options]). +@enddefcom + +@defhvar[var "Default User Spelling Dictionary", val {nil}] +This variable holds the pathname of a dictionary to read the first time +@hid[Spell] mode is entered in a given editing session. When +@hid[Set Buffer Spelling Dictionary] or the "@f[dictionary]" file option is +used to specify a dictionary, this default one is read also. It defaults to +nil. +@enddefhvar + + +@subsection[Auto Spell Mode] +@hid[Auto Spell Mode] checks the spelling of each word as it is typed. +When an unknown word is typed the user is notified and allowed to take a +number of actions to correct the word. + +@defcom[com "Auto Spell Mode"] +This command turns @hid[Spell] mode on or off in the current buffer. +@enddefcom + +@defcom[com "Auto Check Word Spelling", + stuff (bound to word delimiters in @hid[Spell] mode)] +@defhvar1[var "Check Word Spelling Beep", val {t}] +@defhvar1[var "Correct Unique Spelling Immediately", val {t}] +This command checks the spelling of the word before the point, doing nothing if +the word is in the dictionary. If the word is misspelled but has a known +correction previously supplied by the user, then this command corrects the +spelling. If there is no correction, then this displays a message in the echo +area indicating the word is unknown. An unknown word detected by this command +may be corrected using the @hid[Correct Last Misspelled Word] command. This +command executes in addition to others bound to the same key; for example, if +@hid[Fill] mode is on, any of its commands bound to the same keys as this +command also run. + +If @hid[Check Word Spelling Beep] is true, then this command will beep when an +unknown word is found. If @hid[Correct Unique Spelling Immediately] is true, +then this command will immediately attempt to correct any unknown word, +automatically making the correction if there is only one possible. +@enddefhvar + +@defcom[com "Undo Last Spelling Correction", bind (C-x a)] +@defhvar1[var "Spelling Un-Correct Prompt for Insert", val {nil}] +@hid[Undo Last Spelling Correction] undoes the last incremental spelling +correction. The "correction" is replaced with the old word, and the old word +is inserted in the dictionary. Any automatic replacement for the old word is +eliminated. When @hid[Spelling Un-Correct Prompt for Insert] is true, the user +is asked to confirm the insertion into the dictionary. +@enddefcom + +@defcom[com "Correct Last Misspelled Word", bind (M-:)] +This command places the cursor after the last misspelled word detected by the +@hid[Auto Check Word Spelling] command and then prompts for a key-event on +which it dispatches: +@begin[description] +@bf[c]@\ + Display possible corrections in a pop-up window, and prompt for the one to +make according to the corresponding displayed digit or letter. + +@i[any digit]@\ + Similar to @bf[c] @i[digit], but immediately makes the correction, dispensing +with display of the possible corrections. This is shorter, but only works when +there are less than ten corrections. + +@bf[i]@\ + Insert the word in the dictionary. + +@bf[r]@\ + Replace the word with another. + +@binding[Backspace, Delete, n]@\ + Skip this word and try again on the next most recently misspelled word. + +@binding[C-r]@\ + Enter a recursive edit at the word, exiting the command when the recursive +edit is exited. + +@binding[Escape]@\ + Exit and forget about this word. +@end[description] +As in @hid[Correct Buffer Spelling], the @bf[c] and @bf[r] commands add the +correction to the known corrections. +@enddefcom + + + +@chap[Managing Large Systems] + +@hemlock provides three tools which help to manage large systems: +@begin[enumerate] +File groups, which provide several commands that operate on all the files +in a possibly large collection, instead of merely on a single buffer. + +A source comparison facility with semi-automatic merging, which can be used +to compare and merge divergent versions of a source file. + +A change log facility, which maintains a single file containing a record of the +edits done on a system. +@end[enumerate] + + +@section[File Groups] + +@index[file groups]@index[searching, group]@index[replacing, group] +A file group is a set of files, upon which various editing operations can be +performed. The files in a group are specified by a file in the following +format: +@begin[itemize] +Any line which begins with one "@f[@@]" is ignored. + +Any line which does not begin with an "@f[@@]" is the name of a file in the +group. + +A line which begins with "@f[@@@@]" specifies another file having this +syntax, which is recursively examined to find more files in the group. +@end[itemize] +This syntax is used for historical reasons. Although any number of file groups +may be read into @hemlock, there is only one @i[active group], which is the +file group implicitly used by all of the file group commands. +Page @pageref[compile-group-command] describes the @hid[Compile Group] command. + +@defcom[com "Select Group"] +This command prompts for the name of a file group to make the active group. +If the name entered is not the name of a group whose definition has been +read, then the user is prompted for the name of a file to read the group +definition from. The name of the default pathname is the name of the +group, and the type is "@f[upd]". +@enddefcom + +@defcom[com "Group Query Replace"] +This command prompts for target and replacement strings and then executes an +interactive string replace on each file in the active group. This reads in +each file as if @hid[Find File] were used and processes it as if @hid[Query +Replace] were executing. +@enddefcom + +@defcom[com "Group Replace"] +This is like @hid[Group Query Replace] except that it executes a +non-interactive replacement, similar to @hid[Replace String]. +@enddefcom + +@defcom[com "Group Search"] +This command prompts for a string and then searches for it in each file in the +active group. This reads in each file as if @hid[Find File] were used. When +it finds an occurrence, it prompts the user for a key-event indicating what +action to take. The following commands are defined: +@begin[description] +@binding[Escape, Space, y]@\ + Exit @hid[Group Search]. + +@binding[Delete, Backspace, n]@\ + Continue searching for the next occurrence of the string. + +@binding[!]@\ + Continue the search at the beginning of the next file, skipping the remainder +of the current file. + +@binding[C-r]@\ + Go into a recursive edit at the current location, and continue the search when +it is exited. +@end[description] +@enddefcom + +@defhvar[var "Group Find File", val {nil}] +The group searching and replacing commands read each file into its own buffer +using @hid[Find File]. Since this may result in large amounts of memory being +consumed by unwanted buffers, this variable controls whether to delete the +buffer after processing it. When this variable is false, the default, the +commands delete the buffer if it did not previously exist; however, regardless +of this variable, if the user leaves the buffer modified, the commands will not +delete it. +@enddefhvar + +@defhvar[var "Group Save File Confirm", val {t}] +If this variable is true, the group searching and replacing commands ask for +confirmation before saving any modified file. The commands attempt to save +each file processed before going on to the next one in the group. +@enddefhvar + + +@section[Source Comparison] +@index[buffer, merging] +@index[buffer, comparison] +@index[source comparison] + +These commands can be used to find exactly how the text in two buffers differs, +and to generate a new version that combines features of both versions. + +@defhvar[var "Source Compare Default Destination", val {"Differences"}] +This is a sticky default buffer name to offer when comparison commands prompt +for a buffer in which to insert the results. +@enddefhvar + +@defcom[com "Compare Buffers"] +This command prompts for three buffers and then does a buffer comparison. +The first two buffers must exist, as they are the buffers to be compared. +The last buffer, which is created if it does not exist, is the buffer to +which output is directed. The output buffer is selected during the +comparison so that its progress can be monitored. There are various variables +that control exactly how the comparison is done. + +If a prefix argument is specified, then only only the lines in the the regions +of the two buffers are compared. +@enddefcom + +@defcom[com "Buffer Changes"] +This command compares the contents of the current buffer with the disk version +of the associated file. It reads the file into the buffer +@hid[Buffer Changes File], and generates the comparison in the buffer +@hid[Buffer Changes Result]. As with @hid[Compare Buffers], the output buffer +is displayed in the current window. +@enddefcom + +@defcom[com "Merge Buffers"] +This command functions in a very similar fashion to @hid[Compare Buffers], the +difference being that a version which is a combination of the two buffers being +compared is generated in the output buffer. This copies text that is identical +in the two comparison buffers to the output buffer. When it encounters a +difference, it displays the two differing sections in the output buffer and +prompts the user for a key-event indicating what action to take. The following +commands are defined: +@begin[description] +@bf[1]@\ + Use the first version of the text. + +@bf[2]@\ + Use the second version. + +@bf[b]@\ + Insert the string @w<"@f[**** MERGE LOSSAGE ****]"> followed by both versions. +This is useful if the differing sections are too complex, or it is unclear +which is the correct version. If you cannot make the decision conveniently at +this point, you can later search for the marking string above. + +@binding[C-r]@\ + Do a recursive edit and ask again when the edit is exited. +@end[description] +@enddefcom + + +@defhvar[var "Source Compare Ignore Case", val {nil}] +@index[case sensitivity] +If this variable is non-@nil, @hid[Compare Buffers] and @hid[Merge Buffers] +will do comparisons case-insensitively. +@enddefhvar + +@defhvar[var "Source Compare Ignore Indentation", val {nil}] +If this variable is non-@nil, @hid[Compare Buffers] and @hid[Merge Buffers] +ignore initial whitespace when comparing lines. +@enddefhvar + +@defhvar[var "Source Compare Ignore Extra Newlines", val {t}] +If this variable is true, @hid[Compare Buffers] and @hid[Merge Buffers] +will treat all groups of newlines as if they were a single newline. +@enddefhvar + +@defhvar[var "Source Compare Number of Lines", val {3}] +This variable controls the number of lines @hid[Compare Buffers] and +@hid[Merge Buffers] will compare when resynchronizing after a difference +has been encountered. +@enddefhvar + + +@section[Change Logs] +@label[log-files] +@index[edit history] +@index[change log] + +The @hemlock change log facility encourages the recording of changes to a +system by making it easy to do so. The change log is kept in a separate file +so that it doesn't clutter up the source code. The name of the log for a file +is specified by the @f[Log] file option (see page @pageref[file-options].) + +@defcom[com "Log Change"] +@defhvar1[var "Log Entry Template"] +@hid[Log Change] makes a new entry in the change log associated with the file. +Any changes in the current buffer are saved, and the associated log file is +read into its own buffer. The name of the log file is determined by merging +the name specified in the @f[Log] option with the current buffer's file name, +so it is not usually necessary to put the full name there. After inserting a +template for the log entry at the beginning of the buffer, the command enters a +recursive edit (see page @pageref[recursive-edits]) so that the text of the +entry may be filled in. When the user exits the recursive edit, the log file +is saved. + +The variable @hid[Log Entry Template] determines the format of the change log +entry. Its value is a @clisp @f[format] control string. The format string is +passed three string arguments: the full name of the file, the creation date for +the file and the name of the file author. If the creation date is not +available, the current date is used. If the author is not available then @nil +is passed. If there is an @f[@@] in the template, then it is deleted and the +point is left at that position. +@enddefcom + + + +@comment[@chap (Special Modes)] +@include(special-modes) + + + +@chap[Editing Programs] + + +@section[Comment Manipulation] +@index[comment manipulation] +@hemlock has commenting commands which can be used in almost any language. The +behavior of these commands is determined by several @hemlock variables which +language modes should define appropriately. + +@defcom[com "Indent for Comment", bind (M-;)] +@index[indentation, comment]@label[comment-indentation] +This is the most basic commenting command. If there is already a comment on +the current line, then this moves the point to the start of the comment. If +there no comment, this creates an empty one. + +This command normally indents the comment to start at @hid[Comment Column]. +The comment indents differently in the following cases: +@begin[enumerate] +If the comment currently starts at the beginning of the line, or if the last +character in the @hid[Comment Start] appears three times, then the comment +remains unmoved. + +If the last character in the @hid[Comment Start] appears two times, then the +comment is indented like a line of code. + +If text on the line prevents the comment occurring in the desired position, +this places the comment at the end of the line, separated from the text by a +space. +@end[enumerate] +Although the rules about replication in the comment start are oriented toward +Lisp commenting styles, you can exploit these properties in other languages. + +When given a prefix argument, this command indents any existing comment on that +many consecutive lines. This is useful for fixing up the indentation of a +group of comments. +@enddefcom + +@defcom[com "Indent New Comment Line", bind {M-j, M-Linefeed}] +This commend ends the current comment and starts a new comment on a blank line, +indenting the comment the same way that @hid[Indent for Comment] does. +When not in a comment, this command is the same as @hid[Indent New Line]. +@enddefcom + +@defcom[com "Up Comment Line", bind {M-p}] +@defcom1[com "Down Comment Line", bind {M-n}] +These commands are similar to @hid[Previous Line] or @hid[Next Line] +followed by @hid[Indent for Comment]. Any empty comment on the current line is +deleted before moving to the new line. +@enddefcom + +@defcom[com "Kill Comment", bind (C-M-;)] +This command kills any comment on the current line. When given a prefix +argument, it kills comments on that many consecutive lines. @hid[Undo] will +restore the unmodified text. +@enddefcom + +@defcom[com "Set Comment Column", bind (C-x ;)] +This command sets the comment column to its prefix argument. If used without a +prefix argument, it sets the comment column to the column the point is at. +@enddefcom + +@defhvar[var "Comment Start", val {nil}] +@defhvar1[var "Comment End", val {nil}] +@defhvar1[var "Comment Begin", val {nil}] +@defhvar1[var "Comment Column", val {0}] +These variables determine the behavior of the comment commands. +@begin[description] +@hid[Comment Start]@\The string which indicates the start of a comment. If +this is @nil, then there is no defined comment syntax. + +@hid[Comment End]@\The string which ends a comment. If this is @nil, then +the comment is terminated by the end of the line. + +@hid[Comment Begin]@\The string inserted to begin a new comment. + +@hid[Comment Column]@\The column that normal comments start at. +@end[description] +@enddefcom + + +@section[Indentation] +@label[indentation] +@index[indentation] +Nearly all programming languages have conventions for indentation or leading +whitespace at the beginning of lines. The @hemlock indentation facility is +integrated into the command set so that it interacts well with other features +such as filling and commenting. + +@defcom[com "Indent", bind (Tab, C-i)] +This command indents the current line. With a prefix argument, indents that +many lines and moves down. Exactly what constitutes indentation depends on the +current mode (see @hid[Indent Function]). +@enddefcom + +@defcom[com "Indent New Line", bind (Linefeed)] +This command starts a new indented line. Deletes any whitespace before the +point and inserts indentation on a blank line. The effect of this is similar +to @binding[Return] followed by @binding[Tab]. The prefix argument is passed +to @hid[New Line], which is used to insert the blank line. +@enddefcom + +@defcom[com "Indent Region", bind (C-M-\)] +This command indents every line in the region. It may be undone with +@hid[Undo]. +@enddefcom + +@defcom[com "Back to Indentation", bind {M-m, C-M-m}] +@index[motion, indentation] +This command moves point to the first non-whitespace character on the current +line. +@enddefcom + +@defcom[com "Delete Indentation", bind (M-^, C-M-^)] +@hid[Delete Indentation] joins the current line with the previous one, deleting +excess whitespace. This operation is the inverse of the @bf[Linefeed] command +in most modes. Usually this leaves one space between the two joined lines, but +there are several exceptions. + +The non-whitespace immediately surrounding the deleted line break determine the +amount of space inserted. +@begin[enumerate] +If the preceding character is an "@f[(]" or the following character is a +"@f[)]", then this inserts no space. + +If the preceding character is a newline, then this inserts no space. This will +happen if the previous line was blank. + +If the preceding character is a sentence terminator, then this inserts two +spaces. +@end[enumerate] + +When given a prefix argument, this command joins the current and next lines, +rather than the previous and current lines. +@enddefcom + +@defcom[com "Quote Tab", bind (M-Tab)] +This command inserts a tab character. +@enddefcom + +@defcom[com "Indent Rigidly", bind (C-x Tab, C-x C-i)] +This command changes the indentation of all the lines in the region. Each +line is moved to the right by the number of spaces specified by the prefix +argument, which defaults to eight. A negative prefix argument moves lines +left. +@enddefcom + +@defcom[com "Center Line"] +This indents the current line so that it is centered between the left margin +and @hvarref[Fill Column]. If a prefix argument is supplied, then it is used +as the width instead of @hid[Fill Column]. +@enddefcom + +@defhvar[var "Indent Function", val {tab-to-tab-stop}] +The value of this variable determines how indentation is done, and it is a +function which is passed a mark as its argument. The function should indent +the line which the mark points to. The function may move the mark around on +the line. The mark will be @f[:left-inserting]. The default simply inserts a +tab character at the mark. +@enddefhvar + +@defhvar[var "Indent with Tabs", val {indent-using-tabs}] +@defhvar1[var "Spaces per Tab", val {8}] +@hid[Indent with Tabs] holds a function that takes a mark and a number of +spaces. The function will insert a maximum number of tabs and a minimum number +of spaces at mark to move the specified number of columns. The default +definition uses @hid[Spaces per Tab] to determine the size of a tab. @i[Note,] +@hid[Spaces per Tab] @i[is not used everywhere in @hemlock yet, so changing +this variable could have unexpected results.] +@enddefhvar + + +@section[Language Modes] + +@hemlock@comment{}'s language modes are currently fairly crude, but probably +provide better programming support than most non-extensible editors. + +@defcom[com "Pascal Mode"] +@index[indentation, pascal]@index[modes, pascal]This command sets the current +buffer's major mode to @hid[Pascal]. @hid[Pascal] mode borrows parenthesis +matching from Scribe mode and indents lines under the previous line. +@enddefcom + + +@chap[Editing Lisp] +@index[lisp, editing] +@hemlock provides a large number of powerful commands for editing Lisp code. +It is possible for a text editor to provide a much higher level of support for +editing Lisp than ordinary programming languages, since its syntax is much +simpler. + + +@section[Lisp Mode] +@index[lisp mode] +@index[modes, lisp] +@hid[Lisp] mode is a major mode used for editing Lisp code. Although most +Lisp specific commands are globally bound, @hid[Lisp] mode is necessary to +enable Lisp indentation, commenting, and parenthesis-matching. Whenever the +user or some @hemlock mechanism turns on @hid[Lisp] mode, the mode's setup +includes locally setting @hid[Current Package] (see section @ref[lisp-package]) +in that buffer if its value is non-existent there; the value used is +@f["USER"]. + +@defcom[com "Lisp Mode"] +This command sets the major mode of the current buffer to @hid[Lisp]. +@enddefcom + + +@section[Form Manipulation] +@index[form manipulation] +These commands manipulate Lisp forms, the printed representations of Lisp +objects. A form is either an expression balanced with respect to parentheses +or an atom such as a symbol or string. + +@defcom[com "Forward Form", bind (C-M-f)] +@defcom1[com "Backward Form", bind (C-M-b)] +@index[motion, form]@hid[Forward Form] moves to the end of the current or +next form, while @hid[Backward Form] moves to the beginning of the current +or previous form. A prefix argument is treated as a repeat count. +@enddefcom + +@defcom[com "Forward Kill Form", bind (C-M-k)] +@defcom1[com "Backward Kill Form", bind (C-M-Delete, C-M-Backspace)] +@index[killing, form]@hid[Forward Kill Form] kills text from the point to +the end of the current form. If at the end of a list, but inside the close +parenthesis, then kill the close parenthesis. @hid[Backward Kill Form] is +the same, except it goes in the other direction. A prefix argument is +treated as a repeat count. +@enddefcom + +@defcom[com "Mark Form", bind (C-M-@@)] +This command sets the mark at the end of the current or next form. +@enddefcom + +@defcom[com "Transpose Forms", bind (C-M-t)] +This command transposes the forms before and after the point and moves +forward. A prefix argument is treated as a repeat count. If the prefix +argument is negative, then the point is moved backward after the +transposition is done, reversing the effect of the equivalent positive +argument. +@enddefcom + +@defcom[com "Insert ()", bind {M-(}] +This command inserts an open and a close parenthesis, leaving the point +inside the open parenthesis. If a prefix argument is supplied, then the +close parenthesis is put at the end of the form that many forms from the +point. +@enddefcom + +@defcom[com "Extract Form"] +This command replaces the current containing list with the next form. The +entire affected area is pushed onto the kill ring. If an argument is supplied, +that many upward levels of list nesting is replaced by the next form. This is +similar to @hid[Extract List], but this command is more generally useful since +it works on any kind of form; it is also more intuitive since it operates on +the next form as many @hid[Lisp] mode commands do. +@enddefcom + + +@section[List Manipulation] + +@index[list manipulation]List commands are similar to form commands, but +they only pay attention to lists, ignoring any atomic objects that may +appear. These commands are useful because they can skip over many symbols +and move up and down in the list structure. + +@defcom[com "Forward List", bind (C-M-n)] +@defcom1[com "Backward List", bind (C-M-p)] +@index[motion, list]@hid[Forward List] moves the point to immediately +after the end of the next list at the current level of list structure. If +there is not another list at the current level, then it moves up past +the end of the containing list. +@hid[Backward List] is identical, except that it moves backward and leaves +the point at the beginning of the list. The prefix argument is used as a +repeat count. +@enddefcom + +@defcom[com "Forward Up List", bind {C-M-@bf<)>}] +@defcom1[com "Backward Up List", bind (C-M-@bf<(>, C-M-u)] +@hid[Forward Up List] moves to after the end of the enclosing list. +@hid[Backward Up List] moves to the beginning. The prefix argument is used +as a repeat count. +@enddefcom + +@defcom[com "Down List", bind (C-M-d)] +This command moves to just after the beginning of the next list. The +prefix argument is used as a repeat count. +@enddefcom + +@defcom[com "Extract List", bind (C-M-x)] +This command "extracts" the current list from the list which contains it. +The outer list is deleted, leaving behind the current list. The entire +affected area is pushed on the kill ring, so that this possibly catastrophic +operation can be undone. The prefix argument is used as a repeat count. +@enddefcom + + + +@section[Defun Manipulation] + +@index[defun manipulation]A @i[defun] is a list whose open parenthesis is +against the left margin. It is called this because an occurrence of the +@f[defun] top level form usually satisfies this definition, but +other top level forms such as a @f[defstruct] and @f[defmacro] work just as +well. + +@defcom[com "End of Defun", bind (@bf)] +@defcom1[com "Beginning of Defun", bind (C-M-a, C-M-[)] +@index[motion, defun]@hid[End of Defun] moves to the end of the current +or next defun. @hid[Beginning of Defun] moves to the beginning of the +current or previous defun. @hid[End of Defun] will not work if the +parentheses are not balanced. +@enddefcom + +@defcom[com "Mark Defun", bind (C-M-h)] +This command puts the point at the beginning and the mark at the end of the +current or next defun. +@enddefcom + + + +@section[Indentation] + +@index[indentation, lisp] +One of the most important features provided by @hid[Lisp] mode is automatic +indentation of Lisp code. Since unindented Lisp is unreadable, poorly indented +Lisp is hard to manage, and inconsistently indented Lisp is subtly misleading. +See section @ref[indentation] for a description of the general-purpose +indentation commands. @hid[Lisp] mode uses these indentation rules: +@begin[itemize] +If in a semicolon (@f[;]) comment, then use the standard comment indentation +rules. See page @pageref[comment-indentation]. + +If in a quoted string, then indent to the column one greater than the column +containing the opening double quote. This is exactly what you want in function +documentation strings and wrapping @f[error] strings. + +If there is no enclosing list, then use no indentation. + +If enclosing list resembles a call to a known macro or special-form, then the +first few arguments are given greater indentation and the first body form is +indented two spaces. If the first special argument is on the same line as the +beginning of the form, then following special arguments will be indented to the +start of the first special argument, otherwise all special arguments are +indented four spaces. + +If the previous form starts on its own line, then the indentation is copied +from that form. This rule allows the default indentation to be overridden: +once a form has been manually indented to the user's satisfaction, subsequent +forms will be indented in the same way. + +If the enclosing list has some arguments on the same line as the form start, +then subsequent arguments will be indented to the start of the first argument. + +If the enclosing list has no argument on the same line as the form start, then +arguments will be indented one space. +@end[itemize] + + +@defcom[com "Indent Form", bind (C-M-q)] +This command indents all the lines in the current form, leaving the point +unmoved. This is undo-able. +@enddefcom + +@defcom[com "Fill Lisp Comment Paragraph", + stuff ] +@defhvar1[var "Fill Lisp Comment Paragraph Confirm", val {t}] +This fills a flushleft or indented Lisp comment. This also fills Lisp string +literals using the proper indentation as a filling prefix. When invoked +outside of a comment or string, this tries to fill all contiguous lines +beginning with the same initial, non-empty blankspace. When filling a comment, +the current line is used to determine a fill prefix by taking all the initial +whitespace on the line, the semicolons, and any whitespace following the +semicolons. + +When invoked outside of a comment or string, this command prompts for +confirmation before filling. It is useful to use this for filling long +@f[export] lists or other indented text or symbols, but since this is a less +common use, this command tries to make sure that is what you wanted. Setting +@hid[Fill Lisp Comment Paragraph Confirm] to @nil inhibits the confirmation +prompt. +@enddefcom + +@defcom[com "Defindent", bind (C-M-#)] +This command prompts for the number of special arguments to associate with +the symbol at the beginning of the current or containing list. +@enddefcom + +@defhvar[var "Indent Defanything", val {2}] +This is the number of special arguments implicitly assumed to be supplied in +calls to functions whose names begin with "@f[def]". If set to @nil, this +feature is disabled. +@enddefhvar + +@defcom[com "Move Over )", bind {M-)}] +This command moves past the next close parenthesis and then does the equivalent +of @hid[Indent New Line]. +@enddefcom + + +@section[Parenthesis Matching] + +@index[parenthesis matching]Another very important facility provided by +@hid[Lisp] mode is @i[parenthesis matching]. Two different styles of +parenthesis matching are supported: highlighting and pausing. + +@defhvar[var "Highlight Open Parens", val {t}] +@defhvar1[var "Open Paren Highlighting Font", val {nil}] +When @hid[Highlight Open Parens] is true, and a close paren is immediately +before the point, then @hemlock displays the matching open paren in @hid[Open +Paren Highlighting Font]. + +@hid[Open Paren Highlighting Font] is the string name of the font used for +paren highlighting. Only the "@f[(]" character is used in this font. If null, +then a reasonable default is chosen. The highlighting font is read at +initialization time, so this variable must be set before the editor is first +entered to have any effect. +@enddefhvar + +@defcom[com "Lisp Insert )", stuff ] +@defhvar1[var "Paren Pause Period", val {0.5}] +This command inserts a close parenthesis and then attempts to display the +matching open parenthesis by placing the cursor on top of it for +@hid[Paren Pause Period] seconds. If there is no matching parenthesis then +beep. If the matching parenthesis is off the top of the screen, then the line +on which it appears is displayed in the echo area. Paren pausing may be +disabled by setting @hid[Paren Pause Period] to @nil. +@enddefcom + +The initial values shown for @hid[Highlight Open Parens] and @hid[Paren Pause +Period] are only approximately correct. Since paren highlighting is only +meaningful in Lisp mode, @hid[Highlight Open Parens] is false globally, and +has a mode-local value of @true in Lisp mode. It it redundant to do both +kinds of paren matching, so there is also a binding of @hid[Paren Pause Period] +to @false in Lisp mode. + +Paren highlighting is only supported under @windows, so the above defaults are +conditional on the device type. If @hemlock is started on a terminal, the +initialization code makes Lisp mode bindings of @false and @f[0.5] for +@hid[Highlight Open Parens] and @hid[Paren Pause Period]. Since these +alternate default bindings are made at initialization time, the only way to +affect them is to use the @f[after-editor-initializations] macro. + + +@section[Parsing Lisp] +Lisp mode has a fairly complete knowledge of Lisp syntax, but since it does +not use the reader, and must work incrementally, it can be confused by legal +constructs. Lisp mode totally ignores the read-table, so user-defined read +macros have no effect on the editor. In some cases, the values the @hid[Lisp +Syntax] character attribute can be changed to get a similar effect. + +Lisp commands consistently treat semicolon (@f[;]) style comments as +whitespace when parsing, so a Lisp command used in a comment will affect the +next (or previous) form outside of the comment. Since @f[#| ... |#] comments +are not recognized, they can used to comment out code, while still allowing +Lisp editing commands to be used. + +Strings are parsed similarly to symbols. When within a string, the next form +is after the end of the string, and the previous form is the beginning of the +string. + + +@defhvar[var "Defun Parse Goal", val {2}] +@defhvar1[var "Maximum Lines Parsed", val {500}] +@defhvar1[var "Minimum Lines Parsed", val {50}] +In order to save time, Lisp mode does not parse the entire buffer every time +a Lisp command is used. Instead, it uses a heuristic to guess the region of +the buffer that is likely to be interesting. These variables control the +heuristic. + +Normally, parsing begins and ends on defun boundaries (an open parenthesis at +the beginning of a line). @hid[Defun Parse Goal] specifies the number of +defuns before and after the point to parse. If this parses fewer lines than +@hid[Minimum Lines Parsed], then parsing continues until this lower limit is +reached. If we cannot find enough defuns within @hid[Maximum Lines Parsed] +lines then we stop on the farthest defun found, or at the point where we +stopped if no defuns were found. + +When the heuristic fails, and does not parse enough of the buffer, then +commands usually act as though a syntax error was detected. If the parse +starts in a bad place (such as in the middle of a string), then Lisp commands +will be totally confused. Such problems can usually be eliminated by +increasing the values of some of these variables. +@enddefhvar + +@defhvar[var "Parse Start Function", val {start-of-parse-block}] +@defhvar1[var "Parse End Function", val {end-of-parse-block}] +These variables determine the region of the buffer parsed. The values are +functions that take a mark and move it to the start or end of the parse region. +The default values implement the heuristic described above. +@enddefhvar + + + +@comment[@chap(Interacting With Lisp)] +@include(lisp) + + +@comment[@chap(Mail Interface)] +@include(mail) + + +@comment[@chap(Netnews Interface)] +@include(netnews) + + + +@chap[System Interface] + +@hemlock provides a number of commands that access operating system resources +such as the filesystem and print servers. These commands offer an alternative +to leaving the editor and using the normal operating system command language +(such as the Unix shell), but they are implementation dependent. Therefore, +they might not even exist in some implementations. + + +@section[File Utility Commands] +This section describes some general file operation commands and quick directory +commands. + +See section @ref[dired] for a description @hemlock@comment{}'s directory editing +mechanism, @hid[Dired] mode. + +@defcom[com "Copy File"] +This command copies a file, allowing one wildcard in the filename. It prompts +for source and destination specifications. + +If these are both directories, then the copying process is recursive on the +source, and if the destination is in the subdirectory structure of the source, +the recursion excludes this portion of the directory tree. Use +@f[dir-spec-1/*] to copy only the files in a source directory without +recursively descending into subdirectories. + +If the destination specification is a directory, and the source is a file, then +it is copied into the destination with the same filename. + +The copying process copies files maintaining the source's write date. + +See the description of @hid[Dired Copy File Confirm], page +@pageref[copy-confirm], for controlling user interaction when the destination +exists. +@enddefcom + +@defcom[com "Rename File"] +This command renames a file, allowing one wildcard in the filename. It prompts +for source and destination specifications. + +If the destination is a directory, then the renaming process moves file(s) +indicated by the source into the directory with their original filenames. + +For Unix-based implementations, if you want to rename a directory, do not +specify the trailing slash in the source specification. +@enddefcom + +@defcom[com "Delete File"] +This command prompts for the name of a file and deletes it. +@enddefcom + +@defcom[com "Directory", bind (C-x C-d)] +@defcom1[com "Verbose Directory", bind (C-x C-D)] +These commands prompt for a pathname (which may contain wildcards), and display +a directory listing in a pop-up window. If a prefix argument is supplied, then +normally hidden files such as Unix dot-files will also be displayed. +@hid[Directory] uses a compact, multiple-column format; +@hid[Verbose Directory] displays one file on a line, with information about +protection, size, etc. +@enddefcom + + +@section[Printing] + +@defcom[com "Print Region"] +@defcom1[com "Print Buffer"] +@defcom1[com "Print File"] +@hid[Print Region] and @hid[Print Buffer] print the contents of the current +region and the current buffer, respectively. @hid[Print File] prompts for a +the name of a file and prints that file. Any error messages will be displayed +in the echo area. +@enddefcom + +@defhvar[var "Print Utility", val {"/usr/cs/bin/lpr"}] +@defhvar1[var "Print Utility Switches", val {()}] +@hid[Print Utility] is the program the print commands use to send files to the +printer. The program should act like @f[lpr]: if a filename is given as an +argument, it should print that file, and if no name appears, standard input +should be assumed. @hid[Print Utility Switches] is a list of strings +specifying the options to pass to the program. +@enddefhvar + + +@section[Scribe] +@defcom[com "Scribe Buffer File", + stuff (bound to @bf[C-x c] in @hid[Scribe] mode)] +@defhvar1[var "Scribe Buffer File Confirm", val {t}] +@defcom1[com "Scribe File"] +@hid[Scribe Buffer File] invokes @hid[Scribe Utility] on the file associated +with the current buffer. That process's default directory is the directory of +the file. The process sends its output to the @hid[Scribe Warnings] buffer. +Before doing anything, this asks the user to confirm saving and formatting the +file. This prompting can be inhibited with "Scribe Buffer File Confirm". + +@hid[Scribe File] invokes @hid[Scribe Utility] on a file supplied by the user +in the same manner as describe above. +@enddefcom + +@defhvar[var "Scribe Utility", val {"/usr/misc/bin/scribe"}] +@defhvar1[var "Scribe Utility Switches"] +@hid[Scribe Utility] is the program the Scribe commands use to compile the text +formatting. @hid[Scribe Utility Switches] is a list of strings whose contents +would be contiguous characters, other than space, had the user invoked this +program on a command line outside of @hemlock. Do not include the name of the +file to compile in this variable; the Scribe commands supply this. +@enddefhvar + +@defcom[com "Select Scribe Warnings", bind (Scribe: C-M-C)] +This command makes the @hid[Scribe Warnings] buffer current if it exists. +@enddefcom + + +@section[Miscellaneous] + +@defcom[com "Manual Page"] +This command displays a Unix manual page in a buffer which is in @hid[View] +mode. When given an argument, this puts the manual page in a pop-up display. +@enddefcom + +@defcom[com "Unix Filter Region"] +This command prompts for a UNIX program and then passes the current region to +the program as standard input. The standard output from the program is used to +replace the region. This command is undoable. +@enddefcom + + + +@chap[Simple Customization] + +@index[customization]@hemlock can be customized and extended to a very +large degree, but in order to do much of this a knowledge of Lisp is +required. These advanced aspects of customization are discussed in the +@i[Hemlock Command Implementor's Manual], while simpler methods of +customization are discussed here. + + +@section[Keyboard Macros] +@index[keyboard macros] +Keyboard macros provide a facility to turn a sequence of commands into one +command. + +@defcom[com "Define Keyboard Macro", bind {C-x (}] +@defcom1[com "End Keyboard Macro", bind {C-x )}] +@hid[Define Keyboard Macro] starts the definition of a keyboard macro. The +commands which are invoked up until @hid[End Keyboard Macro] is invoked +become the definition for the keyboard macro, thus replaying the keyboard +macro is synonymous with invoking that sequence of commands. +@enddefcom + +@defcom[com "Last Keyboard Macro", bind (C-x e)] +This command is the keyboard macro most recently defined; invoking it will +replay the keyboard macro. The prefix argument is used as a repeat count. +@enddefcom + +@defcom[com "Define Keyboard Macro Key", bind (C-x M-(; )] +@defhvar1[var "Define Keyboard Macro Key Confirm", val {t}] +This command prompts for a key before going into a mode for defining keyboard +macros. After defining the macro @hemlock binds it to the key. If the key is +already bound, @hemlock asks for confirmation before clobbering the binding; +this prompting can be inhibited by setting @hid[Define Keyboard Macro Key +Confirm] to @nil. +@enddefcom + +@defcom[com "Keyboard Macro Query", bind (C-x q)] +This command conditionalizes the execution of a keyboard macro. When invoked +during the definition of a macro, it does nothing. When the macro replays, it +prompts the user for a key-event indicating what action to take. The following +commands are defined: +@begin[description] +@binding[Escape]@\ + Exit all repetitions of this keyboard macro. More than one may have been +specified using a prefix argument. + +@binding[Space, y]@\ + Proceed with the execution of the keyboard macro. + +@binding[Delete, Backspace, n]@\ + Skip the remainder of the keyboard macro and go on to the next repetition, if +any. + +@binding[!]@\ + Do all remaining repetitions of the keyboard macro without prompting. + +@binding[.]@\ + Complete this repetition of the macro and then exit without doing any of the +remaining repetitions. + +@binding[C-r]@\ + Do a recursive edit and then prompt again. +@end[description] +@enddefcom + +@defcom[com "Name Keyboard Macro"] +This command prompts for the name of a command and then makes the +definition for that command the same as @hid[Last Keyboard Macro]'s current +definition. The command which results is not clobbered when another +keyboard macro is defined, so it is possible to keep several keyboard +macros around at once. The resulting command may also be bound to a key +using @hid[Bind Key], in the same way any other command is. +@enddefcom + +Many keyboard macros are not for customization, but rather for one-shot +use, a typical example being performing some operation on each line of a file. +To add "@f[del ]" to the beginning and "@f[.*]" to the end of every line in +in a buffer, one could do this: +@begin[programexample] +C-x ( d e l Space C-e . * C-n C-a C-x ) C-u 9 9 9 C-x e +@end[programexample] +First a keyboard macro is defined which performs the desired operation on +one line, and then the keyboard macro is invoked with a large prefix +argument. The keyboard macro will not actually execute that many times; +when the end of the buffer is reached the @binding[C-n] will get an error +and abort the execution. + + +@section[Binding Keys] +@index[key bindings] +@label[binding-keys] + +@defcom[com "Bind Key"] +This command prompts for a command, a key and a kind of binding to make, +and then makes the specified binding. The following kinds of bindings are +allowed: +@begin[description] +@i[buffer]@\Prompts for a buffer and then makes a key binding which is +only present when that buffer is the current buffer. + +@i[mode]@\Prompts for the name of a mode and then makes a key binding which +is only in present when that mode is active in the current buffer. + +@i[global]@\Makes a global key binding which is in effect when there is +no applicable mode or buffer key binding. This is the default. +@end[description] +@enddefcom + +@defcom[com "Delete Key Binding"] +This command prompts for a key binding the same way that @hid[Bind Key] +does and makes the specified binding go away. +@enddefcom + +@section[Hemlock Variables] + +@label[vars]@index[variables, hemlock]@index[hemlock variables]A number +of commands use @hemlock variables as flags to control their behavior. Often +you can get a command to do what you want by setting a variable. Generally the +default value for a variable is chosen to be the safest value for novice users. + +@defcom[com "Set Variable"] +This command prompts for the name of a @hemlock variable and an expression, +then sets the current value of the variable to the result of the evaluation of +the expression. +@enddefcom + + +@defcom[com "Defhvar"] +Like @hid[Set Variable], this command prompts for the name of a @hemlock +variable and an expression. Like @hid[Bind Key], this command prompts for a +place: mode, buffer or local. The result of evaluating the expression is +defined to be the value of the named variable in the specified place. + +This command is most useful for making mode or buffer local bindings of +variables. Redefining a variable in a mode or buffer will create a +customization that takes effect only when in that mode or buffer. + +Unlike @hid[Set Variable], the variable name need not be the name of an +existing variable: new variables may be defined. If the variable is already +defined in the current environment, @hemlock copies the documentation and hooks +to the new definition. +@enddefcom + + +@section[Init Files] +@index[init files] +@hemlock customizations are normally put in @hemlock@comment{}'s initialization file, +"@f[hemlock-init.lisp]", or when compiled "@f[hemlock-init.fasl]". When +starting up Lisp, use the @f[-hinit] switch to indicate a particular file. The +contents of the init file must be Lisp code, but there is a fairly +straightforward correspondence between the basic customization commands and the +equivalent Lisp code. Rather than describe these functions in depth here, a +brief example follows: +@begin[programexample] +;;; -*- Mode: Lisp; Package: Hemlock -*- + +;;; It is necessary to specify that the customizations go in +;;; the hemlock package. +(in-package 'hemlock) + +;;; Bind @hid[Kill Previous Word] to @binding[M-h]. +(bind-key "Kill Previous Word" '#(#\m-h)) +;;; +;;; Bind @hid[Extract List] to @binding[C-M-?] when in @hid[Lisp] mode. +(bind-key "Extract List" '#(#\c-m-?) :mode "Lisp") + +;;; Make @binding[C-w] globally unbound. +(delete-key-binding '#(#\c-w)) + +;;; Make string searches case-sensitive. +(setv string-search-ignore-case nil) +;;; +;;; Make "Query Replace" replace strings literally. +(setv case-replace nil) +@end[programexample] +For a detailed description of these functions, see the @i[Hemlock Command +Implementor's Manual]. Index: /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock.system =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock.system (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock.system (revision 8058) @@ -0,0 +1,162 @@ +;; -*- Mode: Lisp; -*- + +(defpackage #:hemlock-system + (:use #:cl) + (:export #:*hemlock-base-directory*)) + +(in-package #:hemlock-system) + + +(pushnew :command-bits *features*) +(pushnew :buffered-lines *features*) + +(defparameter *hemlock-base-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defparameter *binary-pathname* + (make-pathname :directory + (append (pathname-directory *hemlock-base-directory*) + (list "bin" + #+CLISP "clisp" + #+CMU "cmu" + #+EXCL "acl" + #+SBCL "sbcl" + #-(or CLISP CMU EXCL SBCL) + (string-downcase (lisp-implementation-type)))) + :defaults *hemlock-base-directory*)) + +(mk:defsystem :hemlock + :source-pathname #.(make-pathname :directory + (append (pathname-directory *hemlock-base-directory*) + (list "src")) + :defaults *hemlock-base-directory*) + :source-extension "lisp" + :binary-pathname #.*binary-pathname* + ;; ehem .. + :initially-do + (progn + ;; try to load clx + (unless (ignore-errors (fboundp (find-symbol "OPEN-DISPLAY" "XLIB"))) + (ignore-errors (require :clx)) + (ignore-errors (require :cmucl-clx))) + (unless (ignore-errors (fboundp (find-symbol "OPEN-DISPLAY" "XLIB"))) + (error "Please provide me with CLX.")) + ;; Create binary pathnames + (ensure-directories-exist *binary-pathname*) + (dolist (subdir '("tty" "wire")) + (ensure-directories-exist (merge-pathnames (make-pathname :directory (list :relative subdir)) + *binary-pathname*) + :verbose t))) + :components + ("package" + + ;; Lisp implementation specific stuff goes into one of the next + ;; two files. + "lispdep" + "hemlock-ext" + + "decls" ;early declarations of functions and stuff + + "struct" + ;; "struct-ed" + "charmacs" + "key-event" + "keysym-defs" + + "rompsite" + + "input" + "macros" + "line" + "ring" + "vars" + "interp" + "syntax" + "htext1" + "buffer" + "htext2" + "htext3" + "htext4" + "files" + "search1" + "search2" + "table" + #+clx + "hunk-draw" + "window" + "screen" + "winimage" + "linimage" + "display" + #+clx + "bit-display" + + "tty/termcap" + ;"tty-disp-rt" + ;"tty-display" + "pop-up-stream" + "bit-screen" + "tty/tty-screen" + "cursor" + "font" + "streams" +; "hacks" + "main" + "echo" + "echocoms" + "command" + "indent" +;; moved "comments" + "morecoms" + "undo" + "killcoms" + "searchcoms" + "filecoms" + "doccoms" + "srccom" + "group" + "fill" + "text" + "lispmode" +;; "ts-buf" +;; "ts-stream" +;; "eval-server" + "lispbuf" +;; "lispeval" +;; "spell-rt" +;; "spell-corr" +;; "spell-aug" +;; "spellcoms" + + "comments" + "overwrite" + "abbrev" + "icom" + "kbdmac" + "defsyn" + #+why + "scribe" + #+what + "pascal" + #+who + "dylan" + "edit-defs" + "auto-save" + "register" + "xcoms" +;; "unixcoms" +;; "mh" + "highlight" +;; "dired" +;; "diredcoms" + "bufed" + "lisp-lib" + "completion" +;; "shell" +;; "debug" +;; "netnews" +;; "rcs" + "bindings" + "bindings-gb" + )) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock11.cursor =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock11.cursor (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock11.cursor (revision 8058) @@ -0,0 +1,8 @@ +#define noname_width 16 +#define noname_height 16 +#define noname_x_hot 3 +#define noname_y_hot 1 +static char noname_bits[] = { + 0x00,0x00,0x08,0x00,0x18,0x00,0x38,0x00,0x78,0x00,0xf8,0x00,0xf8,0x01,0xf8, + 0x03,0xf8,0x07,0xf8,0x00,0xd8,0x00,0x88,0x01,0x80,0x01,0x00,0x03,0x00,0x03, + 0x00,0x00}; Index: /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock11.mask =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock11.mask (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/hemlock11.mask (revision 8058) @@ -0,0 +1,6 @@ +#define noname_width 16 +#define noname_height 16 +static char noname_bits[] = { + 0x0c,0x00,0x1c,0x00,0x3c,0x00,0x7c,0x00,0xfc,0x00,0xfc,0x01,0xfc,0x03,0xfc, + 0x07,0xfc,0x0f,0xfc,0x0f,0xfc,0x01,0xdc,0x03,0xcc,0x03,0x80,0x07,0x80,0x07, + 0x00,0x03}; Index: /branches/experimentation/later/source/cocoa-ide/hemlock/maint/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/maint/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/maint/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/maint/publish =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/maint/publish (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/maint/publish (revision 8058) @@ -0,0 +1,18 @@ +#! /bin/sh + +now=`date --iso` +tempdir=/tmp/hemlock-publish/ +rm -rf $tempdir +mkdir $tempdir +cd $tempdir ; +cvs -d :pserver:gilbert@localhost:/hemlock export -D "`date`" -d hemlock-$now hemlock ; +tar zcvf hemlock-$now.tar.gz hemlock-$now + +sed -e "s/%%DATE%%/$now/g" < hemlock-$now/website/index.html.in > index.html + +scp hemlock-$now.tar.gz unk6@rzstud1.rz.uni-karlsruhe.de:.public_html/export/ +scp index.html unk6@rzstud1.rz.uni-karlsruhe.de:.public_html/hemlock/ + +ssh -l unk6 rzstud1.rz.uni-karlsruhe.de chmod a+r .public_html/export/hemlock-$now.tar.gz .public_html/hemlock/index.html + +# $Id$ Index: /branches/experimentation/later/source/cocoa-ide/hemlock/resources/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/resources/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/resources/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/resources/XKeysymDB =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/resources/XKeysymDB (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/resources/XKeysymDB (revision 8058) @@ -0,0 +1,159 @@ +! $XConsortium: XKeysymDB,v 1.2 91/06/18 13:43:07 rws Exp $ + +hpmute_acute :100000A8 +hpmute_grave :100000A9 +hpmute_asciicircum :100000AA +hpmute_diaeresis :100000AB +hpmute_asciitilde :100000AC +hplira :100000AF +hpguilder :100000BE +hpYdiaeresis :100000EE +hpIO :100000EE +hplongminus :100000F6 +hpblock :100000FC +apLineDel :1000FF00 +apCharDel :1000FF01 +apCopy :1000FF02 +apCut :1000FF03 +apPaste :1000FF04 +apMove :1000FF05 +apGrow :1000FF06 +apCmd :1000FF07 +apShell :1000FF08 +apLeftBar :1000FF09 +apRightBar :1000FF0A +apLeftBox :1000FF0B +apRightBox :1000FF0C +apUpBox :1000FF0D +apDownBox :1000FF0E +apPop :1000FF0F +apRead :1000FF10 +apEdit :1000FF11 +apSave :1000FF12 +apExit :1000FF13 +apRepeat :1000FF14 +hpModelock1 :1000FF48 +hpModelock2 :1000FF49 +hpReset :1000FF6C +hpSystem :1000FF6D +hpUser :1000FF6E +hpClearLine :1000FF6F +hpInsertLine :1000FF70 +hpDeleteLine :1000FF71 +hpInsertChar :1000FF72 +hpDeleteChar :1000FF73 +hpBackTab :1000FF74 +hpKP_BackTab :1000FF75 +apKP_parenleft :1000FFA8 +apKP_parenright :1000FFA9 + +I2ND_FUNC_L :10004001 +I2ND_FUNC_R :10004002 +IREMOVE :10004003 +IREPEAT :10004004 +IA1 :10004101 +IA2 :10004102 +IA3 :10004103 +IA4 :10004104 +IA5 :10004105 +IA6 :10004106 +IA7 :10004107 +IA8 :10004108 +IA9 :10004109 +IA10 :1000410A +IA11 :1000410B +IA12 :1000410C +IA13 :1000410D +IA14 :1000410E +IA15 :1000410F +IB1 :10004201 +IB2 :10004202 +IB3 :10004203 +IB4 :10004204 +IB5 :10004205 +IB6 :10004206 +IB7 :10004207 +IB8 :10004208 +IB9 :10004209 +IB10 :1000420B +IB11 :1000420B +IB12 :1000420C +IB13 :1000420D +IB14 :1000420E +IB15 :1000420F +IB16 :10004210 + +DRemove :1000FF00 +Dring_accent :1000FEB0 +Dcircumflex_accent :1000FE5E +Dcedilla_accent :1000FE2C +Dacute_accent :1000FE27 +Dgrave_accent :1000FE60 +Dtilde :1000FE7E +Ddiaeresis :1000FE22 + +osfCopy :1004FF02 +osfCut :1004FF03 +osfPaste :1004FF04 +osfBackTab :1004FF07 +osfBackSpace :1004FF08 +osfClear :1004FF0B +osfEscape :1004FF1B +osfAddMode :1004FF31 +osfPrimaryPaste :1004FF32 +osfQuickPaste :1004FF33 +osfPageLeft :1004FF40 +osfPageUp :1004FF41 +osfPageDown :1004FF42 +osfPageRight :1004FF43 +osfActivate :1004FF44 +osfMenuBar :1004FF45 +osfLeft :1004FF51 +osfUp :1004FF52 +osfRight :1004FF53 +osfDown :1004FF54 +osfEndLine :1004FF57 +osfBeginLine :1004FF58 +osfEndData :1004FF59 +osfBeginData :1004FF5A +osfPrevMenu :1004FF5B +osfNextMenu :1004FF5C +osfPrevField :1004FF5D +osfNextField :1004FF5E +osfSelect :1004FF60 +osfInsert :1004FF63 +osfUndo :1004FF65 +osfMenu :1004FF67 +osfCancel :1004FF69 +osfHelp :1004FF6A +osfSelectAll :1004FF71 +osfDeselectAll :1004FF72 +osfReselect :1004FF73 +osfExtend :1004FF74 +osfRestore :1004FF78 +osfDelete :1004FFFF + +SunFA_Grave :1005FF00 +SunFA_Circum :1005FF01 +SunFA_Tilde :1005FF02 +SunF36 :1005FF10 +SunF37 :1005FF11 +SunSys_Req :1005FF60 +SunProps :1005FF70 +SunFront :1005FF71 +SunCopy :1005FF72 +SunOpen :1005FF73 +SunPaste :1005FF74 +SunCut :1005FF75 + +SunCompose :FF20 +SunPageUp :FF55 +SunPageDown :FF56 +SunPrint_Screen :FF61 +SunUndo :FF65 +SunAgain :FF66 +SunFind :FF68 +SunStop :FF69 +SunAltGraph :FF7E + +WYSetup :1006FF00 Index: /branches/experimentation/later/source/cocoa-ide/hemlock/resources/mh-scan =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/resources/mh-scan (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/resources/mh-scan (revision 8058) @@ -0,0 +1,5 @@ +%4(putnumf(msg))%<(cur)+%| %>%<{replied}A%| %> \ +%02(putnumf(mday{date}))-%(putstr(month{date}))%<{date} %|*%>\ +%5(size) \ +%<(mymbox{from})To:%14(putstrf(friendly{to}))%|%17(putstrf(friendly{from}))%> \ +%{subject}%<{body} <<%{body}%> Index: /branches/experimentation/later/source/cocoa-ide/hemlock/resources/spell-dictionary.text =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/resources/spell-dictionary.text (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/resources/spell-dictionary.text (revision 8058) @@ -0,0 +1,15505 @@ +AAAI +ABACK +ABAFT +ABANDON/D/G/S +ABANDONMENT +ABASE/D/G/S +ABASEMENT/S +ABASH/D/G/S +ABATE/D/R/G/S +ABATEMENT/S +ABBE +ABBEY/M/S +ABBOT/M/S +ABBREVIATE/D/G/N/X/S +ABDOMEN/M/S +ABDOMINAL +ABDUCT/D/S +ABDUCTION/M/S +ABDUCTOR/M/S +ABED +ABERRANT +ABERRATION/S +ABET/S +ABETTED +ABETTER +ABETTING +ABETTOR +ABEYANCE +ABHOR/S +ABHORRED +ABHORRENT +ABHORRER +ABHORRING +ABIDE/D/G/S +ABILITY/M/S +ABJECT/P/Y +ABJECTION/S +ABJURE/D/G/S +ABLATE/D/G/N/V/S +ABLAZE +ABLE/T/R +ABLUTE +ABLY +ABNORMAL/Y +ABNORMALITY/S +ABOARD +ABODE/M/S +ABOLISH/D/R/Z/G/S +ABOLISHMENT/M/S +ABOLITION +ABOLITIONIST/S +ABOMINABLE +ABORIGINAL +ABORIGINE/M/S +ABORT/D/G/V/S +ABORTION/M/S +ABORTIVE/Y +ABOUND/D/G/S +ABOUT +ABOVE +ABOVEGROUND +ABRADE/D/G/S +ABRASION/M/S +ABREACTION/S +ABREAST +ABRIDGE/D/G/S +ABRIDGMENT +ABROAD +ABROGATE/D/G/S +ABRUPT/P/Y +ABSCESS/D/S +ABSCISSA/M/S +ABSCOND/D/G/S +ABSENCE/M/S +ABSENT/D/G/Y/S +ABSENTEE/M/S +ABSENTEEISM +ABSENTIA +ABSENTMINDED +ABSINTHE +ABSOLUTE/P/N/Y/S +ABSOLVE/D/G/S +ABSORB/D/R/G/S +ABSORBENCY +ABSORBENT +ABSORPTION/M/S +ABSORPTIVE +ABSTAIN/D/R/G/S +ABSTENTION/S +ABSTINENCE +ABSTRACT/P/D/G/Y/S +ABSTRACTION/M/S +ABSTRACTIONISM +ABSTRACTIONIST +ABSTRACTOR/M/S +ABSTRUSE/P +ABSURD/Y +ABSURDITY/M/S +ABUNDANCE +ABUNDANT/Y +ABUSE/D/G/V/S +ABUT/S +ABUTMENT +ABUTTED +ABUTTER/M/S +ABUTTING +ABYSMAL/Y +ABYSS/M/S +ACACIA +ACADEMIA +ACADEMIC/S +ACADEMICALLY +ACADEMY/M/S +ACCEDE/D/S +ACCELERATE/D/G/N/X/S +ACCELERATOR/S +ACCELEROMETER/M/S +ACCENT/D/G/S +ACCENTUAL +ACCENTUATE/D/G/N/S +ACCEPT/D/R/Z/G/S +ACCEPTABILITY +ACCEPTABLE +ACCEPTABLY +ACCEPTANCE/M/S +ACCEPTOR/M/S +ACCESS/D/G/S +ACCESSIBILITY +ACCESSIBLE +ACCESSIBLY +ACCESSION/M/S +ACCESSOR/M/S +ACCESSORY/M/S +ACCIDENT/M/S +ACCIDENTAL/Y +ACCLAIM/D/G/S +ACCLAMATION +ACCLIMATE/D/G/S +ACCLIMATIZATION +ACCLIMATIZED +ACCOLADE/S +ACCOMMODATE/D/G/N/X/S +ACCOMPANIMENT/M/S +ACCOMPANIST/M/S +ACCOMPANY/D/G/S +ACCOMPLICE/S +ACCOMPLISH/D/R/Z/G/S +ACCOMPLISHMENT/M/S +ACCORD/D/R/Z/G/S +ACCORDANCE +ACCORDINGLY +ACCORDION/M/S +ACCOST/D/G/S +ACCOUNT/D/G/S +ACCOUNTABILITY +ACCOUNTABLE +ACCOUNTABLY +ACCOUNTANCY +ACCOUNTANT/M/S +ACCOUTREMENT/S +ACCREDIT/D +ACCREDITATION/S +ACCRETION/M/S +ACCRUE/D/G/S +ACCULTURATE/D/G/N/S +ACCUMULATE/D/G/N/X/S +ACCUMULATOR/M/S +ACCURACY/S +ACCURATE/P/Y +ACCURSED +ACCUSAL +ACCUSATION/M/S +ACCUSATIVE +ACCUSE/D/R/G/S +ACCUSINGLY +ACCUSTOM/D/G/S +ACE/M/S +ACETATE +ACETONE +ACETYLENE +ACHE/D/G/S +ACHIEVABLE +ACHIEVE/D/R/Z/G/S +ACHIEVEMENT/M/S +ACHILLES +ACID/Y/S +ACIDIC +ACIDITY/S +ACIDULOUS +ACKNOWLEDGE/D/R/Z/G/S +ACKNOWLEDGMENT/M/S +ACM +ACME +ACNE +ACOLYTE/S +ACORN/M/S +ACOUSTIC/S +ACOUSTICAL/Y +ACOUSTICIAN +ACQUAINT/D/G/S +ACQUAINTANCE/M/S +ACQUIESCE/D/G/S +ACQUIESCENCE +ACQUIRABLE +ACQUIRE/D/G/S +ACQUISITION/M/S +ACQUISITIVENESS +ACQUIT/S +ACQUITTAL +ACQUITTED +ACQUITTER +ACQUITTING +ACRE/M/S +ACREAGE +ACRID +ACRIMONIOUS +ACRIMONY +ACROBAT/M/S +ACROBATIC/S +ACRONYM/M/S +ACROPOLIS +ACROSS +ACRYLIC +ACT/D/G/V/S +ACTINIUM +ACTINOMETER/S +ACTION/M/S +ACTIVATE/D/G/N/X/S +ACTIVATOR/M/S +ACTIVELY +ACTIVISM +ACTIVIST/M/S +ACTIVITY/M/S +ACTOR/M/S +ACTRESS/M/S +ACTUAL/Y/S +ACTUALITY/S +ACTUALIZATION +ACTUARIAL/Y +ACTUATE/D/G/S +ACTUATOR/M/S +ACUITY +ACUMEN +ACUTE/P/Y +ACYCLIC +ACYCLICALLY +AD +ADAGE/S +ADAGIO/S +ADAMANT/Y +ADAPT/D/R/Z/G/V/S +ADAPTABILITY +ADAPTABLE +ADAPTATION/M/S +ADAPTIVELY +ADAPTOR/S +ADD/D/R/Z/G/S +ADDENDA +ADDENDUM +ADDICT/D/G/S +ADDICTION/M/S +ADDISON +ADDITION/M/S +ADDITIONAL/Y +ADDITIVE/M/S +ADDITIVITY +ADDRESS/D/R/Z/G/S +ADDRESSABILITY +ADDRESSABLE +ADDRESSEE/M/S +ADDUCE/D/G/S +ADDUCIBLE +ADDUCT/D/G/S +ADDUCTION +ADDUCTOR +ADEPT +ADEQUACY/S +ADEQUATE/Y +ADHERE/D/R/Z/G/S +ADHERENCE +ADHERENT/M/S +ADHESION/S +ADHESIVE/M/S +ADIABATIC +ADIABATICALLY +ADIEU +ADJACENCY +ADJACENT +ADJECTIVE/M/S +ADJOIN/D/G/S +ADJOURN/D/G/S +ADJOURNMENT +ADJUDGE/D/G/S +ADJUDICATE/D/G/S +ADJUDICATION/M/S +ADJUNCT/M/S +ADJURE/D/G/S +ADJUST/D/R/Z/G/S +ADJUSTABLE +ADJUSTABLY +ADJUSTMENT/M/S +ADJUSTOR/M/S +ADJUTANT/S +ADMINISTER/D/G/J/S +ADMINISTRATION/M/S +ADMINISTRATIVE/Y +ADMINISTRATOR/M/S +ADMIRABLE +ADMIRABLY +ADMIRAL/M/S +ADMIRALTY +ADMIRATION/S +ADMIRE/D/R/Z/G/S +ADMIRING/Y +ADMISSIBILITY +ADMISSIBLE +ADMISSION/M/S +ADMIT/S +ADMITTANCE +ADMITTED/Y +ADMITTER/S +ADMITTING +ADMIX/D/S +ADMIXTURE +ADMONISH/D/G/S +ADMONISHMENT/M/S +ADMONITION/M/S +ADO +ADOBE +ADOLESCENCE +ADOLESCENT/M/S +ADOPT/D/R/Z/G/V/S +ADOPTION/M/S +ADORABLE +ADORATION +ADORE/D/S +ADORN/D/S +ADORNMENT/M/S +ADRENAL +ADRENALINE +ADRIFT +ADROIT/P +ADS +ADSORB/D/G/S +ADSORPTION +ADULATION +ADULT/M/S +ADULTERATE/D/G/S +ADULTERER/M/S +ADULTEROUS/Y +ADULTERY +ADULTHOOD +ADUMBRATE/D/G/S +ADVANCE/D/G/S +ADVANCEMENT/M/S +ADVANTAGE/D/S +ADVANTAGEOUS/Y +ADVENT +ADVENTIST/S +ADVENTITIOUS +ADVENTURE/D/R/Z/G/S +ADVENTUROUS +ADVERB/M/S +ADVERBIAL +ADVERSARY/M/S +ADVERSE/Y +ADVERSITY/S +ADVERTISE/D/R/Z/G/S +ADVERTISEMENT/M/S +ADVICE +ADVISABILITY +ADVISABLE +ADVISABLY +ADVISE/D/R/Z/G/S +ADVISEDLY +ADVISEE/M/S +ADVISEMENT/S +ADVISOR/M/S +ADVISORY +ADVOCACY +ADVOCATE/D/G/S +AEGIS +AERATE/D/G/N/S +AERATOR/S +AERIAL/M/S +AEROACOUSTIC +AEROBIC/S +AERODYNAMIC/S +AERONAUTIC/S +AERONAUTICAL +AEROSOL/S +AEROSOLIZE +AEROSPACE +AESTHETIC/M/S +AESTHETICALLY +AFAR +AFFABLE +AFFAIR/M/S +AFFECT/D/G/V/S +AFFECTATION/M/S +AFFECTINGLY +AFFECTION/M/S +AFFECTIONATE/Y +AFFECTOR +AFFERENT +AFFIANCED +AFFIDAVIT/M/S +AFFILIATE/D/G/N/X/S +AFFINITY/M/S +AFFIRM/D/G/S +AFFIRMATION/M/S +AFFIRMATIVE/Y +AFFIX/D/G/S +AFFLICT/D/G/V/S +AFFLICTION/M/S +AFFLUENCE +AFFLUENT +AFFORD/D/G/S +AFFORDABLE +AFFRICATE/S +AFFRIGHT +AFFRONT/D/G/S +AFGHAN/S +AFGHANISTAN +AFICIONADO +AFIELD +AFIRE +AFLAME +AFLOAT +AFOOT +AFORE +AFOREMENTIONED +AFORESAID +AFORETHOUGHT +AFOSR +AFOUL +AFRAID +AFRESH +AFRICA +AFRICAN/S +AFT/R +AFTEREFFECT +AFTERMATH +AFTERMOST +AFTERNOON/M/S +AFTERSHOCK/S +AFTERTHOUGHT/S +AFTERWARD/S +AGAIN +AGAINST +AGAPE +AGAR +AGATE/S +AGE/D/R/Z/G/S +AGELESS +AGENCY/M/S +AGENDA/M/S +AGENT/M/S +AGGLOMERATE/D/N/S +AGGLUTINATE/D/G/N/S +AGGLUTININ/S +AGGRAVATE/D/N/S +AGGREGATE/D/G/N/X/Y/S +AGGRESSION/M/S +AGGRESSIVE/P/Y +AGGRESSOR/S +AGGRIEVE/D/G/S +AGHAST +AGILE/Y +AGILITY +AGITATE/D/G/N/X/S +AGITATOR/M/S +AGLEAM +AGLOW +AGNOSTIC/M/S +AGO +AGOG +AGONIZE/D/G/S +AGONY/S +AGRARIAN +AGREE/D/R/Z/S +AGREEABLE/P +AGREEABLY +AGREEING +AGREEMENT/M/S +AGRICULTURAL/Y +AGRICULTURE +AGUE +AH +AHEAD +AI +AID/D/G/S +AIDE/D/G/S +AIL/G +AILERON/S +AILMENT/M/S +AIM/D/R/Z/G/S +AIMLESS/Y +AIR/D/R/Z/G/J/S +AIRBAG/S +AIRBORNE +AIRCRAFT +AIRDROP/S +AIREDALE +AIRFIELD/M/S +AIRFLOW +AIRFOIL/S +AIRFRAME/S +AIRILY +AIRLESS +AIRLIFT/M/S +AIRLINE/R/S +AIRLOCK/M/S +AIRMAIL/S +AIRMAN +AIRMEN +AIRPLANE/M/S +AIRPORT/M/S +AIRSHIP/M/S +AIRSPACE +AIRSPEED +AIRSTRIP/M/S +AIRWAY/M/S +AIRY +AISLE +AJAR +AKIMBO +AKIN +AL/M +ALABAMA +ALABAMIAN +ALABASTER +ALACRITY +ALARM/D/G/S +ALARMINGLY +ALARMIST +ALAS +ALASKA +ALBA +ALBACORE +ALBANIA +ALBANIAN/S +ALBEIT +ALBUM/S +ALBUMIN +ALCHEMY +ALCIBIADES +ALCOHOL/M/S +ALCOHOLIC/M/S +ALCOHOLISM +ALCOVE/M/S +ALDEN +ALDER +ALDERMAN/M +ALDERMEN +ALE/V +ALEE +ALERT/P/D/R/Z/G/Y/S +ALERTEDLY +ALEXANDER/M +ALFALFA +ALFRED/M +ALFRESCO +ALGA +ALGAE +ALGAECIDE +ALGEBRA/M/S +ALGEBRAIC +ALGEBRAICALLY +ALGERIA +ALGERIAN +ALGINATE +ALGOL +ALGORITHM/M/S +ALGORITHMIC +ALGORITHMICALLY +ALIAS/D/G/S +ALIBI/M/S +ALIEN/M/S +ALIENATE/D/G/N/S +ALIGHT +ALIGN/D/G/S +ALIGNMENT/S +ALIKE +ALIMENT/S +ALIMONY +ALKALI/M/S +ALKALINE +ALKALOID/M/S +ALKYL +ALL +ALLAH/M +ALLAY/D/G/S +ALLEGATION/M/S +ALLEGE/D/G/S +ALLEGEDLY +ALLEGIANCE/M/S +ALLEGORIC +ALLEGORICAL/Y +ALLEGORY/M/S +ALLEGRETTO/M/S +ALLEGRO/M/S +ALLELE/S +ALLEMANDE +ALLEN/M +ALLERGIC +ALLERGY/M/S +ALLEVIATE/D/R/Z/G/N/S +ALLEY/M/S +ALLEYWAY/M/S +ALLIANCE/M/S +ALLIGATOR/M/S +ALLITERATION/M/S +ALLITERATIVE +ALLOCATE/D/G/N/X/S +ALLOCATOR/M/S +ALLOPHONE/S +ALLOPHONIC +ALLOT/S +ALLOTMENT/M/S +ALLOTTED +ALLOTTER +ALLOTTING +ALLOW/D/G/S +ALLOWABLE +ALLOWABLY +ALLOWANCE/M/S +ALLOY/M/S +ALLUDE/D/G/S +ALLURE/G +ALLUREMENT +ALLUSION/M/S +ALLUSIVE/P +ALLY/D/G/S +ALMA +ALMANAC/M/S +ALMIGHTY +ALMOND/M/S +ALMONER +ALMOST +ALMS +ALMSMAN +ALNICO +ALOE/S +ALOFT +ALOHA +ALONE/P +ALONG +ALONGSIDE +ALOOF/P +ALOUD +ALPHA +ALPHABET/M/S +ALPHABETIC/S +ALPHABETICAL/Y +ALPHABETIZE/D/G/S +ALPHANUMERIC +ALPINE +ALPS +ALREADY +ALSO +ALTAR/M/S +ALTER/D/R/Z/G/S +ALTERABLE +ALTERATION/M/S +ALTERCATION/M/S +ALTERNATE/D/G/N/X/V/Y/S +ALTERNATIVE/Y/S +ALTERNATOR/M/S +ALTHOUGH +ALTITUDE/S +ALTMODE +ALTO/M/S +ALTOGETHER +ALTRUISM +ALTRUIST +ALTRUISTIC +ALTRUISTICALLY +ALUM +ALUMINUM +ALUMNA/M +ALUMNAE +ALUMNI +ALUMNUS +ALUNDUM +ALVEOLAR +ALVEOLI +ALVEOLUS +ALWAYS +ALZHEIMER/M +AM/N +AMAIN +AMALGAM/M/S +AMALGAMATE/D/G/N/S +AMANUENSIS +AMASS/D/G/S +AMATEUR/M/S +AMATEURISH/P +AMATEURISM +AMATORY +AMAZE/D/R/Z/G/S +AMAZEDLY +AMAZEMENT +AMAZING/Y +AMAZON/M/S +AMBASSADOR/M/S +AMBER +AMBIANCE +AMBIDEXTROUS/Y +AMBIENT +AMBIGUITY/M/S +AMBIGUOUS/Y +AMBITION/M/S +AMBITIOUS/Y +AMBIVALENCE +AMBIVALENT/Y +AMBLE/D/R/G/S +AMBROSIAL +AMBULANCE/M/S +AMBULATORY +AMBUSCADE +AMBUSH/D/S +AMDAHL/M +AMELIA +AMELIORATE/D/G +AMENABLE +AMEND/D/G/S +AMENDMENT/M/S +AMENITY/S +AMENORRHEA +AMERICA/M/S +AMERICAN/M/S +AMERICANA +AMERICIUM +AMIABLE +AMICABLE +AMICABLY +AMID +AMIDE +AMIDST +AMIGO +AMINO +AMISS +AMITY +AMMO +AMMONIA +AMMONIAC +AMMONIUM +AMMUNITION +AMNESTY +AMOEBA/M/S +AMOK +AMONG +AMONGST +AMORAL +AMORALITY +AMORIST +AMOROUS +AMORPHOUS/Y +AMORTIZE/D/G/S +AMOUNT/D/R/Z/G/S +AMOUR +AMP/Y/S +AMPERE/S +AMPERSAND/M/S +AMPHETAMINE/S +AMPHIBIAN/M/S +AMPHIBIOUS/Y +AMPHIBOLOGY +AMPHITHEATER/M/S +AMPLE +AMPLIFY/D/R/Z/G/N/S +AMPLITUDE/M/S +AMPOULE/M/S +AMPUTATE/D/G/S +AMSTERDAM +AMTRAK +AMULET/S +AMUSE/D/R/Z/G/S +AMUSEDLY +AMUSEMENT/M/S +AMUSINGLY +AMYL +AN +ANABAPTIST/M/S +ANACHRONISM/M/S +ANACHRONISTICALLY +ANACONDA/S +ANAEROBIC +ANAESTHESIA +ANAGRAM/M/S +ANAL +ANALOG +ANALOGICAL +ANALOGOUS/Y +ANALOGUE/M/S +ANALOGY/M/S +ANALYSES +ANALYSIS +ANALYST/M/S +ANALYTIC +ANALYTICAL/Y +ANALYTICITY/S +ANALYZABLE +ANALYZE/D/R/Z/G/S +ANAPHORA +ANAPHORIC +ANAPHORICALLY +ANAPLASMOSIS +ANARCHIC +ANARCHICAL +ANARCHIST/M/S +ANARCHY +ANASTOMOSES +ANASTOMOSIS +ANASTOMOTIC +ANATHEMA +ANATOMIC +ANATOMICAL/Y +ANATOMY +ANCESTOR/M/S +ANCESTRAL +ANCESTRY +ANCHOR/D/G/S +ANCHORAGE/M/S +ANCHORITE +ANCHORITISM +ANCHOVY/S +ANCIENT/Y/S +ANCILLARY +AND/Z/G +ANDERSON/M +ANDORRA +ANDREW/M +ANDY/M +ANECDOTAL +ANECDOTE/M/S +ANECHOIC +ANEMIA +ANEMIC +ANEMOMETER/M/S +ANEMOMETRY +ANEMONE +ANESTHESIA +ANESTHETIC/M/S +ANESTHETICALLY +ANESTHETIZE/D/G/S +ANEW +ANGEL/M/S +ANGELIC +ANGER/D/G/S +ANGIOGRAPHY +ANGLE/D/R/Z/G/S +ANGLICAN/S +ANGLICANISM +ANGLOPHILIA +ANGLOPHOBIA +ANGOLA +ANGRILY +ANGRY/T/R +ANGST +ANGSTROM +ANGUISH/D +ANGULAR/Y +ANHYDROUS/Y +ANILINE +ANIMAL/M/S +ANIMATE/P/D/G/N/X/Y/S +ANIMATEDLY +ANIMATOR/M/S +ANIMISM +ANIMIZED +ANIMOSITY +ANION/M/S +ANIONIC +ANISE +ANISEIKONIC +ANISOTROPIC +ANISOTROPY +ANKLE/M/S +ANNAL/S +ANNEAL/G +ANNEX/D/G/S +ANNEXATION +ANNIHILATE/D/G/N/S +ANNIVERSARY/M/S +ANNOTATE/D/G/N/X/S +ANNOUNCE/D/R/Z/G/S +ANNOUNCEMENT/M/S +ANNOY/D/G/S +ANNOYANCE/M/S +ANNOYER/S +ANNOYINGLY +ANNUAL/Y/S +ANNUITY +ANNUL/S +ANNULLED +ANNULLING +ANNULMENT/M/S +ANNUM +ANNUNCIATE/D/G/S +ANNUNCIATOR/S +ANODE/M/S +ANODIZE/D/S +ANOINT/D/G/S +ANOMALOUS/Y +ANOMALY/M/S +ANOMIC +ANOMIE +ANON +ANONYMITY +ANONYMOUS/Y +ANOREXIA +ANOTHER/M +ANSI +ANSWER/D/R/Z/G/S +ANSWERABLE +ANT/M/S +ANTAGONISM/S +ANTAGONIST/M/S +ANTAGONISTIC +ANTAGONISTICALLY +ANTAGONIZE/D/G/S +ANTARCTIC +ANTARCTICA +ANTE +ANTEATER/M/S +ANTECEDENT/M/S +ANTEDATE +ANTELOPE/M/S +ANTENNA/M/S +ANTENNAE +ANTERIOR +ANTHEM/M/S +ANTHER +ANTHOLOGY/S +ANTHONY +ANTHRACITE +ANTHROPOLOGICAL/Y +ANTHROPOLOGIST/M/S +ANTHROPOLOGY +ANTHROPOMORPHIC +ANTHROPOMORPHICALLY +ANTI +ANTIBACTERIAL +ANTIBIOTIC/S +ANTIBODY/S +ANTIC/M/S +ANTICIPATE/D/G/N/X/S +ANTICIPATORY +ANTICOAGULATION +ANTICOMPETITIVE +ANTIDISESTABLISHMENTARIANISM +ANTIDOTE/M/S +ANTIFORMANT +ANTIFUNDAMENTALIST +ANTIGEN/M/S +ANTIHISTORICAL +ANTIMICROBIAL +ANTIMONY +ANTINOMIAN +ANTINOMY +ANTIPATHY +ANTIPHONAL +ANTIPODE/M/S +ANTIQUARIAN/M/S +ANTIQUATE/D +ANTIQUE/M/S +ANTIQUITY/S +ANTIREDEPOSITION +ANTIRESONANCE +ANTIRESONATOR +ANTISEPTIC +ANTISERA +ANTISERUM +ANTISLAVERY +ANTISOCIAL +ANTISUBMARINE +ANTISYMMETRIC +ANTISYMMETRY +ANTITHESIS +ANTITHETICAL +ANTITHYROID +ANTITOXIN/M/S +ANTITRUST +ANTLER/D +ANUS +ANVIL/M/S +ANXIETY/S +ANXIOUS/Y +ANY +ANYBODY +ANYHOW +ANYMORE +ANYONE +ANYPLACE +ANYTHING +ANYTIME +ANYWAY +ANYWHERE +AORTA +APACE +APART +APARTHEID +APARTMENT/M/S +APATHETIC +APATHY +APE/D/G/S +APERIODIC +APERIODICITY +APERTURE +APEX +APHASIA +APHASIC +APHID/M/S +APHONIC +APHORISM/M/S +APHRODITE +APIARY/S +APICAL +APIECE +APISH +APLENTY +APLOMB +APOCALYPSE +APOCALYPTIC +APOCRYPHA +APOCRYPHAL +APOGEE/S +APOLLO +APOLLONIAN +APOLOGETIC +APOLOGETICALLY +APOLOGIA +APOLOGIST/M/S +APOLOGIZE/D/G/S +APOLOGY/M/S +APOSTATE +APOSTLE/M/S +APOSTOLIC +APOSTROPHE/S +APOTHECARY +APOTHEOSES +APOTHEOSIS +APPALACHIA +APPALACHIAN/S +APPALL/D/G +APPALLINGLY +APPANAGE +APPARATUS +APPAREL/D +APPARENT/Y +APPARITION/M/S +APPEAL/D/R/Z/G/S +APPEALINGLY +APPEAR/D/R/Z/G/S +APPEARANCE/S +APPEASE/D/G/S +APPEASEMENT +APPELLANT/M/S +APPELLATE +APPEND/D/R/Z/G/S +APPENDAGE/M/S +APPENDICES +APPENDICITIS +APPENDIX/M/S +APPERTAIN/S +APPETITE/M/S +APPETIZER +APPETIZING +APPLAUD/D/G/S +APPLAUSE +APPLE/M/S +APPLEJACK +APPLIANCE/M/S +APPLICABILITY +APPLICABLE +APPLICANT/M/S +APPLICATION/M/S +APPLICATIVE/Y +APPLICATOR/M/S +APPLIQUE +APPLY/D/R/Z/G/N/X/S +APPOINT/D/R/Z/G/V/S +APPOINTEE/M/S +APPOINTMENT/M/S +APPORTION/D/G/S +APPORTIONMENT/S +APPRAISAL/M/S +APPRAISE/D/R/Z/G/S +APPRAISINGLY +APPRECIABLE +APPRECIABLY +APPRECIATE/D/G/N/X/V/S +APPRECIATIVELY +APPREHEND/D +APPREHENSIBLE +APPREHENSION/M/S +APPREHENSIVE/P/Y +APPRENTICE/D/S +APPRENTICESHIP +APPRISE/D/G/S +APPROACH/D/R/Z/G/S +APPROACHABILITY +APPROACHABLE +APPROBATE/N +APPROPRIATE/P/D/G/N/X/Y/S +APPROPRIATOR/M/S +APPROVAL/M/S +APPROVE/D/R/Z/G/S +APPROVINGLY +APPROXIMATE/D/G/N/X/Y/S +APPURTENANCE/S +APRICOT/M/S +APRIL +APRON/M/S +APROPOS +APSE +APSIS +APT/P/Y +APTITUDE/S +AQUA +AQUARIA +AQUARIUM +AQUARIUS +AQUATIC +AQUEDUCT/M/S +AQUEOUS +AQUIFER/S +ARAB/M/S +ARABESQUE +ARABIA +ARABIAN/S +ARABIC +ARABLE +ARACHNID/M/S +ARBITER/M/S +ARBITRARILY +ARBITRARY/P +ARBITRATE/D/G/N/S +ARBITRATOR/M/S +ARBOR/M/S +ARBOREAL +ARC/D/G/S +ARCADE/D/M/S +ARCANE +ARCH/D/R/Z/G/Y/S +ARCHAEOLOGICAL +ARCHAEOLOGIST/M/S +ARCHAEOLOGY +ARCHAIC/P +ARCHAICALLY +ARCHAISM +ARCHAIZE +ARCHANGEL/M/S +ARCHBISHOP +ARCHDIOCESE/S +ARCHENEMY +ARCHEOLOGICAL +ARCHEOLOGIST +ARCHEOLOGY +ARCHERY +ARCHETYPE +ARCHFOOL +ARCHIPELAGO +ARCHIPELAGOES +ARCHITECT/M/S +ARCHITECTONIC +ARCHITECTURAL/Y +ARCHITECTURE/M/S +ARCHIVAL +ARCHIVE/D/R/Z/G/S +ARCHIVIST +ARCLIKE +ARCTIC +ARDENT/Y +ARDOR +ARDUOUS/P/Y +ARE +AREA/M/S +AREN'T +ARENA/M/S +ARGENTINA +ARGO/S +ARGON +ARGONAUT/S +ARGOT +ARGUABLE +ARGUABLY +ARGUE/D/R/Z/G/S +ARGUMENT/M/S +ARGUMENTATION +ARGUMENTATIVE +ARIANISM +ARIANIST/S +ARID +ARIDITY +ARIES +ARIGHT +ARISE/R/G/J/S +ARISEN +ARISTOCRACY +ARISTOCRAT/M/S +ARISTOCRATIC +ARISTOCRATICALLY +ARISTOTELIAN +ARISTOTLE +ARITHMETIC/S +ARITHMETICAL/Y +ARITHMETIZE/D/S +ARIZONA +ARK +ARKANSAS +ARM/D/R/Z/G/S +ARMADILLO/S +ARMAGEDDON +ARMAMENT/M/S +ARMCHAIR/M/S +ARMENIAN +ARMFUL +ARMHOLE +ARMISTICE +ARMLOAD +ARMOR/D/R +ARMORY +ARMOUR +ARMPIT/M/S +ARMSTRONG +ARMY/M/S +AROMA/S +AROMATIC +AROSE +AROUND +AROUSAL +AROUSE/D/G/S +ARPA +ARPANET +ARPEGGIO/M/S +ARRACK +ARRAIGN/D/G/S +ARRAIGNMENT/M/S +ARRANGE/D/R/Z/G/S +ARRANGEMENT/M/S +ARRANT +ARRAY/D/S +ARREARS +ARREST/D/R/Z/G/S +ARRESTINGLY +ARRESTOR/M/S +ARRIVAL/M/S +ARRIVE/D/G/S +ARROGANCE +ARROGANT/Y +ARROGATE/D/G/N/S +ARROW/D/S +ARROWHEAD/M/S +ARROYO/S +ARSENAL/M/S +ARSENIC +ARSINE +ARSON +ART/M/S +ARTEMIS +ARTERIAL +ARTERIOLAR +ARTERIOLE/M/S +ARTERIOSCLEROSIS +ARTERY/M/S +ARTFUL/P/Y +ARTHOGRAM +ARTHRITIS +ARTHROPOD/M/S +ARTICHOKE/M/S +ARTICLE/M/S +ARTICULATE/P/D/G/N/X/Y/S +ARTICULATOR/S +ARTICULATORY +ARTIFACT/M/S +ARTIFACTUALLY +ARTIFICE/R/S +ARTIFICIAL/P/Y +ARTIFICIALITY/S +ARTILLERIST +ARTILLERY +ARTISAN/M/S +ARTIST/M/S +ARTISTIC +ARTISTICALLY +ARTISTRY +ARTLESS +ARTWORK +ARYAN +AS +ASBESTOS +ASCEND/D/R/Z/G/S +ASCENDANCY +ASCENDANT +ASCENDENCY +ASCENDENT +ASCENSION/S +ASCENT +ASCERTAIN/D/G/S +ASCERTAINABLE +ASCETIC/M/S +ASCETICISM +ASCII +ASCOT +ASCRIBABLE +ASCRIBE/D/G/S +ASCRIPTION +ASEPTIC +ASH/R/N/S +ASHAMED/Y +ASHMAN +ASHORE +ASHTRAY/M/S +ASIA +ASIAN/S +ASIATIC +ASIDE +ASININE +ASK/D/R/Z/G/S +ASKANCE +ASKEW +ASLEEP +ASOCIAL +ASP/N +ASPARAGUS +ASPECT/M/S +ASPERSION/M/S +ASPHALT +ASPHYXIA +ASPIC +ASPIRANT/M/S +ASPIRATE/D/G/S +ASPIRATION/M/S +ASPIRATOR/S +ASPIRE/D/G/S +ASPIRIN/S +ASS/M/S +ASSAIL/D/G/S +ASSAILANT/M/S +ASSASSIN/M/S +ASSASSINATE/D/G/N/X/S +ASSAULT/D/G/S +ASSAY/D/G +ASSEMBLAGE/M/S +ASSEMBLE/D/R/Z/G/S +ASSEMBLY/M/S +ASSENT/D/R/G/S +ASSERT/D/R/Z/G/V/S +ASSERTION/M/S +ASSERTIVELY +ASSERTIVENESS +ASSESS/D/G/S +ASSESSMENT/M/S +ASSESSOR/S +ASSET/M/S +ASSIDUITY +ASSIDUOUS/Y +ASSIGN/D/R/Z/G/S +ASSIGNABLE +ASSIGNEE/M/S +ASSIGNMENT/M/S +ASSIMILATE/D/G/N/X/S +ASSIST/D/G/S +ASSISTANCE/S +ASSISTANT/M/S +ASSISTANTSHIP/S +ASSOCIATE/D/G/N/X/V/S +ASSOCIATIONAL +ASSOCIATIVELY +ASSOCIATIVITY +ASSOCIATOR/M/S +ASSONANCE +ASSONANT +ASSORT/D/S +ASSORTMENT/M/S +ASSUAGE/D/S +ASSUME/D/G/S +ASSUMPTION/M/S +ASSURANCE/M/S +ASSURE/D/R/Z/G/S +ASSUREDLY +ASSURINGLY +ASSYRIAN +ASSYRIOLOGY +ASTATINE +ASTER/M/S +ASTERISK/M/S +ASTEROID/M/S +ASTEROIDAL +ASTHMA +ASTONISH/D/G/S +ASTONISHINGLY +ASTONISHMENT +ASTOUND/D/G/S +ASTRAL +ASTRAY +ASTRIDE +ASTRINGENCY +ASTRINGENT +ASTRONAUT/M/S +ASTRONAUTICS +ASTRONOMER/M/S +ASTRONOMICAL/Y +ASTRONOMY +ASTROPHYSICAL +ASTROPHYSICS +ASTUTE/P +ASUNDER +ASYLUM +ASYMMETRIC +ASYMMETRICALLY +ASYMMETRY +ASYMPTOMATICALLY +ASYMPTOTE/M/S +ASYMPTOTIC +ASYMPTOTICALLY +ASYNCHRONISM +ASYNCHRONOUS/Y +ASYNCHRONY +AT +ATAVISTIC +ATE +ATEMPORAL +ATHEIST/M/S +ATHEISTIC +ATHENA +ATHENIAN/S +ATHENS +ATHEROSCLEROSIS +ATHLETE/M/S +ATHLETIC/S +ATHLETICISM +ATLANTIC +ATLAS +ATMOSPHERE/M/S +ATMOSPHERIC +ATOLL/M/S +ATOM/M/S +ATOMIC/S +ATOMICALLY +ATOMIZATION +ATOMIZE/D/G/S +ATONAL/Y +ATONE/D/S +ATONEMENT +ATOP +ATROCIOUS/Y +ATROCITY/M/S +ATROPHIC +ATROPHY/D/G/S +ATTACH/D/R/Z/G/S +ATTACHE/D/G/S +ATTACHMENT/M/S +ATTACK/D/R/Z/G/S +ATTACKABLE +ATTAIN/D/R/Z/G/S +ATTAINABLE +ATTAINABLY +ATTAINMENT/M/S +ATTEMPT/D/R/Z/G/S +ATTEND/D/R/Z/G/S +ATTENDANCE/M/S +ATTENDANT/M/S +ATTENDEE/M/S +ATTENTION/M/S +ATTENTIONAL +ATTENTIONALITY +ATTENTIVE/P/Y +ATTENUATE/D/G/N/S +ATTENUATOR/M/S +ATTEST/D/G/S +ATTIC/M/S +ATTIRE/D/G/S +ATTITUDE/M/S +ATTITUDINAL +ATTORNEY/M/S +ATTRACT/D/G/V/S +ATTRACTION/M/S +ATTRACTIVELY +ATTRACTIVENESS +ATTRACTOR/M/S +ATTRIBUTABLE +ATTRIBUTE/D/G/N/X/V/S +ATTRIBUTIVELY +ATTRITION +ATTUNE/D/G/S +ATYPICAL/Y +AUBURN +AUCKLAND +AUCTION +AUCTIONEER/M/S +AUDACIOUS/P/Y +AUDACITY +AUDIBLE +AUDIBLY +AUDIENCE/M/S +AUDIO +AUDIOGRAM/M/S +AUDIOLOGICAL +AUDIOLOGIST/M/S +AUDIOLOGY +AUDIOMETER/S +AUDIOMETRIC +AUDIOMETRY +AUDIT/D/G/S +AUDITION/D/M/G/S +AUDITOR/M/S +AUDITORIUM +AUDITORY +AUDUBON +AUGER/M/S +AUGHT +AUGMENT/D/G/S +AUGMENTATION +AUGUR/S +AUGUST/P/Y +AUGUSTA +AUNT/M/S +AURA/M/S +AURAL/Y +AUREOLE +AUREOMYCIN +AURORA +AUSCULTATE/D/G/N/X/S +AUSPICE/S +AUSPICIOUS/Y +AUSTERE/Y +AUSTERITY +AUSTIN +AUSTRALIA +AUSTRALIAN +AUSTRIA +AUSTRIAN +AUTHENTIC +AUTHENTICALLY +AUTHENTICATE/D/G/N/X/S +AUTHENTICATOR/S +AUTHENTICITY +AUTHOR/D/G/S +AUTHORITARIAN +AUTHORITARIANISM +AUTHORITATIVE/Y +AUTHORITY/M/S +AUTHORIZATION/M/S +AUTHORIZE/D/R/Z/G/S +AUTHORSHIP +AUTISM +AUTISTIC +AUTO/M/S +AUTOBIOGRAPHIC +AUTOBIOGRAPHICAL +AUTOBIOGRAPHY/M/S +AUTOCOLLIMATOR +AUTOCORRELATE/N +AUTOCRACY/S +AUTOCRAT/M/S +AUTOCRATIC +AUTOCRATICALLY +AUTOFLUORESCENCE +AUTOGRAPH/D/G +AUTOGRAPHS +AUTOMATA +AUTOMATE/D/G/N/S +AUTOMATIC +AUTOMATICALLY +AUTOMATON +AUTOMOBILE/M/S +AUTOMOTIVE +AUTONAVIGATOR/M/S +AUTONOMIC +AUTONOMOUS/Y +AUTONOMY +AUTOPILOT/M/S +AUTOPSY/D/S +AUTOREGRESSIVE +AUTOSUGGESTIBILITY +AUTOTRANSFORMER +AUTUMN/M/S +AUTUMNAL +AUXILIARY/S +AVAIL/D/R/Z/G/S +AVAILABILITY/S +AVAILABLE +AVAILABLY +AVALANCHE/D/G/S +AVANT +AVARICE +AVARICIOUS/Y +AVE +AVENGE/D/R/G/S +AVENUE/M/S +AVER/S +AVERAGE/D/G/S +AVERRED +AVERRER +AVERRING +AVERSE/N +AVERSION/M/S +AVERT/D/G/S +AVIAN +AVIARY/S +AVIATION +AVIATOR/M/S +AVID/Y +AVIDITY +AVIONIC/S +AVOCADO/S +AVOCATION/M/S +AVOID/D/R/Z/G/S +AVOIDABLE +AVOIDABLY +AVOIDANCE +AVOUCH +AVOW/D/S +AWAIT/D/G/S +AWAKE/G/S +AWAKEN/D/G/S +AWARD/D/R/Z/G/S +AWARE/P +AWASH +AWAY +AWE/D +AWESOME +AWFUL/P/Y +AWHILE +AWKWARD/P/Y +AWL/M/S +AWNING/M/S +AWOKE +AWRY +AX/D/R/Z/G/S +AXE/D/S +AXIAL/Y +AXIOLOGICAL +AXIOM/M/S +AXIOMATIC +AXIOMATICALLY +AXIOMATIZATION/M/S +AXIOMATIZE/D/G/S +AXIS +AXLE/M/S +AXOLOTL/M/S +AXON/M/S +AYE/S +AZALEA/M/S +AZIMUTH/M +AZIMUTHS +AZURE +BABBLE/D/G/S +BABE/M/S +BABEL/M +BABY/D/G/S +BABYHOOD +BABYISH +BACCALAUREATE +BACH/M +BACHELOR/M/S +BACILLI +BACILLUS +BACK/D/R/Z/G/S +BACKACHE/M/S +BACKARROW/S +BACKBEND/M/S +BACKBONE/M/S +BACKDROP/M/S +BACKGAMMON +BACKGROUND/M/S +BACKLASH +BACKLOG/M/S +BACKPACK/M/S +BACKPLANE/M/S +BACKPOINTER/M/S +BACKPROPAGATE/D/G/N/X/S +BACKSCATTER/D/G/S +BACKSLASH/S +BACKSPACE/D/S +BACKSTAGE +BACKSTAIRS +BACKSTITCH/D/G/S +BACKTRACK/D/R/Z/G/S +BACKUP/S +BACKWARD/P/S +BACKWATER/M/S +BACKWOODS +BACKYARD/M/S +BACON +BACTERIA +BACTERIAL +BACTERIUM +BAD/P/Y +BADE +BADGE/R/Z/S +BADGER'S +BADGERED +BADGERING +BADLANDS +BADMINTON +BAFFLE/D/R/Z/G +BAG/M/S +BAGATELLE/M/S +BAGEL/M/S +BAGGAGE +BAGGED +BAGGER/M/S +BAGGING +BAGGY +BAGPIPE/M/S +BAH +BAIL/G +BAILIFF/M/S +BAIT/D/R/G/S +BAKE/D/R/Z/G/S +BAKERY/M/S +BAKLAVA +BALALAIKA/M/S +BALANCE/D/R/Z/G/S +BALCONY/M/S +BALD/P/G/Y +BALE/R/S +BALEFUL +BALK/D/G/S +BALKAN/S +BALKANIZE/D/G +BALKY/P +BALL/D/R/Z/G/S +BALLAD/M/S +BALLAST/M/S +BALLERINA/M/S +BALLET/M/S +BALLGOWN/M/S +BALLISTIC/S +BALLOON/D/R/Z/G/S +BALLOT/M/S +BALLPARK/M/S +BALLPLAYER/M/S +BALLROOM/M/S +BALLYHOO +BALM/M/S +BALMY +BALSA +BALSAM +BALTIC +BALUSTRADE/M/S +BAMBOO +BAN/M/S +BANAL/Y +BANANA/M/S +BAND/D/G/S +BANDAGE/D/G/S +BANDIT/M/S +BANDLIMIT/D/G/S +BANDPASS +BANDSTAND/M/S +BANDWAGON/M/S +BANDWIDTH +BANDWIDTHS +BANDY/D/G/S +BANE +BANEFUL +BANG/D/G/S +BANGLADESH +BANGLE/M/S +BANISH/D/G/S +BANISHMENT +BANISTER/M/S +BANJO/M/S +BANK/D/R/Z/G/S +BANKRUPT/D/G/S +BANKRUPTCY/M/S +BANNED +BANNER/M/S +BANNING +BANQUET/G/J/S +BANSHEE/M/S +BANTAM +BANTER/D/G/S +BANTU/S +BAPTISM/M/S +BAPTISMAL +BAPTIST/M/S +BAPTISTERY +BAPTISTRY/M/S +BAPTIZE/D/G/S +BAR/M/S +BARB/D/R/S +BARBADOS +BARBARA/M +BARBARIAN/M/S +BARBARIC +BARBARITY/S +BARBAROUS/Y +BARBECUE/D/S/G +BARBELL/M/S +BARBITAL +BARBITURATE/S +BARD/M/S +BARE/P/D/T/R/G/Y/S +BAREFOOT/D +BARFLY/M/S +BARGAIN/D/G/S +BARGE/G/S +BARITONE/M/S +BARIUM +BARK/D/R/Z/G/S +BARLEY +BARN/M/S +BARNSTORM/D/G/S +BARNYARD/M/S +BAROMETER/M/S +BAROMETRIC +BARON/M/S +BARONESS +BARONIAL +BARONY/M/S +BAROQUE/P +BARRACK/S +BARRAGE/M/S +BARRED +BARREL/M/S/D/G +BARRELLED +BARRELLING +BARREN/P +BARRICADE/M/S +BARRIER/M/S +BARRING/R +BARROW +BARTENDER/M/S +BARTER/D/G/S +BAS +BASAL +BASALT +BASE/P/D/R/G/Y/S +BASEBALL/M/S +BASEBOARD/M/S +BASELESS +BASELINE/M/S +BASEMAN +BASEMENT/M/S +BASH/D/G/S +BASHFUL/P +BASIC/S +BASICALLY +BASIL +BASIN/M/S +BASIS +BASK/D/G +BASKET/M/S +BASKETBALL/M/S +BASS/M/S +BASSET +BASSINET/M/S +BASSO +BASTARD/M/S +BASTE/D/G/N/X/S +BASTION'S +BAT/M/S +BATCH/D/S +BATH +BATHE/D/R/Z/G/S +BATHOS +BATHROBE/M/S +BATHROOM/M/S +BATHS +BATHTUB/M/S +BATON/M/S +BATTALION/M/S +BATTED +BATTEN/S +BATTER/D/G/S +BATTERY/M/S +BATTING +BATTLE/D/R/Z/G/S +BATTLEFIELD/M/S +BATTLEFRONT/M/S +BATTLEGROUND/M/S +BATTLEMENT/M/S +BATTLESHIP/M/S +BAUBLE/M/S +BAUD +BAUXITE +BAWDY +BAWL/D/G/S +BAY/D/G/S +BAYONET/M/S +BAYOU/M/S +BAZAAR/M/S +BE/D/G/Y +BEACH/D/G/S +BEACHHEAD/M/S +BEACON/M/S +BEAD/D/G/S +BEADLE/M/S +BEADY +BEAGLE/M/S +BEAK/D/R/Z/S +BEAM/D/R/Z/G/S +BEAN/D/R/Z/G/S +BEAR/R/Z/G/J/S +BEARABLE +BEARABLY +BEARD/D/S +BEARDLESS +BEARISH +BEAST/Y/S +BEAT/R/Z/G/N/J/S +BEATABLE +BEATABLY +BEATIFIC +BEATIFY/N +BEATITUDE/M/S +BEATNIK/M/S +BEAU/M/S +BEAUTEOUS/Y +BEAUTIFUL/Y +BEAUTIFY/D/R/Z/G/X/S +BEAUTY/M/S +BEAVER/M/S +BECALM/D/G/S +BECAME +BECAUSE +BECK +BECKON/D/G/S +BECOME/G/S +BECOMINGLY +BED/M/S +BEDAZZLE/D/G/S +BEDAZZLEMENT +BEDBUG/M/S +BEDDED +BEDDER/M/S +BEDDING +BEDEVIL/D/G/S +BEDFAST +BEDLAM +BEDPOST/M/S +BEDRAGGLE/D +BEDRIDDEN +BEDROCK/M +BEDROOM/M/S +BEDSIDE +BEDSPREAD/M/S +BEDSPRING/M/S +BEDSTEAD/M/S +BEDTIME +BEE/R/Z/G/J/S +BEECH/R/N +BEEF/D/R/Z/G/S +BEEFSTEAK +BEEFY +BEEHIVE/M/S +BEEN +BEEP/S +BEET/M/S +BEETHOVEN +BEETLE/D/M/G/S +BEFALL/G/N/S +BEFELL +BEFIT/M/S +BEFITTED +BEFITTING +BEFOG +BEFOGGED +BEFOGGING +BEFORE +BEFOREHAND +BEFOUL/D/G/S +BEFRIEND/D/G/S +BEFUDDLE/D/G/S +BEG/S +BEGAN +BEGET/S +BEGETTING +BEGGAR/Y/S +BEGGARY +BEGGED +BEGGING +BEGIN/S +BEGINNER/M/S +BEGINNING/M/S +BEGOT +BEGOTTEN +BEGRUDGE/D/G/S +BEGRUDGINGLY +BEGUILE/D/G/S +BEGUN +BEHALF +BEHAVE/D/G/S +BEHAVIOR/S +BEHAVIORAL/Y +BEHAVIORISM +BEHAVIORISTIC +BEHEAD/G +BEHELD +BEHEST +BEHIND +BEHOLD/R/Z/G/N/S +BEHOOVE/S +BEIGE +BEIJING +BELABOR/D/G/S +BELATED/Y +BELAY/D/G/S +BELCH/D/G/S +BELFRY/M/S +BELGIAN/M/S +BELGIUM +BELIE/D/S +BELIEF/M/S +BELIEVABLE +BELIEVABLY +BELIEVE/D/R/Z/G/S +BELITTLE/D/G/S +BELL/M/S +BELLBOY/M/S +BELLE/M/S +BELLHOP/M/S +BELLICOSE +BELLICOSITY +BELLIGERENCE +BELLIGERENT/M/Y/S +BELLMAN +BELLMEN +BELLOW/D/G/S +BELLWETHER/M/S +BELLY/M/S +BELLYFUL +BELONG/D/G/J/S +BELOVED +BELOW +BELT/D/G/S +BELYING +BEMOAN/D/G/S +BENCH/D/S +BENCHMARK/M/S +BEND/R/Z/G/S +BENDABLE +BENEATH +BENEDICT +BENEDICTINE +BENEDICTION/M/S +BENEFACTOR/M/S +BENEFICENCE/S +BENEFICIAL/Y +BENEFICIARY/S +BENEFIT/D/G/S +BENEFITTED +BENEFITTING +BENEVOLENCE +BENEVOLENT +BENGAL +BENGALI +BENIGHTED +BENIGN/Y +BENT +BENZEDRINE +BENZENE +BEQUEATH/D/G/S +BEQUEST/M/S +BERATE/D/G/S +BEREAVE/D/G/S +BEREAVEMENT/S +BEREFT +BERET/M/S +BERIBBONED +BERIBERI +BERKELEY +BERKELIUM +BERLIN/R/Z +BERMUDA +BERRY/M/S +BERTH +BERTHS +BERYL +BERYLLIUM +BESEECH/G/S +BESET/S +BESETTING +BESIDE/S +BESIEGE/D/R/Z/G +BESMIRCH/D/G/S +BESOTTED +BESOTTER +BESOTTING +BESOUGHT +BESPEAK/S +BESPECTACLED +BESSEL +BEST/D/G/S +BESTIAL +BESTOW/D +BESTOWAL +BESTSELLER/M/S +BESTSELLING +BET/M/S +BETA +BETHESDA +BETIDE +BETRAY/D/R/G/S +BETRAYAL +BETROTH/D +BETROTHAL +BETTER/D/G/S +BETTERMENT/S +BETTING +BETWEEN +BETWIXT +BEVEL/D/G/S +BEVERAGE/M/S +BEVY +BEWAIL/D/G/S +BEWARE +BEWHISKERED +BEWILDER/D/G/S +BEWILDERINGLY +BEWILDERMENT +BEWITCH/D/G/S +BEYOND +BEZIER +BIANNUAL +BIAS/D/G/S +BIB/M/S +BIBBED +BIBBING +BIBLE/M/S +BIBLICAL/Y +BIBLIOGRAPHIC +BIBLIOGRAPHICAL +BIBLIOGRAPHY/M/S +BIBLIOPHILE +BICAMERAL +BICARBONATE +BICENTENNIAL +BICEP/M/S +BICKER/D/G/S +BICONCAVE +BICONVEX +BICYCLE/D/R/Z/G/S +BID/M/S +BIDDABLE +BIDDEN +BIDDER/M/S +BIDDING +BIDDY/S +BIDE +BIDIRECTIONAL +BIENNIAL +BIENNIUM +BIFOCAL/S +BIG/P +BIGGER +BIGGEST +BIGHT/M/S +BIGNUM +BIGOT/D/M/S +BIGOTRY +BIJECTION/M/S +BIJECTIVE/Y +BIKE/M/G/S +BIKINI/M/S +BILABIAL +BILATERAL/Y +BILE +BILGE/M/S +BILINEAR +BILINGUAL +BILK/D/G/S +BILL/D/R/Z/G/J/S/M +BILLBOARD/M/S +BILLET/D/G/S +BILLIARD/S +BILLION/H/S +BILLOW/D/S +BIMODAL +BIMOLECULAR +BIMONTHLY/S +BIN/M/S +BINARY +BINAURAL +BIND/R/Z/G/J/S +BINGE/S +BINGO +BINOCULAR/S +BINOMIAL +BINUCLEAR +BIOCHEMICAL +BIOCHEMISTRY +BIOFEEDBACK +BIOGRAPHER/M/S +BIOGRAPHIC +BIOGRAPHICAL/Y +BIOGRAPHY/M/S +BIOLOGICAL/Y +BIOLOGIST/M/S +BIOLOGY +BIOMEDICAL +BIOMEDICINE +BIOPHYSICAL +BIOPHYSICS +BIOPSY/S +BIOTECHNOLOGY +BIPARTISAN +BIPARTITE +BIPED/S +BIPLANE/M/S +BIPOLAR +BIRACIAL +BIRCH/N/S +BIRD/M/S +BIRDBATH/M +BIRDBATHS +BIRDIE/D/S +BIRDLIKE +BIREFRINGENCE +BIREFRINGENT +BIRMINGHAM +BIRTH/D +BIRTHDAY/M/S +BIRTHPLACE/S +BIRTHRIGHT/M/S +BIRTHS +BISCUIT/M/S +BISECT/D/G/S +BISECTION/M/S +BISECTOR/M/S +BISHOP/M/S +BISMUTH +BISON/M/S +BISQUE/S +BIT/M/S +BITCH/M/S +BITE/G/R/S/Z +BITINGLY +BITMAP/S +BITMAPPED +BITTEN +BITTER/P/T/R/Y/S +BITTERSWEET +BITUMINOUS +BITWISE +BIVALVE/M/S +BIVARIATE +BIVOUAC/S +BIWEEKLY +BIZARRE +BLAB/S +BLABBED +BLABBERMOUTH +BLABBERMOUTHS +BLABBING +BLACK/P/D/T/R/G/N/X/Y/S +BLACKBERRY/M/S +BLACKBIRD/M/S +BLACKBOARD/M/S +BLACKENED +BLACKENING +BLACKJACK/M/S +BLACKLIST/D/G/S +BLACKMAIL/D/R/Z/G/S +BLACKOUT/M/S +BLACKSMITH +BLACKSMITHS +BLADDER/M/S +BLADE/M/S +BLAINE +BLAMABLE +BLAME/D/R/Z/G/S +BLAMELESS/P +BLANCH/D/G/S +BLAND/P/Y +BLANK/P/D/T/R/G/Y/S +BLANKET/D/R/Z/G/S +BLARE/D/G/S +BLASE +BLASPHEME/D/G/S +BLASPHEMOUS/P/Y +BLASPHEMY/S +BLAST/D/R/Z/G/S +BLATANT/Y +BLAZE/D/R/Z/G/S +BLEACH/D/R/Z/G/S +BLEAK/P/Y +BLEAR +BLEARY +BLEAT/G/S +BLED +BLEED/R/G/J/S +BLEMISH/M/S +BLEND/D/G/S +BLESS/D/G/J +BLEW +BLIGHT/D +BLIMP/M/S +BLIND/P/D/R/Z/G/Y/S +BLINDFOLD/D/G/S +BLINDINGLY +BLINK/D/R/Z/G/S +BLIP/M/S +BLISS +BLISSFUL/Y +BLISTER/D/G/S +BLITHE/Y +BLITZ/M/S +BLITZKRIEG +BLIZZARD/M/S +BLOAT/D/R/G/S +BLOB/M/S +BLOC/M/S +BLOCK'S +BLOCK/D/R/Z/G/S +BLOCKADE/D/G/S +BLOCKAGE/M/S +BLOCKHOUSE/S +BLOKE/M/S +BLOND/M/S +BLONDE/M/S +BLOOD/D/S +BLOODHOUND/M/S +BLOODLESS +BLOODSHED +BLOODSHOT +BLOODSTAIN/D/M/S +BLOODSTREAM +BLOODY/D/T +BLOOM/D/Z/G/S +BLOSSOM/D/S +BLOT/M/S +BLOTTED +BLOTTING +BLOUSE/M/S +BLOW/R/Z/G/S +BLOWFISH +BLOWN +BLOWUP +BLUBBER +BLUDGEON/D/G/S +BLUE/P/T/R/G/S +BLUEBERRY/M/S +BLUEBIRD/M/S +BLUEBONNET/M/S +BLUEFISH +BLUEPRINT/M/S +BLUESTOCKING +BLUFF/G/S +BLUISH +BLUNDER/D/G/J/S +BLUNT/P/D/T/R/G/Y/S +BLUR/M/S +BLURB +BLURRED +BLURRING +BLURRY +BLURT/D/G/S +BLUSH/D/G/S +BLUSTER/D/G/S +BLUSTERY +BOAR +BOARD/D/R/Z/G/S +BOARDINGHOUSE/M/S +BOAST/D/R/Z/G/J/S +BOASTFUL/Y +BOAT/R/Z/G/S +BOATHOUSE/M/S +BOATLOAD/M/S +BOATMAN +BOATMEN +BOATSMAN +BOATSMEN +BOATSWAIN/M/S +BOATYARD/M/S +BOB/M/S +BOBBED +BOBBIN/M/S +BOBBING +BOBBY +BOBOLINK/M/S +BOBWHITE/M/S +BODE/S +BODICE +BODILY +BODONI +BODY/D/S +BODYBUILDER/M/S +BODYBUILDING +BODYGUARD/M/S +BODYWEIGHT +BOG/M/S +BOGGED +BOGGLE/D/G/S +BOGUS +BOIL/D/R/Z/G/S +BOILERPLATE +BOISTEROUS/Y +BOLD/P/T/R/Y +BOLDFACE +BOLIVIA +BOLL +BOLOGNA +BOLSHEVIK/M/S +BOLSHEVISM +BOLSTER/D/G/S +BOLT/D/G/S +BOLTZMANN +BOMB/D/R/Z/G/J/S +BOMBARD/D/G/S +BOMBARDMENT +BOMBAST +BOMBASTIC +BOMBPROOF +BONANZA/M/S +BOND/D/R/Z/G/S +BONDAGE +BONDSMAN +BONDSMEN +BONE/D/R/Z/G/S +BONFIRE/M/S +BONG +BONNET/D/S +BONNY +BONUS/M/S +BONY +BOO/H/S +BOOB +BOOBOO +BOOBY +BOOK/D/R/Z/G/J/S +BOOKCASE/M/S +BOOKIE/M/S +BOOKISH +BOOKKEEPER/M/S +BOOKKEEPING +BOOKLET/M/S +BOOKSELLER/M/S +BOOKSHELF/M +BOOKSHELVES +BOOKSTORE/M/S +BOOLEAN +BOOM/D/G/S +BOOMERANG/M/S +BOOMTOWN/M/S +BOON +BOOR/M/S +BOORISH +BOOST/D/R/G/S +BOOT/D/G/S +BOOTHS +BOOTLEG/S +BOOTLEGGED +BOOTLEGGER/M/S +BOOTLEGGING +BOOTSTRAP/M/S +BOOTSTRAPPED +BOOTSTRAPPING +BOOTY +BOOZE +BORATE/S +BORAX +BORDELLO/M/S +BORDER/D/G/J/S +BORDERLAND/M/S +BORDERLINE +BORE/D/R/G/S +BOREDOM +BORIC +BORN +BORNE +BORNEO +BORON +BOROUGH +BOROUGHS +BORROW/D/R/Z/G/S +BOSOM/M/S +BOSS/D/S +BOSTON +BOSTONIAN/M/S +BOSUN +BOTANICAL +BOTANIST/M/S +BOTANY +BOTCH/D/R/Z/G/S +BOTH/Z +BOTHER/D/G/S +BOTHERSOME +BOTSWANA +BOTTLE/D/R/Z/G/S +BOTTLENECK/M/S +BOTTOM/D/G/S +BOTTOMLESS +BOTULINUS +BOTULISM +BOUFFANT +BOUGH/M +BOUGHS +BOUGHT +BOULDER/M/S +BOULEVARD/M/S +BOUNCE/D/R/G/S +BOUNCY +BOUND/D/G/N/S +BOUNDARY/M/S +BOUNDLESS/P +BOUNTEOUS/Y +BOUNTY/M/S +BOUQUET/M/S +BOURBON +BOURGEOIS +BOURGEOISIE +BOUT/M/S +BOVINE/S +BOW/D/R/Z/G/S +BOWDLERIZE/D/G/S +BOWEL/M/S +BOWL/D/R/Z/G/S +BOWLINE/M/S +BOWMAN +BOWSTRING/M/S +BOX/D/R/Z/G/S +BOXCAR/M/S +BOXTOP/M/S +BOXWOOD +BOY/M/S +BOYCOTT/D/S +BOYFRIEND/M/S +BOYHOOD +BOYISH/P +BRA/M/S +BRACE/D/G/S +BRACELET/M/S +BRACKET/D/G/S +BRACKISH +BRAD/M +BRAE/M/S +BRAG/S +BRAGGED +BRAGGER +BRAGGING +BRAID/D/G/S +BRAILLE +BRAIN/D/G/S +BRAINCHILD/M +BRAINSTEM/M/S +BRAINSTORM/M/S +BRAINWASH/D/G/S +BRAINY +BRAKE/D/G/S +BRAMBLE/M/S +BRAMBLY +BRAN +BRANCH/D/G/J/S +BRAND/D/G/S +BRANDISH/G/S +BRANDY +BRASH/P/Y +BRASS/S +BRASSIERE +BRASSY +BRAT/M/S +BRAVADO +BRAVE/P/D/T/R/G/Y/S +BRAVERY +BRAVO/S +BRAVURA +BRAWL/R/G +BRAWN +BRAY/D/R/G/S +BRAZE/D/G/S +BRAZEN/P/Y +BRAZIER/M/S +BRAZIL +BRAZILIAN +BREACH/D/R/Z/G/S +BREAD/D/G/H/S +BREADBOARD/M/S +BREADBOX/M/S +BREADWINNER/M/S +BREAK/R/Z/G/S +BREAKABLE/S +BREAKAGE +BREAKAWAY +BREAKDOWN/M/S +BREAKFAST/D/R/Z/G/S +BREAKPOINT/M/S +BREAKTHROUGH/M/S +BREAKTHROUGHS +BREAKUP +BREAKWATER/M/S +BREAST/D/S +BREASTWORK/M/S +BREATH +BREATHABLE +BREATHE/D/R/Z/G/S +BREATHLESS/Y +BREATHS +BREATHTAKING/Y +BREATHY +BRED +BREECH/M/S +BREED/R/G/S +BREEZE/M/S +BREEZILY +BREEZY +BREMSSTRAHLUNG +BRETHREN +BREVE +BREVET/D/G/S +BREVITY +BREW/D/R/Z/G/S +BREWERY/M/S +BRIAN/M +BRIAR/M/S +BRIBE/D/R/Z/G/S +BRICK/D/R/S +BRICKLAYER/M/S +BRICKLAYING +BRIDAL +BRIDE/M/S +BRIDEGROOM +BRIDESMAID/M/S +BRIDGE/D/G/S +BRIDGEABLE +BRIDGEHEAD/M/S +BRIDGEWORK/M +BRIDLE/D/G/S +BRIEF/P/D/T/R/Y/S +BRIEFCASE/M/S +BRIEFING/M/S +BRIER +BRIG/M/S +BRIGADE/M/S +BRIGADIER/M/S +BRIGANTINE +BRIGHT/P/T/R/X/Y +BRIGHTEN/D/R/Z/G/S +BRILLIANCE +BRILLIANCY +BRILLIANT/Y +BRIM +BRIMFUL +BRIMMED +BRINDLE/D +BRINE +BRING/G/R/S/Z +BRINK +BRINKMANSHIP +BRISK/P/R/Y +BRISTLE/D/G/S +BRITAIN +BRITCHES +BRITISH/R +BRITON/M/S +BRITTLE/P +BROACH/D/G/S +BROAD/P/T/R/X/Y +BROADBAND +BROADCAST/R/Z/G/J/S +BROADEN/D/R/Z/G/J/S +BROADSIDE +BROCADE/D +BROCCOLI +BROCHURE/M/S +BROIL/D/R/Z/G/S +BROKE/R/Z +BROKEN/P/Y +BROKERAGE +BROMIDE/M/S +BROMINE +BRONCHI +BRONCHIAL +BRONCHIOLE/M/S +BRONCHITIS +BRONCHUS +BRONZE/D/S +BROOCH/M/S +BROOD/R/G/S +BROOK/D/S +BROOKHAVEN +BROOM/M/S +BROOMSTICK/M/S +BROTH/R/Z +BROTHEL/M/S +BROTHER'S +BROTHERHOOD +BROTHERLY/P +BROUGHT +BROW/M/S +BROWBEAT/G/N/S +BROWN/P/D/T/R/G/S +BROWNIE/M/S +BROWNISH +BROWSE/G +BROWSER/S +BRUCE/M +BRUISE/D/G/S +BRUNCH/S +BRUNETTE +BRUNT +BRUSH/D/G/S +BRUSHFIRE/M/S +BRUSHLIKE +BRUSHY +BRUSQUE/Y +BRUTAL/Y +BRUTALITY/S +BRUTALIZE/D/G/S +BRUTE/M/S +BRUTISH +BSD +BUBBLE/D/G/S +BUBBLY +BUCK/D/G/S +BUCKBOARD/M/S +BUCKET/M/S +BUCKLE/D/R/G/S +BUCKSHOT +BUCKSKIN/S +BUCKWHEAT +BUCOLIC +BUD/M/S +BUDDED +BUDDING +BUDDY/M/S +BUDGE/D/G/S +BUDGET/D/R/Z/G/S +BUDGETARY +BUFF/M/S +BUFFALO +BUFFALOES +BUFFER/D/M/G/S +BUFFERER/M/S +BUFFET/D/G/J/S +BUFFOON/M/S +BUG/M/S +BUGGED +BUGGER/M/S +BUGGING +BUGGY/M/S +BUGLE/D/R/G/S +BUILD/R/Z/G/J/S +BUILDUP/M/S +BUILT +BULB/M/S +BULGE/D/G +BULK/D/S +BULKHEAD/M/S +BULKY +BULL/D/G/S +BULLDOG/M/S +BULLDOZE/D/R/G/S +BULLET/M/S +BULLETIN/M/S +BULLION +BULLISH +BULLY/D/G/S +BULWARK +BUM/M/S +BUMBLE/D/R/Z/G/S +BUMBLEBEE/M/S +BUMMED +BUMMING +BUMP/D/R/Z/G/S +BUMPTIOUS/P/Y +BUN/M/S +BUNCH/D/G/S +BUNDLE/D/G/S +BUNGALOW/M/S +BUNGLE/D/R/Z/G/S +BUNION/M/S +BUNK/R/Z/S +BUNKER'S +BUNKERED +BUNKHOUSE/M/S +BUNKMATE/M/S +BUNNY/M/S +BUNT/D/R/Z/G/S +BUOY/D/S +BUOYANCY +BUOYANT +BURDEN/D/G/S +BURDENSOME +BUREAU/M/S +BUREAUCRACY/M/S +BUREAUCRAT/M/S +BUREAUCRATIC +BURGEON/D/G +BURGESS/M/S +BURGHER/M/S +BURGLAR/M/S +BURGLARIZE/D/G/S +BURGLARPROOF/D/G/S +BURGLARY/M/S +BURIAL +BURL +BURLESQUE/S +BURLY +BURN/D/R/Z/G/J/S +BURNINGLY +BURNISH/D/G/S +BURNT/P/Y +BURP/D/G/S +BURR/M/S +BURRO/M/S +BURROW/D/R/G/S +BURSA +BURSITIS +BURST/G/S +BURY/D/G/S +BUS/D/G/S +BUSBOY/M/S +BUSH/G/S +BUSHEL/M/S +BUSHWHACK/D/G/S +BUSHY +BUSILY +BUSINESS/M/S +BUSINESSLIKE +BUSINESSMAN +BUSINESSMEN +BUSS/D/G/S +BUST/D/R/S +BUSTARD/M/S +BUSTLE/G +BUSY/D/T/R +BUT +BUTANE +BUTCHER/D/S +BUTCHERY +BUTLER/M/S +BUTT/M/S +BUTTE/D/Z/G/S +BUTTER/D/R/Z/G +BUTTERFAT +BUTTERFLY/M/S +BUTTERNUT +BUTTOCK/M/S +BUTTON/D/G/S +BUTTONHOLE/M/S +BUTTRESS/D/G/S +BUTYL +BUTYRATE +BUXOM +BUY/G/S +BUYER/M/S +BUZZ/D/R/G/S +BUZZARD/M/S +BUZZWORD/M/S +BUZZY +BY/R +BYE +BYGONE +BYLAW/M/S +BYLINE/M/S +BYPASS/D/G/S +BYPRODUCT/M/S +BYSTANDER/M/S +BYTE/M/S +BYWAY/S +BYWORD/M/S +CAB/M/S +CABBAGE/M/S +CABIN/M/S +CABINET/M/S +CABLE/D/G/S +CACHE/M/S/G/D +CACKLE/D/R/G/S +CACTI +CACTUS +CADENCE/D +CADUCEUS +CAFE/M/S +CAGE/D/R/Z/G/S +CAJOLE/D/G/S +CAKE/D/G/S +CALAMITY/M/S +CALCIUM +CALCULATE/D/G/N/X/V/S +CALCULATOR/M/S +CALCULUS +CALENDAR/M/S +CALF +CALIBER/S +CALIBRATE/D/G/N/X/S +CALICO +CALIFORNIA +CALIPH +CALIPHS +CALL/D/R/Z/G/S +CALLIGRAPHY +CALLOUS/P/D/Y +CALM/P/D/T/R/G/Y/S +CALMINGLY +CALORIE/M/S +CALVES +CAMBRIDGE +CAME +CAMEL/M/S +CAMERA/M/S +CAMOUFLAGE/D/G/S +CAMP/D/R/Z/G/S +CAMPAIGN/D/R/Z/G/S +CAMPUS/M/S +CAN'T +CAN/M/S +CANADA +CANAL/M/S +CANARY/M/S +CANCEL/D/G/S +CANCELLATION/M/S +CANCER/M/S +CANDID/P/Y +CANDIDATE/M/S +CANDLE/R/S +CANDLESTICK/M/S +CANDOR +CANDY/D/S +CANE/R +CANINE +CANKER +CANNED +CANNER/M/S +CANNIBAL/M/S +CANNIBALIZE/D/G/S +CANNING +CANNISTER/M/S +CANNON/M/S +CANNOT +CANOE/M/S +CANON/M/S +CANONICAL/Y/S +CANONICALIZATION +CANONICALIZE/D/G/S +CANOPY +CANTANKEROUS/Y +CANTO +CANTON/M/S +CANTOR/M/S +CANVAS/M/S +CANVASS/D/R/Z/G/S +CANYON/M/S +CAP/M/S +CAPABILITY/M/S +CAPABLE +CAPABLY +CAPACIOUS/P/Y +CAPACITANCE/S +CAPACITIVE +CAPACITOR/M/S +CAPACITY/S +CAPE/R/Z/S +CAPILLARY +CAPITA +CAPITAL/Y/S +CAPITALISM +CAPITALIST/M/S +CAPITALIZATION/S +CAPITALIZE/D/R/Z/G/S +CAPITOL/M/S +CAPPED +CAPPING +CAPRICIOUS/P/Y +CAPTAIN/D/G/S +CAPTION/M/S +CAPTIVATE/D/G/N/S +CAPTIVE/M/S +CAPTIVITY +CAPTOR/M/S +CAPTURE/D/R/Z/G/S +CAR/M/S +CARAVAN/M/S +CARBOHYDRATE +CARBOLIC +CARBON/M/S +CARBONATE/N/S +CARBONIC +CARBONIZATION +CARBONIZE/D/R/Z/G/S +CARCASS/M/S +CARCINOMA +CARD/R/S +CARDBOARD +CARDIAC +CARDINAL/Y/S +CARDINALITY/M/S +CARDIOLOGY +CARDIOPULMONARY +CARE/D/G/S +CAREER/M/S +CAREFREE +CAREFUL/P/Y +CARELESS/P/Y +CARESS/D/R/G/S +CARET +CARGO +CARGOES +CARIBOU +CARNEGIE +CARNIVAL/M/S +CARNIVOROUS/Y +CAROL/M/S +CAROLINA/M/S +CARPENTER/M/S +CARPET/D/G/S +CARRIAGE/M/S +CARROT/M/S +CARRY/D/R/Z/G/S +CARRYOVER/S +CART/D/R/Z/G/S +CARTESIAN +CARTOGRAPHIC +CARTOGRAPHY +CARTON/M/S +CARTOON/M/S +CARTRIDGE/M/S +CARVE/D/R/G/J/S +CASCADE/D/G/S +CASE/D/G/J/S +CASEMENT/M/S +CASH/D/R/Z/G/S +CASHIER/M/S +CASK/M/S +CASKET/M/S +CASSEROLE/M/S +CAST/G/M/S +CASTE/R/S/Z +CASTLE/D/S +CASUAL/P/Y/S +CASUALTY/M/S +CAT/M/S +CATALOG/D/R/G/S +CATALOGUE/D/S +CATALYST/M/S +CATARACT +CATASTROPHE +CATASTROPHIC +CATCH/G/R/S/Z +CATCHABLE +CATEGORICAL/Y +CATEGORIZATION +CATEGORIZE/D/R/Z/G/S +CATEGORY/M/S +CATER/D/R/G/S +CATERPILLAR/M/S +CATHEDRAL/M/S +CATHERINE/M +CATHETER/S +CATHODE/M/S +CATHOLIC/M/S +CATSUP +CATTLE +CAUGHT +CAUSAL/Y +CAUSALITY +CAUSATION/M/S +CAUSE/D/R/G/S +CAUSEWAY/M/S +CAUSTIC/Y/S +CAUTION/D/R/Z/G/J/S +CAUTIOUS/P/Y +CAVALIER/P/Y +CAVALRY +CAVE/D/G/S +CAVEAT/M/S +CAVERN/M/S +CAVITY/M/S +CAW/G +CDR +CEASE/D/G/S +CEASELESS/P/Y +CEDAR +CEILING/M/S +CELEBRATE/D/G/N/X/S +CELEBRITY/M/S +CELERY +CELESTIAL/Y +CELL/D/S +CELLAR/M/S +CELLIST/M/S +CELLULAR +CELSIUS +CEMENT/D/G/S +CEMETERY/M/S +CENSOR/D/G/S +CENSORSHIP +CENSURE/D/R/S +CENSUS/M/S +CENT/Z/S +CENTER/D/G/S +CENTERPIECE/M/S +CENTIMETER/S +CENTIPEDE/M/S +CENTRAL/Y +CENTRALIZATION +CENTRALIZE/D/G/S +CENTRIPETAL +CENTURY/M/S +CEREAL/M/S +CEREBRAL +CEREMONIAL/P/Y +CEREMONY/M/S +CERTAIN/Y +CERTAINTY/S +CERTIFIABLE +CERTIFICATE/N/X/S +CERTIFY/D/R/Z/G/N/S +CESSATION/M/S +CHAFE/R/G +CHAFF/R/G +CHAGRIN +CHAIN/D/G/S +CHAIR/D/G/S +CHAIRMAN +CHAIRMEN +CHAIRPERSON/M/S +CHALICE/M/S +CHALK/D/G/S +CHALLENGE/D/R/Z/G/S +CHAMBER/D/S +CHAMBERLAIN/M/S +CHAMPAGNE +CHAMPAIGN +CHAMPION/D/G/S +CHAMPIONSHIP/M/S +CHANCE/D/G/S +CHANCELLOR +CHANDELIER/M/S +CHANGE/D/R/Z/G/S +CHANGEABILITY +CHANGEABLE +CHANGEABLY +CHANNEL/D/G/S +CHANNELLED +CHANNELLER/M/S +CHANNELLING +CHANT/D/R/G/S +CHANTICLEER/M/S +CHAOS +CHAOTIC +CHAP/M/S +CHAPEL/M/S +CHAPERON/D +CHAPLAIN/M/S +CHAPTER/M/S +CHAR/S +CHARACTER/M/S +CHARACTERISTIC/M/S +CHARACTERISTICALLY +CHARACTERIZABLE +CHARACTERIZATION/M/S +CHARACTERIZE/D/R/Z/G/S +CHARCOAL/D +CHARGE/D/R/Z/G/S +CHARGEABLE +CHARIOT/M/S +CHARISMA +CHARISMATIC +CHARITABLE/P +CHARITY/M/S +CHARLES +CHARM/D/R/Z/G/S +CHARMINGLY +CHART/D/R/Z/G/J/S +CHARTABLE +CHARTERED +CHARTERING +CHASE/D/R/Z/G/S +CHASM/M/S +CHASTE/P/Y +CHASTISE/D/R/Z/G/S +CHAT +CHATEAU/M/S +CHATTER/D/R/G/S/Z +CHAUFFEUR/D +CHEAP/P/T/R/X/Y +CHEAPEN/D/G/S +CHEAT/D/R/Z/G/S +CHECK/D/R/Z/G/S +CHECKABLE +CHECKBOOK/M/S +CHECKOUT +CHECKPOINT/M/S +CHECKSUM/M/S +CHEEK/M/S +CHEER/D/R/G/S +CHEERFUL/P/Y +CHEERILY +CHEERLESS/P/Y +CHEERY/P +CHEESE/M/S +CHEF/M/S +CHEMICAL/Y/S +CHEMISE +CHEMIST/M/S +CHEMISTRY/S +CHERISH/D/G/S +CHERRY/M/S +CHERUB/M/S +CHERUBIM +CHESS +CHEST/R/S +CHESTNUT/M/S +CHEW/D/R/Z/G/S +CHICK/N/X/S +CHICKADEE/M/S +CHIDE/D/G/S +CHIEF/Y/S +CHIEFTAIN/M/S +CHIFFON +CHILD +CHILDHOOD +CHILDISH/P/Y +CHILDREN +CHILES +CHILL/D/R/Z/G/S +CHILLINGLY +CHILLY/P/R +CHIME/M/S +CHIMNEY/M/S +CHIN/M/S +CHINA +CHINESE +CHINK/D/S +CHINNED +CHINNER/S +CHINNING +CHINTZ +CHIP/M/S +CHIPMUNK/M/S +CHIRP/D/G/S +CHISEL/D/R/S +CHIVALROUS/P/Y +CHIVALRY +CHLORINE +CHLOROPLAST/M/S +CHOCK/M/S +CHOCOLATE/M/S +CHOICE/T/S +CHOIR/M/S +CHOKE/D/R/Z/G/S +CHOLERA +CHOOSE/R/Z/G/S +CHOP/S +CHOPPED +CHOPPER/M/S +CHOPPING +CHORAL +CHORD/M/S +CHORE/G/S +CHORUS/D/S +CHOSE +CHOSEN +CHRIS +CHRISTEN/D/G/S +CHRISTIAN/M/S +CHRISTMAS +CHRISTOPHER/M +CHROMOSOME +CHRONIC +CHRONICLE/D/R/Z/S +CHRONOLOGICAL/Y +CHRONOLOGY/M/S +CHUBBY/P/T/R +CHUCK/M/S +CHUCKLE/D/S +CHUM +CHUNK/G/D/S/M +CHURCH/Y/S +CHURCHMAN +CHURCHYARD/M/S +CHURN/D/G/S +CHUTE/M/S +CIDER +CIGAR/M/S +CIGARETTE/M/S +CINCINNATI +CINDER/M/S +CINNAMON +CIPHER/M/S +CIRCLE/D/G/S +CIRCUIT/M/S +CIRCUITOUS/Y +CIRCUITRY +CIRCULAR/Y +CIRCULARITY/S +CIRCULATE/D/G/N/S +CIRCUMFERENCE +CIRCUMFLEX +CIRCUMLOCUTION/M/S +CIRCUMSPECT/Y +CIRCUMSTANCE/M/S +CIRCUMSTANTIAL/Y +CIRCUMVENT/D/G/S +CIRCUMVENTABLE +CIRCUS/M/S +CISTERN/M/S +CITADEL/M/S +CITATION/M/S +CITE/D/G/S +CITIZEN/M/S +CITIZENSHIP +CITY/M/S +CIVIC/S +CIVIL/Y +CIVILIAN/M/S +CIVILITY +CIVILIZATION/M/S +CIVILIZE/D/G/S +CLAD +CLAIM/D/G/S +CLAIMABLE +CLAIMANT/M/S +CLAIRVOYANT/Y +CLAM/M/S +CLAMBER/D/G/S +CLAMOR/D/G/S +CLAMOROUS +CLAMP/D/G/S +CLAN +CLANG/D/G/S +CLAP/S +CLARA/M +CLARIFY/D/G/N/X/S +CLARITY +CLASH/D/G/S +CLASP/D/G/S +CLASS/D/S +CLASSIC/S +CLASSICAL/Y +CLASSIFIABLE +CLASSIFY/D/R/Z/G/N/X/S +CLASSMATE/M/S +CLASSROOM/M/S +CLATTER/D/G +CLAUSE/M/S +CLAW/D/G/S +CLAY/M/S +CLEAN/P/D/T/G/Y/S +CLEANER/M/S +CLEANLINESS +CLEANSE/D/R/Z/G/S +CLEAR/P/D/T/R/Y/S +CLEARANCE/M/S +CLEARING/M/S +CLEAVAGE +CLEAVE/D/R/Z/G/S +CLEFT/M/S +CLENCH/D/S +CLERGY +CLERGYMAN +CLERICAL +CLERK/D/G/S +CLEVER/P/T/R/Y +CLICHE/M/S +CLICK/D/G/S +CLIENT/M/S +CLIFF/M/S +CLIMATE/M/S +CLIMATIC +CLIMATICALLY +CLIMAX/D/S +CLIMB/D/R/Z/G/S +CLIME/M/S +CLINCH/D/R/S +CLING/G/S +CLINIC/M/S +CLINICAL/Y +CLINK/D/R +CLIP/M/S +CLIPPED +CLIPPER/M/S +CLIPPING/M/S +CLIQUE/M/S +CLOAK/M/S +CLOBBER/D/G/S +CLOCK/D/R/Z/G/J/S +CLOCKWISE +CLOCKWORK +CLOD/M/S +CLOG/M/S +CLOGGED +CLOGGING +CLOISTER/M/S +CLONE/D/G/S +CLOSE/D/T/G/Y/S +CLOSENESS/S +CLOSER/S +CLOSET/D/S +CLOSURE/M/S +CLOT +CLOTH +CLOTHE/D/G/S +CLOUD/D/G/S +CLOUDLESS +CLOUDY/P/T/R +CLOUT +CLOVE/R/S +CLOWN/G/S +CLUB/M/S +CLUBBED +CLUBBING +CLUCK/D/G/S +CLUE/M/S +CLUMP/D/G/S +CLUMSILY +CLUMSY/P +CLUNG +CLUSTER/D/G/J/S +CLUTCH/D/G/S +CLUTTER/D/G/S +CLX +CLYDE/M +CMU/M +COACH/D/R/G/S +COACHMAN +COAGULATION +COAL/S +COALESCE/D/G/S +COALITION +COARSE/P/T/R/Y +COARSEN/D +COAST/D/R/Z/G/S +COASTAL +COAT/D/G/J/S +COAX/D/R/G/S +COBBLER/M/S +COBOL +COBWEB/M/S +COCK/D/G/S +COCKATOO +COCKTAIL/M/S +COCOA +COCONUT/M/S +COCOON/M/S +COD +CODE/D/R/Z/G/J/S +CODEWORD/M/S +CODIFICATION/M/S +CODIFIER/M/S +CODIFY/D/G/S +COEFFICIENT/M/S +COERCE/D/G/N/V/S +COEXIST/D/G/S +COEXISTENCE +COFFEE/M/S +COFFER/M/S +COFFIN/M/S +COGENT/Y +COGITATE/D/G/N/S +COGNITION +COGNITIVE/Y +COGNIZANCE +COGNIZANT +COHABIT/S +COHABITATION/S +COHERE/D/G/S +COHERENCE +COHERENT/Y +COHESION +COHESIVE/P/Y +COIL/D/G/S +COIN/D/R/G/S +COINAGE +COINCIDE/D/G/S +COINCIDENCE/M/S +COINCIDENTAL +COKE/S +COLD/P/T/R/Y/S +COLLABORATE/D/G/N/X/V/S +COLLABORATOR/M/S +COLLAPSE/D/G/S +COLLAR/D/G/S +COLLATERAL +COLLEAGUE/M/S +COLLECT/D/G/V/S +COLLECTIBLE +COLLECTION/M/S +COLLECTIVE/Y/S +COLLECTOR/M/S +COLLEGE/M/S +COLLEGIATE +COLLIDE/D/G/S +COLLIE/R/S +COLLISION/M/S +COLLOQUIA +COLOGNE +COLON/M/S +COLONEL/M/S +COLONIAL/Y/S +COLONIST/M/S +COLONIZATION +COLONIZE/D/R/Z/G/S +COLONY/M/S +COLOR/D/R/Z/G/J/S +COLORADO +COLORFUL +COLORLESS +COLOSSAL +COLT/M/S +COLUMBUS +COLUMN/M/S +COLUMNAR +COLUMNIZE/D/G/S +COMB/D/R/Z/G/J/S +COMBAT/D/G/V/S +COMBATANT/M/S +COMBINATION/M/S +COMBINATIONAL +COMBINATOR/M/S +COMBINATORIAL/Y +COMBINATORIC/S +COMBINE/D/G/S +COMBUSTION +COME/R/Z/G/Y/J/S +COMEDIAN/M/S +COMEDIC +COMEDY/M/S +COMELINESS +COMESTIBLE +COMET/M/S +COMFORT/D/R/Z/G/S +COMFORTABILITY/S +COMFORTABLE +COMFORTABLY +COMFORTINGLY +COMIC/M/S +COMICAL/Y +COMMA/M/S +COMMAND'S +COMMAND/D/R/Z/G/S +COMMANDANT/M/S +COMMANDINGLY +COMMANDMENT/M/S +COMMEMORATE/D/G/N/V/S +COMMENCE/D/G/S +COMMENCEMENT/M/S +COMMEND/D/G/S +COMMENDABLE +COMMENDATION/M/S +COMMENSURATE +COMMENT/D/G/S +COMMENTARY/M/S +COMMENTATOR/M/S +COMMERCE +COMMERCIAL/P/Y/S +COMMISSION/D/R/Z/G/S +COMMIT/S +COMMITMENT/M/S +COMMITTED +COMMITTEE/M/S +COMMITTING +COMMODITY/M/S +COMMODORE/M/S +COMMON/P/T/Y/S +COMMONALITY/S +COMMONER/M/S +COMMONPLACE/S +COMMONWEALTH +COMMONWEALTHS +COMMOTION +COMMUNAL/Y +COMMUNE/N/S +COMMUNICANT/M/S +COMMUNICATE/D/G/N/X/V/S +COMMUNICATOR/M/S +COMMUNIST/M/S +COMMUNITY/M/S +COMMUTATIVE +COMMUTATIVITY +COMMUTE/D/R/Z/G/S +COMPACT/P/D/T/R/G/Y/S +COMPACTOR/M/S +COMPANION/M/S +COMPANIONABLE +COMPANIONSHIP +COMPANY/M/S +COMPARABILITY +COMPARABLE +COMPARABLY +COMPARATIVE/Y/S +COMPARATOR/M/S +COMPARE/D/G/S +COMPARISON/M/S +COMPARTMENT/D/S +COMPARTMENTALIZE/D/G/S +COMPASS +COMPASSION +COMPASSIONATE/Y +COMPATIBILITY/M/S +COMPATIBLE +COMPATIBLY +COMPEL/S +COMPELLED +COMPELLING/Y +COMPENDIUM +COMPENSATE/D/G/N/X/S +COMPENSATORY +COMPETE/D/G/S +COMPETENCE +COMPETENT/Y +COMPETITION/M/S +COMPETITIVE/Y +COMPETITOR/M/S +COMPILATION/M/S +COMPILE/D/R/Z/G/S +COMPILER'S +COMPLAIN/D/R/Z/G/S +COMPLAINT/M/S +COMPLEMENT/D/R/Z/G/S +COMPLEMENTARY +COMPLETE/P/D/G/N/X/Y/S +COMPLEX/Y/S +COMPLEXION +COMPLEXITY/S +COMPLIANCE +COMPLICATE/D/G/N/X/S +COMPLICATOR/M/S +COMPLICITY +COMPLIMENT/D/R/Z/G/S +COMPLIMENTARY +COMPLY/D/G +COMPONENT/M/S +COMPONENTWISE +COMPOSE/D/R/Z/G/S +COMPOSEDLY +COMPOSITE/N/X/S +COMPOSITIONAL +COMPOSURE +COMPOUND/D/G/S +COMPREHEND/D/G/S +COMPREHENSIBILITY +COMPREHENSIBLE +COMPREHENSION +COMPREHENSIVE/Y +COMPRESS/D/G/V/S +COMPRESSIBLE +COMPRESSION +COMPRISE/D/G/S +COMPROMISE/D/R/Z/G/S +COMPROMISING/Y +COMPTROLLER/M/S +COMPULSION/M/S +COMPULSORY +COMPUNCTION +COMPUTABILITY +COMPUTABLE +COMPUTATION/M/S +COMPUTATIONAL/Y +COMPUTE/D/R/Z/G/S +COMPUTER'S +COMPUTERIZE/D/G/S +COMRADE/Y/S +COMRADESHIP +CONCATENATE/D/G/N/X/S +CONCEAL/D/R/Z/G/S +CONCEALMENT +CONCEDE/D/G/S +CONCEIT/D/S +CONCEIVABLE +CONCEIVABLY +CONCEIVE/D/G/S +CONCENTRATE/D/G/N/X/S +CONCENTRATOR/S +CONCENTRIC +CONCEPT/M/S +CONCEPTION/M/S +CONCEPTUAL/Y +CONCEPTUALIZATION/M/S +CONCEPTUALIZE/D/G/S +CONCERN/D/G/S +CONCERNEDLY +CONCERT/D/S +CONCESSION/M/S +CONCISE/P/Y +CONCLUDE/D/G/S +CONCLUSION/M/S +CONCLUSIVE/Y +CONCOCT +CONCOMITANT +CONCORD +CONCORDANCE +CONCRETE/P/N/Y/S +CONCUR/S +CONCURRED +CONCURRENCE +CONCURRENCY/S +CONCURRENT/Y +CONCURRING +CONDEMN/D/R/Z/G/S +CONDEMNATION/S +CONDENSATION +CONDENSE/D/R/G/S +CONDESCEND/G +CONDITION/D/R/Z/G/S +CONDITIONAL/Y/S +CONDONE/D/G/S +CONDUCIVE +CONDUCT/D/G/V/S +CONDUCTION +CONDUCTIVITY +CONDUCTOR/M/S +CONE/M/S +CONFEDERACY +CONFEDERATE/N/X/S +CONFER/S +CONFERENCE/M/S +CONFERRED +CONFERRER/M/S +CONFERRING +CONFESS/D/G/S +CONFESSION/M/S +CONFESSOR/M/S +CONFIDANT/M/S +CONFIDE/D/G/S +CONFIDENCE/S +CONFIDENT/Y +CONFIDENTIAL/Y +CONFIDENTIALITY +CONFIDINGLY +CONFIGURABLE +CONFIGURATION/M/S +CONFIGURE/D/G/S +CONFINE/D/R/G/S +CONFINEMENT/M/S +CONFIRM/D/G/S +CONFIRMATION/M/S +CONFISCATE/D/G/N/X/S +CONFLICT/D/G/S +CONFORM/D/G/S +CONFORMITY +CONFOUND/D/G/S +CONFRONT/D/R/Z/G/S +CONFRONTATION/M/S +CONFUSE/D/R/Z/G/N/X/S +CONFUSINGLY +CONGENIAL/Y +CONGESTED +CONGESTION +CONGRATULATE/D/N/X +CONGREGATE/D/G/N/X/S +CONGRESS/M/S +CONGRESSIONAL/Y +CONGRESSMAN +CONGRUENCE +CONGRUENT +CONIC +CONJECTURE/D/G/S +CONJOINED +CONJUNCT/D/V/S +CONJUNCTION/M/S +CONJUNCTIVELY +CONJURE/D/R/G/S +CONNECT/D/G/S +CONNECTEDNESS +CONNECTICUT +CONNECTION/M/S +CONNECTIONIST +CONNECTIVE/M/S +CONNECTIVITY +CONNECTOR/M/S +CONNOISSEUR/M/S +CONNOTE/D/G/S +CONQUER/D/R/Z/G/S +CONQUERABLE +CONQUEROR/M/S +CONQUEST/M/S +CONS +CONSCIENCE/M/S +CONSCIENTIOUS/Y +CONSCIOUS/P/Y +CONSECRATE/N +CONSECUTIVE/Y +CONSENSUS +CONSENT/D/R/Z/G/S +CONSEQUENCE/M/S +CONSEQUENT/Y/S +CONSEQUENTIAL +CONSEQUENTIALITY/S +CONSERVATION/M/S +CONSERVATIONIST/M/S +CONSERVATISM +CONSERVATIVE/Y/S +CONSERVE/D/G/S +CONSIDER/D/G/S +CONSIDERABLE +CONSIDERABLY +CONSIDERATE/N/X/Y +CONSIGN/D/G/S +CONSIST/D/G/S +CONSISTENCY +CONSISTENT/Y +CONSOLABLE +CONSOLATION/M/S +CONSOLE/D/R/Z/G/S +CONSOLIDATE/D/G/N/S +CONSOLINGLY +CONSONANT/M/S +CONSORT/D/G/S +CONSORTIUM +CONSPICUOUS/Y +CONSPIRACY/M/S +CONSPIRATOR/M/S +CONSPIRE/D/S +CONSTABLE/M/S +CONSTANCY +CONSTANT/Y/S +CONSTELLATION/M/S +CONSTERNATION +CONSTITUENCY/M/S +CONSTITUENT/M/S +CONSTITUTE/D/G/N/X/V/S +CONSTITUTIONAL/Y +CONSTITUTIONALITY +CONSTRAIN/D/G/S +CONSTRAINT/M/S +CONSTRUCT/D/G/V/S +CONSTRUCTIBILITY +CONSTRUCTIBLE +CONSTRUCTION/M/S +CONSTRUCTIVELY +CONSTRUCTOR/M/S +CONSTRUE/D/G +CONSUL/M/S +CONSULATE/M/S +CONSULT/D/G/S +CONSULTANT/M/S +CONSULTATION/M/S +CONSUMABLE +CONSUME/D/R/Z/G/S +CONSUMER'S +CONSUMMATE/D/N/Y +CONSUMPTION/M/S +CONSUMPTIVE/Y +CONTACT/D/G/S +CONTAGION +CONTAGIOUS/Y +CONTAIN/D/R/Z/G/S +CONTAINABLE +CONTAINMENT/M/S +CONTAMINATE/D/G/N/S +CONTEMPLATE/D/G/N/X/V/S +CONTEMPORARY/P/S +CONTEMPT +CONTEMPTIBLE +CONTEMPTUOUS/Y +CONTEND/D/R/Z/G/S +CONTENT/D/G/Y/S +CONTENTION/M/S +CONTENTMENT +CONTEST/D/R/Z/G/S +CONTESTABLE +CONTEXT/M/S +CONTEXTUAL/Y +CONTIGUITY +CONTIGUOUS/Y +CONTINENT/M/S +CONTINENTAL/Y +CONTINGENCY/M/S +CONTINGENT/M/S +CONTINUAL/Y +CONTINUANCE/M/S +CONTINUATION/M/S +CONTINUE/D/G/S +CONTINUITY/S +CONTINUO +CONTINUOUS/Y +CONTINUUM +CONTOUR/D/M/G/S +CONTRACT/D/G/S +CONTRACTION/M/S +CONTRACTOR/M/S +CONTRACTUAL/Y +CONTRADICT/D/G/S +CONTRADICTION/M/S +CONTRADICTORY +CONTRADISTINCTION/S +CONTRAPOSITIVE/S +CONTRAPTION/M/S +CONTRARY/P +CONTRAST/D/R/Z/G/S +CONTRASTINGLY +CONTRIBUTE/D/G/N/X/S +CONTRIBUTOR/M/S +CONTRIBUTORILY +CONTRIBUTORY +CONTRIVANCE/M/S +CONTRIVE/D/R/G/S +CONTROL/M/S +CONTROLLABILITY +CONTROLLABLE +CONTROLLABLY +CONTROLLED +CONTROLLER/M/S +CONTROLLING +CONTROVERSIAL +CONTROVERSY/M/S +CONUNDRUM/M/S +CONVENE/D/G/S +CONVENIENCE/M/S +CONVENIENT/Y +CONVENT/M/S +CONVENTION/M/S +CONVENTIONAL/Y +CONVERGE/D/G/S +CONVERGENCE +CONVERGENT +CONVERSANT/Y +CONVERSATION/M/S +CONVERSATIONAL/Y +CONVERSE/D/G/N/X/Y/S +CONVERT/D/R/Z/G/S +CONVERTIBILITY +CONVERTIBLE +CONVEX +CONVEY/D/R/Z/G/S +CONVEYANCE/M/S +CONVICT/D/G/S +CONVICTION/M/S +CONVINCE/D/R/Z/G/S +CONVINCINGLY +CONVOLUTED +CONVOY/D/G/S +CONVULSION/M/S +COO/G +COOK/D/G/S +COOKERY +COOKIE/M/S +COOKY +COOL/P/D/T/G/Y/S +COOLER/M/S +COOLIE/M/S +COON/M/S +COOP/D/R/Z/S +COOPERATE/D/G/N/X/V/S +COOPERATIVELY +COOPERATIVES +COOPERATOR/M/S +COORDINATE/D/G/N/X/S +COORDINATOR/M/S +COP/M/S +COPE/D/G/J/S +COPIOUS/P/Y +COPPER/M/S +COPSE +COPY/D/R/Z/G/S +COPYRIGHT/M/S +CORAL +CORD/D/R/S +CORDIAL/Y +CORE/D/R/Z/G/S +CORK/D/R/Z/G/S +CORMORANT +CORN/R/Z/G/S +CORNERED +CORNERSTONE/M/S +CORNFIELD/M/S +COROLLARY/M/S +CORONARY/S +CORONATION +CORONET/M/S +COROUTINE/M/S +CORPOCRACY/S +CORPORAL/M/S +CORPORATE/N/X/Y +CORPORATION'S +CORPS +CORPSE/M/S +CORPUS +CORRECT/P/D/G/Y/S +CORRECTABLE +CORRECTION/S +CORRECTIVE/Y/S +CORRECTOR +CORRELATE/D/G/N/X/V/S +CORRESPOND/D/G/S +CORRESPONDENCE/M/S +CORRESPONDENT/M/S +CORRESPONDINGLY +CORRIDOR/M/S +CORROBORATE/D/G/N/X/V/S +CORROSION +CORRUPT/D/R/G/S +CORRUPTION +CORSET +CORTEX +CORTICAL +COSINE/S +COSMETIC/S +COSMOLOGY +COSMOPOLITAN +COST/D/G/Y/S +COSTUME/D/R/G/S +COT/M/S +COTTAGE/R/S +COTTON/S +COTYLEDON/M/S +COUCH/D/G/S +COUGH/D/G +COUGHS +COULD +COULDN'T +COUNCIL/M/S +COUNCILLOR/M/S +COUNSEL/D/G/S +COUNSELLED +COUNSELLING +COUNSELLOR/M/S +COUNSELOR/M/S +COUNT/D/Z/G/S +COUNTABLE +COUNTABLY +COUNTENANCE +COUNTER/D/G/S +COUNTERACT/D/G/V +COUNTERCLOCKWISE +COUNTEREXAMPLE/S +COUNTERFEIT/D/R/G +COUNTERMEASURE/M/S +COUNTERPART/M/S +COUNTERPOINT/G +COUNTERPRODUCTIVE +COUNTERREVOLUTION +COUNTESS +COUNTLESS +COUNTRY/M/S +COUNTRYMAN +COUNTRYSIDE +COUNTY/M/S +COUPLE/D/R/Z/G/J/S +COUPON/M/S +COURAGE +COURAGEOUS/Y +COURIER/M/S +COURSE/D/R/G/S +COURT/D/R/Z/G/Y/S +COURTEOUS/Y +COURTESY/M/S +COURTHOUSE/M/S +COURTIER/M/S +COURTROOM/M/S +COURTSHIP +COURTYARD/M/S +COUSIN/M/S +COVE/Z/S +COVENANT/M/S +COVER/D/G/J/S +COVERABLE +COVERAGE +COVERLET/M/S +COVERT/Y +COVET/D/G/S +COVETOUS/P +COW/D/Z/G/S +COWARD/Y +COWARDICE +COWBOY/M/S +COWER/D/R/Z/G/S +COWERINGLY +COWL/G/S +COWSLIP/M/S +COYOTE/M/S +COZY/P/R +CPU +CRAB/M/S +CRACK/D/R/Z/G/S +CRACKLE/D/G/S +CRADLE/D/S +CRAFT/D/R/G/S +CRAFTSMAN +CRAFTY/P +CRAG/M/S +CRAM/S +CRAMP/M/S +CRANBERRY/M/S +CRANE/M/S +CRANK/D/G/S +CRANKILY +CRANKY/T/R +CRASH/D/R/Z/G/S +CRATE/R/Z/S +CRAVAT/M/S +CRAVE/D/G/S +CRAVEN +CRAWL/D/R/Z/G/S +CRAY +CRAZE/D/G/S +CRAZILY +CRAZY/P/T/R +CREAK/D/G/S +CREAM/D/R/Z/G/S +CREAMY +CREASE/D/G/S +CREATE/D/G/N/X/V/S +CREATIVELY +CREATIVENESS +CREATIVITY +CREATOR/M/S +CREATURE/M/S +CREDENCE +CREDIBILITY +CREDIBLE +CREDIBLY +CREDIT/D/G/S +CREDITABLE +CREDITABLY +CREDITOR/M/S +CREDULITY +CREDULOUS/P +CREED/M/S +CREEK/M/S +CREEP/R/Z/G/S +CREMATE/D/G/N/X/S +CREPE +CREPT +CRESCENT/M/S +CREST/D/S +CREVICE/M/S +CREW/D/G/S +CRIB/M/S +CRICKET/M/S +CRIME/M/S +CRIMINAL/Y/S +CRIMSON/G +CRINGE/D/G/S +CRIPPLE/D/G/S +CRISES +CRISIS +CRISP/P/Y +CRITERIA +CRITERION +CRITIC/M/S +CRITICAL/Y +CRITICISE/D +CRITICISM/M/S +CRITICIZE/D/G/S +CRITIQUE/G/S +CROAK/D/G/S +CROCHET/S +CROOK/D/S +CROP/M/S +CROPPED +CROPPER/M/S +CROPPING +CROSS/D/R/Z/G/Y/J/S +CROSSABLE +CROSSBAR/M/S +CROSSOVER/M/S +CROSSWORD/M/S +CROUCH/D/G +CROW/D/G/S +CROWD/D/R/G/S +CROWN/D/G/S +CRT +CRUCIAL/Y +CRUCIFY/D/G/S +CRUDE/P/T/Y +CRUEL/T/R/Y +CRUELTY +CRUISE/R/Z/G/S +CRUMB/Y/S +CRUMBLE/D/G/S +CRUMPLE/D/G/S +CRUNCH/D/G/S +CRUNCHY/T/R +CRUSADE/R/Z/G/S +CRUSH/D/R/Z/G/S +CRUSHABLE +CRUSHINGLY +CRUST/M/S +CRUSTACEAN/M/S +CRUTCH/M/S +CRUX/M/S +CRY/D/R/Z/G/S +CRYPTANALYSIS +CRYPTOGRAPHIC +CRYPTOGRAPHY +CRYPTOLOGY +CRYSTAL/M/S +CRYSTALLINE +CRYSTALLIZE/D/G/S +CS +CSD +CUB/M/S +CUBE/D/S +CUBIC +CUCKOO/M/S +CUCUMBER/M/S +CUDDLE/D +CUDGEL/M/S +CUE/D/S +CUFF/M/S +CULL/D/R/G/S +CULMINATE/D/G/N/S +CULPRIT/M/S +CULT/M/S +CULTIVATE/D/G/N/X/S +CULTIVATOR/M/S +CULTURAL/Y +CULTURE/D/G/S +CUMBERSOME +CUMULATIVE/Y +CUNNING/Y +CUP/M/S +CUPBOARD/M/S +CUPFUL +CUPPED +CUPPING +CUR/Y/S +CURABLE +CURABLY +CURB/G/S +CURD +CURE/D/G/S +CURFEW/M/S +CURIOSITY/M/S +CURIOUS/T/R/Y +CURL/D/R/Z/G/S +CURRANT/M/S +CURRENCY/M/S +CURRENT/P/Y/S +CURRICULA +CURRICULAR +CURRICULUM/M/S +CURRY/D/G/S +CURSE/D/G/V/S +CURSOR/M/S +CURSORILY +CURSORY +CURT/P/Y +CURTAIL/D/S +CURTAIN/D/S +CURTATE +CURTSY/M/S +CURVATURE +CURVE/D/G/S +CUSHION/D/G/S +CUSP/M/S +CUSTARD +CUSTODIAN/M/S +CUSTODY +CUSTOM/R/Z/S +CUSTOMARILY +CUSTOMARY +CUSTOMIZABLE +CUSTOMIZATION/M/S +CUSTOMIZE/D/R/Z/G/S +CUT/M/S +CUTE/T +CUTOFF +CUTTER/M/S +CUTTING/Y/S +CYBERNETIC +CYCLE/D/G/S +CYCLIC +CYCLICALLY +CYCLOID/M/S +CYCLOIDAL +CYCLONE/M/S +CYLINDER/M/S +CYLINDRICAL +CYMBAL/M/S +CYNICAL/Y +CYPRESS +CYST/S +CYTOLOGY +CZAR +DABBLE/D/R/G/S +DAD/M/S +DADDY +DAEMON/M/S +DAFFODIL/M/S +DAGGER +DAILY/S +DAINTILY +DAINTY/P +DAIRY +DAISY/M/S +DALE/M/S +DAM/M/S +DAMAGE/D/R/Z/G/S +DAMASK +DAME +DAMN/D/G/S +DAMNATION +DAMP/P/R/G/N/X +DAMSEL/M/S +DAN/M +DANCE/D/R/Z/G/S +DANDELION/M/S +DANDY +DANGER/M/S +DANGEROUS/Y +DANGLE/D/G/S +DANIEL/M +DARE/D/R/Z/G/S +DARESAY +DARINGLY +DARK/P/T/R/N/Y +DARLING/M/S +DARN/D/R/G/S +DARPA +DART/D/R/G/S +DASH/D/R/Z/G/S +DASHING/Y +DATA +DATABASE/M/S +DATE/D/R/G/V/S +DATUM +DAUGHTER/Y/S +DAUNT/D +DAUNTLESS +DAVE/M +DAVID/M +DAWN/D/G/S +DAY/M/S +DAYBREAK +DAYDREAM/G/S +DAYLIGHT/M/S +DAYTIME +DAZE/D +DAZZLE/D/R/G/S +DAZZLINGLY +DBMS +DEACON/M/S +DEAD/P/N/Y +DEADLINE/M/S +DEADLOCK/D/G/S +DEAF/P/T/R/N +DEAL/R/Z/G/J/S +DEALLOCATE/D/G/N/X/S +DEALLOCATED +DEALLOCATION +DEALT +DEAN/M/S +DEAR/P/T/R/H/Y +DEARTHS +DEATH/Y +DEATHRATE/M/S +DEATHS +DEBATABLE +DEBATE/D/R/Z/G/S +DEBBIE/M +DEBILITATE/D/G/S +DEBRIS +DEBT/M/S +DEBTOR +DEBUG/S +DEBUGGED +DEBUGGER/M/S +DEBUGGING +DECADE/M/S +DECADENCE +DECADENT/Y +DECAY/D/G/S +DECEASE/D/G/S +DECEIT +DECEITFUL/P/Y +DECEIVE/D/R/Z/G/S +DECELERATE/D/G/N/S +DECEMBER +DECENCY/M/S +DECENT/Y +DECENTRALIZATION +DECENTRALIZED +DECEPTION/M/S +DECEPTIVE/Y +DECIDABILITY +DECIDABLE +DECIDE/D/G/S +DECIDEDLY +DECIMAL/S +DECIMATE/D/G/N/S +DECIPHER/D/R/G/S +DECISION/M/S +DECISIVE/P/Y +DECK/D/G/J/S +DECLARATION/M/S +DECLARATIVE/Y/S +DECLARE/D/R/Z/G/S +DECLINATION/M/S +DECLINE/D/R/Z/G/S +DECODE/D/R/Z/G/J/S +DECOMPOSABILITY +DECOMPOSABLE +DECOMPOSE/D/G/S +DECOMPOSITION/M/S +DECOMPRESSION +DECONSTRUCT/D/G/S +DECONSTRUCTION +DECORATE/D/G/N/X/V/S +DECORUM +DECOUPLE/D/G/S +DECOY/M/S +DECREASE/D/G/S +DECREASINGLY +DECREE/D/S +DECREEING +DECREMENT/D/G/S +DEDICATE/D/G/N/S +DEDUCE/D/R/G/S +DEDUCIBLE +DEDUCT/D/G/V +DEDUCTION/M/S +DEED/D/G/S +DEEM/D/G/S +DEEMPHASIZE/D/G/S +DEEP/T/R/N/Y/S +DEEPEN/D/G/S +DEER +DEFAULT/D/R/G/S +DEFEAT/D/G/S +DEFECT/D/G/V/S +DEFECTION/M/S +DEFEND/D/R/Z/G/S +DEFENDANT/M/S +DEFENESTRATE/D/G/N/S +DEFENSE/V/S +DEFENSELESS +DEFER/S +DEFERENCE +DEFERMENT/M/S +DEFERRABLE +DEFERRED +DEFERRER/M/S +DEFERRING +DEFIANCE +DEFIANT/Y +DEFICIENCY/S +DEFICIENT +DEFICIT/M/S +DEFILE/G +DEFINABLE +DEFINE/D/R/G/S +DEFINITE/P/N/X/Y +DEFINITION/M/S +DEFINITIONAL +DEFINITIVE +DEFORMATION/M/S +DEFORMED +DEFORMITY/M/S +DEFTLY +DEFY/D/G/S +DEGENERATE/D/G/N/V/S +DEGRADABLE +DEGRADATION/M/S +DEGRADE/D/G/S +DEGREE/M/S +DEIGN/D/G/S +DEITY/M/S +DEJECTED/Y +DELAWARE +DELAY/D/G/S +DELEGATE/D/G/N/X/S +DELETE/D/R/G/N/X/S +DELIBERATE/P/D/G/N/X/Y/S +DELIBERATIVE +DELIBERATOR/M/S +DELICACY/M/S +DELICATE/Y +DELICIOUS/Y +DELIGHT/D/G/S +DELIGHTEDLY +DELIGHTFUL/Y +DELIMIT/D/R/Z/G/S +DELINEATE/D/G/N/S +DELIRIOUS/Y +DELIVER/D/R/Z/G/S +DELIVERABLE/S +DELIVERANCE +DELIVERY/M/S +DELL/M/S +DELTA/M/S +DELUDE/D/G/S +DELUGE/D/S +DELUSION/M/S +DELVE/G/S +DEMAND/D/R/G/S +DEMANDINGLY +DEMARCATE/N/D/G/S +DEMEANOR +DEMISE +DEMO/S +DEMOCRACY/M/S +DEMOCRAT/M/S +DEMOCRATIC +DEMOCRATICALLY +DEMOGRAPHIC +DEMOLISH/D/S +DEMOLITION +DEMON/M/S +DEMONSTRABLE +DEMONSTRATE/D/G/N/X/V/S +DEMONSTRATIVELY +DEMONSTRATOR/M/S +DEMORALIZE/D/G/S +DEMUR +DEN/M/S +DENDRITE/S +DENIABLE +DENIAL/M/S +DENIGRATE/D/G/S +DENMARK +DENOMINATION/M/S +DENOMINATOR/M/S +DENOTABLE +DENOTATION/M/S +DENOTATIONAL/Y +DENOTE/D/G/S +DENOUNCE/D/G/S +DENSE/P/T/R/Y +DENSITY/M/S +DENT/D/G/S +DENTAL/Y +DENTIST/M/S +DENY/D/R/G/S +DEPART/D/G/S +DEPARTMENT/M/S +DEPARTMENTAL +DEPARTURE/M/S +DEPEND/D/G/S +DEPENDABILITY +DEPENDABLE +DEPENDABLY +DEPENDENCE +DEPENDENCY/S +DEPENDENT/Y/S +DEPICT/D/G/S +DEPLETE/D/G/N/X/S +DEPLORABLE +DEPLORE/D/S +DEPLOY/D/G/S +DEPLOYABLE +DEPLOYMENT/M/S +DEPORTATION +DEPORTMENT +DEPOSE/D/S +DEPOSIT/D/G/S +DEPOSITION/M/S +DEPOSITOR/M/S +DEPOT/M/S +DEPRAVE/D +DEPRECIATE/N/S +DEPRESS/D/G/S +DEPRESSION/M/S +DEPRIVATION/M/S +DEPRIVE/D/G/S +DEPT +DEPTH +DEPTHS +DEPUTY/M/S +DEQUEUE/D/G/S +DERAIL/D/G/S +DERBY +DERIDE +DERISION +DERIVABLE +DERIVATION/M/S +DERIVATIVE/M/S +DERIVE/D/G/S +DESCEND/D/R/Z/G/S +DESCENDANT/M/S +DESCENT/M/S +DESCRIBABLE +DESCRIBE/D/R/G/S +DESCRIPTION/M/S +DESCRIPTIVE/Y/S +DESCRIPTOR/M/S +DESCRY +DESELECTED +DESERT/D/R/Z/G/S +DESERTION/S +DESERVE/D/G/J/S +DESERVINGLY +DESIDERATA +DESIDERATUM +DESIGN/D/R/Z/G/S +DESIGNATE/D/G/N/X/S +DESIGNATOR/M/S +DESIGNER'S +DESIRABILITY +DESIRABLE +DESIRABLY +DESIRE/D/G/S +DESIROUS +DESK/M/S +DESOLATE/N/X/Y +DESPAIR/D/G/S +DESPAIRINGLY +DESPATCH/D +DESPERATE/N/Y +DESPISE/D/G/S +DESPITE +DESPOT/M/S +DESPOTIC +DESSERT/M/S +DESTINATION/M/S +DESTINE/D +DESTINY/M/S +DESTITUTE/N +DESTROY/D/G/S +DESTROYER/M/S +DESTRUCTION/M/S +DESTRUCTIVE/P/Y +DETACH/D/R/G/S +DETACHMENT/M/S +DETAIL/D/G/S +DETAIN/D/G/S +DETECT/D/G/V/S +DETECTABLE +DETECTABLY +DETECTION/M/S +DETECTIVES +DETECTOR/M/S +DETENTION +DETERIORATE/D/G/N/S +DETERMINABLE +DETERMINACY +DETERMINANT/M/S +DETERMINATE/N/X/V/Y +DETERMINE/D/R/Z/G/S +DETERMINISM +DETERMINISTIC +DETERMINISTICALLY +DETERRENT +DETEST/D +DETESTABLE +DETRACT/S +DETRACTOR/M/S +DETRIMENT +DETRIMENTAL +DEVASTATE/D/G/N/S +DEVELOP/D/R/Z/G/S +DEVELOPMENT/M/S +DEVELOPMENTAL +DEVIANT/M/S +DEVIATE/D/G/N/X/S +DEVICE/M/S +DEVIL/M/S +DEVILISH/Y +DEVISE/D/G/J/S +DEVOID +DEVOTE/D/G/N/X/S +DEVOTEDLY +DEVOTEE/M/S +DEVOUR/D/R/S +DEVOUT/P/Y +DEW +DEWDROP/M/S +DEWY +DEXTERITY +DIADEM +DIAGNOSABLE +DIAGNOSE/D/G/S +DIAGNOSIS +DIAGNOSTIC/M/S +DIAGONAL/Y/S +DIAGRAM/M/S +DIAGRAMMABLE +DIAGRAMMATIC +DIAGRAMMATICALLY +DIAGRAMMED +DIAGRAMMER/M/S +DIAGRAMMING +DIAL/D/G/S +DIALECT/M/S +DIALOG/M/S +DIALOGUE/M/S +DIAMETER/M/S +DIAMETRICALLY +DIAMOND/M/S +DIAPER/M/S +DIAPHRAGM/M/S +DIARY/M/S +DIATRIBE/M/S +DICE +DICHOTOMIZE +DICHOTOMY +DICKENS +DICKY +DICTATE/D/G/N/X/S +DICTATOR/M/S +DICTATORSHIP +DICTION +DICTIONARY/M/S +DICTUM/M/S +DID +DIDN'T +DIE/D/S +DIEGO +DIELECTRIC/M/S +DIET/R/Z/S +DIETITIAN/M/S +DIFFER/D/G/R/S/Z +DIFFERENCE/M/S +DIFFERENT/Y +DIFFERENTIAL/M/S +DIFFERENTIATE/D/G/N/X/S +DIFFERENTIATORS +DIFFICULT/Y +DIFFICULTY/M/S +DIFFUSE/D/R/Z/G/N/X/Y/S +DIG/S +DIGEST/D/G/V/S +DIGESTIBLE +DIGESTION +DIGGER/M/S +DIGGING/S +DIGIT/M/S +DIGITAL/Y +DIGITIZE/S/G/D +DIGNIFY/D +DIGNITY/S +DIGRESS/D/G/V/S +DIGRESSION/M/S +DIKE/M/S +DILATE/D/G/N/S +DILEMMA/M/S +DILIGENCE +DILIGENT/Y +DILUTE/D/G/N/S +DIM/P/Y/S +DIME/M/S +DIMENSION/D/G/S +DIMENSIONAL/Y +DIMENSIONALITY +DIMINISH/D/G/S +DIMINUTION +DIMINUTIVE +DIMMED +DIMMER/M/S +DIMMEST +DIMMING +DIMPLE/D +DIN +DINE/D/R/Z/G/S +DINGY/P +DINNER/M/S +DINT +DIODE/M/S +DIOPHANTINE +DIOXIDE +DIP/S +DIPHTHERIA +DIPLOMA/M/S +DIPLOMACY +DIPLOMAT/M/S +DIPLOMATIC +DIPPED +DIPPER/M/S +DIPPING/S +DIRE +DIRECT/P/D/G/Y/S +DIRECTION/M/S +DIRECTIONAL/Y +DIRECTIONALITY +DIRECTIVE/M/S +DIRECTOR/M/S +DIRECTORY/M/S +DIRGE/M/S +DIRT/S +DIRTILY +DIRTY/P/T/R +DISABILITY/M/S +DISABLE/D/R/Z/G/S +DISADVANTAGE/M/S +DISAGREE/D/S +DISAGREEABLE +DISAGREEING +DISAGREEMENT/M/S +DISALLOW/D/G/S +DISAMBIGUATE/D/G/N/X/S +DISAPPEAR/D/G/S +DISAPPEARANCE/M/S +DISAPPOINT/D/G +DISAPPOINTMENT/M/S +DISAPPROVAL +DISAPPROVE/D/S +DISARM/D/G/S +DISARMAMENT +DISASSEMBLE/D/G/S +DISASTER/M/S +DISASTROUS/Y +DISBAND/D/G/S +DISBURSE/D/G/S +DISBURSEMENT/M/S +DISC/M/S +DISCARD/D/G/S +DISCERN/D/G/S +DISCERNIBILITY +DISCERNIBLE +DISCERNIBLY +DISCERNINGLY +DISCERNMENT +DISCHARGE/D/G/S +DISCIPLE/M/S +DISCIPLINARY +DISCIPLINE/D/G/S +DISCLAIM/D/R/S +DISCLOSE/D/G/S +DISCLOSURE/M/S +DISCOMFORT +DISCONCERT +DISCONCERTING/Y +DISCONNECT/D/G/S +DISCONNECTION +DISCONTENT/D +DISCONTINUANCE +DISCONTINUE/D/S +DISCONTINUITY/M/S +DISCONTINUOUS +DISCORD +DISCOUNT/D/G/S +DISCOURAGE/D/G/S +DISCOURAGEMENT +DISCOURSE/M/S +DISCOVER/D/R/Z/G/S +DISCOVERY/M/S +DISCREDIT/D +DISCREET/Y +DISCREPANCY/M/S +DISCRETE/P/N/Y +DISCRIMINATE/D/G/N/S +DISCRIMINATORY +DISCUSS/D/G/S +DISCUSSION/M/S +DISDAIN/G/S +DISEASE/D/S +DISENGAGE/D/G/S +DISFIGURE/D/G/S +DISGORGE +DISGRACE/D/S +DISGRACEFUL/Y +DISGRUNTLED +DISGUISE/D/S +DISGUST/D/G/S +DISGUSTEDLY +DISGUSTINGLY +DISH/D/G/S +DISHEARTEN/G +DISHONEST/Y +DISHONOR/D/G/S +DISHWASHER/S +DISHWASHING +DISILLUSION/D/G +DISILLUSIONMENT/M/S +DISINTERESTED/P +DISJOINT/P/D +DISJUNCT/V/S +DISJUNCTION/S +DISJUNCTIVELY +DISK/M/S +DISKETTE/S +DISLIKE/D/G/S +DISLOCATE/D/G/N/X/S +DISLODGE/D +DISMAL/Y +DISMAY/D/G +DISMISS/D/R/Z/G/S +DISMISSAL/M/S +DISMOUNT/D/G/S +DISOBEDIENCE +DISOBEY/D/G/S +DISORDER/D/Y/S +DISORGANIZED +DISORIENTED +DISOWN/D/G/S +DISPARATE +DISPARITY/M/S +DISPATCH/D/R/Z/G/S +DISPEL/S +DISPELLED +DISPELLING +DISPENSATION +DISPENSE/D/R/Z/G/S +DISPERSE/D/G/N/X/S +DISPLACE/D/G/S +DISPLACEMENT/M/S +DISPLAY/D/G/S +DISPLEASE/D/G/S +DISPLEASURE +DISPOSABLE +DISPOSAL/M/S +DISPOSE/D/R/G/S +DISPOSITION/M/S +DISPROVE/D/G/S +DISPUTE/D/R/Z/G/S +DISQUALIFY/D/G/N/S +DISQUIET/G +DISREGARD/D/G/S +DISRUPT/D/G/V/S +DISRUPTION/M/S +DISSATISFACTION/M/S +DISSATISFIED +DISSEMINATE/D/G/N/S +DISSENSION/M/S +DISSENT/D/R/Z/G/S +DISSERTATION/M/S +DISSERVICE +DISSIDENT/M/S +DISSIMILAR +DISSIMILARITY/M/S +DISSIPATE/D/G/N/S +DISSOCIATE/D/G/N/S +DISSOLUTION/M/S +DISSOLVE/D/G/S +DISTAL/Y +DISTANCE/S +DISTANT/Y +DISTASTE/S +DISTASTEFUL/Y +DISTEMPER +DISTILL/D/R/Z/G/S +DISTILLATION +DISTINCT/P/Y +DISTINCTION/M/S +DISTINCTIVE/P/Y +DISTINGUISH/D/G/S +DISTINGUISHABLE +DISTORT/D/G/S +DISTORTION/M/S +DISTRACT/D/G/S +DISTRACTION/M/S +DISTRAUGHT +DISTRESS/D/G/S +DISTRIBUTE/D/G/N/V/S +DISTRIBUTION/M/S +DISTRIBUTIONAL +DISTRIBUTIVITY +DISTRIBUTOR/M/S +DISTRICT/M/S +DISTRUST/D +DISTURB/D/R/G/S +DISTURBANCE/M/S +DISTURBINGLY +DITCH/M/S +DITTO +DIVAN/M/S +DIVE/D/R/Z/G/S +DIVERGE/D/G/S +DIVERGENCE/M/S +DIVERGENT +DIVERSE/N/X/Y +DIVERSIFY/D/G/N/S +DIVERSITY/S +DIVERT/D/G/S +DIVEST/D/G/S +DIVIDE/D/R/Z/G/S +DIVIDEND/M/S +DIVINE/R/G/Y +DIVINITY/M/S +DIVISION/M/S +DIVISOR/M/S +DIVORCE/D +DIVULGE/D/G/S +DIZZY/P +DNA +DO/R/Z/G/J +DOCK/D/S +DOCTOR/D/S +DOCTORAL +DOCTORATE/M/S +DOCTRINE/M/S +DOCUMENT/D/R/Z/G/S +DOCUMENTARY/M/S +DOCUMENTATION/M/S +DODGE/D/R/Z/G +DOES +DOESN'T +DOG/M/S +DOGGED/P/Y +DOGGING +DOGMA/M/S +DOGMATISM +DOLE/D/S +DOLEFUL/Y +DOLL/M/S +DOLLAR/S +DOLLY/M/S +DOLPHIN/M/S +DOMAIN/M/S +DOME/D/S +DOMESTIC +DOMESTICALLY +DOMESTICATE/D/G/N/S +DOMINANCE +DOMINANT/Y +DOMINATE/D/G/N/S +DOMINION +DON'T +DON/S +DONALD/M +DONATE/D/G/S +DONE +DONKEY/M/S +DOOM/D/G/S +DOOR/M/S +DOORSTEP/M/S +DOORWAY/M/S +DOPE/D/R/Z/G/S +DORMANT +DORMITORY/M/S +DOSE/D/S +DOT/M/S +DOTE/D/G/S +DOTINGLY +DOTTED +DOTTING +DOUBLE/D/R/Z/G/S +DOUBLET/M/S +DOUBLY +DOUBT/D/R/Z/G/S +DOUBTABLE +DOUBTFUL/Y +DOUBTLESS/Y +DOUG/M +DOUGH +DOUGHNUT/M/S +DOUGLAS +DOVE/R/S +DOWN/D/Z/G/S +DOWNCAST +DOWNFALL/N +DOWNPLAY/D/G/S +DOWNRIGHT +DOWNSTAIRS +DOWNSTREAM +DOWNTOWN/S +DOWNWARD/S +DOWNY +DOZE/D/G/S +DOZEN/H/S +DR +DRAB +DRAFT/D/R/Z/G/S +DRAFTSMAN +DRAFTSMEN +DRAG/S +DRAGGED +DRAGGING +DRAGON/M/S +DRAGOON/D/S +DRAIN/D/R/G/S +DRAINAGE +DRAKE +DRAMA/M/S +DRAMATIC/S +DRAMATICALLY +DRAMATIST/M/S +DRANK +DRAPE/D/R/Z/S +DRAPERY/M/S +DRASTIC +DRASTICALLY +DRAUGHT/M/S +DRAW/R/Z/G/J/S +DRAWBACK/M/S +DRAWBRIDGE/M/S +DRAWL/D/G/S +DRAWN/P/Y +DREAD/D/G/S +DREADFUL/Y +DREAM/D/R/Z/G/S +DREAMILY +DREAMY +DREARY/P +DREGS +DRENCH/D/G/S +DRESS/D/R/Z/G/J/S +DRESSMAKER/M/S +DREW +DRIER/M/S +DRIFT/D/R/Z/G/S +DRILL/D/R/G/S +DRILY +DRINK/R/Z/G/S +DRINKABLE +DRIP/M/S +DRIVE/R/Z/G/S +DRIVEN +DRIVEWAY/M/S +DRONE/M/S +DROOP/D/G/S +DROP/M/S +DROPPED +DROPPER/M/S +DROPPING/M/S +DROUGHT/M/S +DROVE/R/Z/S +DROWN/D/G/J/S +DROWSY/P +DRUDGERY +DRUG/M/S +DRUGGIST/M/S +DRUM/M/S +DRUMMED +DRUMMER/M/S +DRUMMING +DRUNK/R/N/Y/S +DRUNKARD/M/S +DRUNKENNESS +DRY/D/T/G/Y/S +DUAL +DUALITY/M/S +DUANE/M +DUB/S +DUBBED +DUBIOUS/P/Y +DUCHESS/M/S +DUCHY +DUCK/D/G/S +DUE/S +DUEL/G/S +DUG +DUKE/M/S +DULL/P/D/T/R/G/S +DULLY +DULY +DUMB/P/T/R/Y +DUMBBELL/M/S +DUMMY/M/S +DUMP/D/R/G/S +DUMPLING +DUNCE/M/S +DUNE/M/S +DUNGEON/M/S +DUPLICATE/D/G/N/X/S +DUPLICATOR/M/S +DURABILITY/S +DURABLE +DURABLY +DURATION/M/S +DURING +DUSK +DUSKY/P +DUST/D/R/Z/G/S +DUSTY/T/R +DUTIFUL/P/Y +DUTY/M/S +DWARF/D/S +DWELL/D/R/Z/G/J/S +DWINDLE/D/G +DYE/D/R/Z/G/S +DYEING +DYNAMIC/S +DYNAMICAL +DYNAMICALLY +DYNAMITE/D/G/S +DYNASTY/M/S +EACH +EAGER/P/Y +EAGLE/M/S +EAR/D/H/S +EARL/M/S +EARLY/P/T/R +EARMARK/D/G/J/S +EARN/D/T/G/J/S +EARNER/M/S +EARNESTLY +EARNESTNESS +EARRING/M/S +EARTHEN +EARTHENWARE +EARTHLY/P +EARTHQUAKE/M/S +EARTHS +EARTHWORM/M/S +EASE/D/G/S +EASEMENT/M/S +EASILY +EAST/R +EASTERN/R/Z +EASTWARD/S +EASY/P/T/R +EAT/R/Z/G/N/J/S +EAVES +EAVESDROP/S +EAVESDROPPED +EAVESDROPPER/M/S +EAVESDROPPING +EBB/G/S +EBONY +ECCENTRIC/M/S +ECCENTRICITY/S +ECCLESIASTICAL +ECHO/D/G +ECHOES +ECHOIC +ECLIPSE/D/G/S +ECOLOGY +ECONOMIC/S +ECONOMICAL/Y +ECONOMIST/M/S +ECONOMIZE/D/R/Z/G/S +ECONOMY/M/S +ECSTASY +EDDY/M/S +EDGE/D/G/S +EDIBLE +EDICT/M/S +EDIFICE/M/S +EDIT/D/G/S +EDITION/M/S +EDITOR/M/S +EDITORIAL/Y/S +EDUCATE/D/G/N/X/S +EDUCATIONAL/Y +EDUCATOR/M/S +EDWARD/M +EEL/M/S +EERIE +EFFECT/D/G/V/S +EFFECTIVELY +EFFECTIVENESS +EFFECTOR/M/S +EFFECTUALLY +EFFEMINATE +EFFICACY +EFFICIENCY/S +EFFICIENT/Y +EFFIGY +EFFORT/M/S +EFFORTLESS/P/Y +EGG/D/G/S +EGO/S +EIGENVALUE/M/S +EIGHT/S +EIGHTEEN/H/S +EIGHTH/M/S +EIGHTY/H/S +EITHER +EJACULATE/D/G/N/X/S +EJECT/D/G/S +EKE/D/S +EL +ELABORATE/P/D/G/N/X/Y/S +ELABORATORS +ELAPSE/D/G/S +ELASTIC +ELASTICALLY +ELASTICITY +ELBOW/G/S +ELDER/Y/S +ELDEST +ELECT/D/G/V/S +ELECTION/M/S +ELECTIVES +ELECTOR/M/S +ELECTORAL +ELECTRIC +ELECTRICAL/P/Y +ELECTRICITY +ELECTRIFY/G/N +ELECTROCUTE/D/G/N/X/S +ELECTRODE/M/S +ELECTROLYTE/M/S +ELECTROLYTIC +ELECTRON/M/S +ELECTRONIC/S +ELECTRONICALLY +ELEGANCE +ELEGANT/Y +ELEGY +ELEMENT/M/S +ELEMENTAL/S +ELEMENTARY +ELEPHANT/M/S +ELEVATE/D/N/S +ELEVATOR/M/S +ELEVEN/H/S +ELF +ELICIT/D/G/S +ELIGIBILITY +ELIGIBLE +ELIMINATE/D/G/N/X/S +ELIMINATOR/S +ELISION +ELK/M/S +ELLIPSE/M/S +ELLIPSIS +ELLIPSOID/M/S +ELLIPSOIDAL +ELLIPTIC +ELLIPTICAL/Y +ELM/R/S +ELOQUENCE +ELOQUENT/Y +ELSE +ELSEWHERE +ELUCIDATE/D/G/N/S +ELUDE/D/G/S +ELUSIVE/P/Y +ELVES +ELWOOD +EMACIATED +EMACS +EMANATING +EMANCIPATION +EMBARK/D/S +EMBARRASS/D/G/S +EMBARRASSING/Y +EMBARRASSMENT +EMBASSY/M/S +EMBED/S +EMBEDDED +EMBEDDING +EMBELLISH/D/G/S +EMBELLISHMENT/M/S +EMBER +EMBLEM +EMBODIMENT/M/S +EMBODY/D/G/S +EMBRACE/D/G/S +EMBROIDER/D/S +EMBROIDERY/S +EMBRYO/M/S +EMBRYOLOGY +EMERALD/M/S +EMERGE/D/G/S +EMERGENCE +EMERGENCY/M/S +EMERGENT +EMERY +EMIGRANT/M/S +EMIGRATE/D/G/N/S +EMINENCE +EMINENT/Y +EMIT/S +EMITTED +EMOTION/M/S +EMOTIONAL/Y +EMPATHY +EMPEROR/M/S +EMPHASES +EMPHASIS +EMPHASIZE/D/G/S +EMPHATIC +EMPHATICALLY +EMPIRE/M/S +EMPIRICAL/Y +EMPIRICIST/M/S +EMPLOY/D/G/S +EMPLOYABLE +EMPLOYEE/M/S +EMPLOYER/M/S +EMPLOYMENT/M/S +EMPOWER/D/G/S +EMPRESS +EMPTILY +EMPTY/P/D/T/R/G/S +EMULATE/D/N/X/S +EMULATOR/M/S +ENABLE/D/R/Z/G/S +ENACT/D/G/S +ENACTMENT +ENAMEL/D/G/S +ENCAMP/D/G/S +ENCAPSULATE/D/G/N/S +ENCHANT/D/R/G/S +ENCHANTMENT +ENCIPHER/D/G/S +ENCIRCLE/D/S +ENCLOSE/D/G/S +ENCLOSURE/M/S +ENCODE/D/R/G/J/S +ENCOMPASS/D/G/S +ENCOUNTER/D/G/S +ENCOURAGE/D/G/S +ENCOURAGEMENT/S +ENCOURAGINGLY +ENCRYPT/D/G/S +ENCRYPTION +ENCUMBER/D/G/S +ENCYCLOPEDIA/M/S +ENCYCLOPEDIC +END/D/R/Z/G/J/S +ENDANGER/D/G/S +ENDEAR/D/G/S +ENDEAVOR/D/G/S +ENDLESS/P/Y +ENDORSE/D/G/S +ENDORSEMENT +ENDOW/D/G/S +ENDOWMENT/M/S +ENDPOINT/S +ENDURABLE +ENDURABLY +ENDURANCE +ENDURE/D/G/S +ENDURINGLY +ENEMA/M/S +ENEMY/M/S +ENERGETIC +ENERGY/S +ENFORCE/D/R/Z/G/S +ENFORCEMENT +ENGAGE/D/G/S +ENGAGEMENT/M/S +ENGAGINGLY +ENGENDER/D/G/S +ENGINE/M/S +ENGINEER/D/M/G/S +ENGLAND/R/Z +ENGLISH +ENGRAVE/D/R/G/J/S +ENGROSS/D/G +ENHANCE/D/G/S +ENHANCEMENT/M/S +ENIGMATIC +ENJOIN/D/G/S +ENJOY/D/G/S +ENJOYABLE +ENJOYABLY +ENJOYMENT +ENLARGE/D/R/Z/G/S +ENLARGEMENT/M/S +ENLIGHTEN/D/G +ENLIGHTENMENT +ENLIST/D/S +ENLISTMENT +ENLIVEN/D/G/S +ENMITY/S +ENNOBLE/D/G/S +ENNUI +ENORMITY/S +ENORMOUS/Y +ENOUGH +ENQUEUE/D/S +ENQUIRE/D/R/S +ENRAGE/D/G/S +ENRICH/D/G/S +ENROLL/D/G/S +ENROLLMENT/M/S +ENSEMBLE/M/S +ENSIGN/M/S +ENSLAVE/D/G/S +ENSNARE/D/G/S +ENSUE/D/G/S +ENSURE/D/R/Z/G/S +ENTAIL/D/G/S +ENTANGLE +ENTER/D/G/S +ENTERPRISE/G/S +ENTERTAIN/D/R/Z/G/S +ENTERTAININGLY +ENTERTAINMENT/M/S +ENTHUSIASM/S +ENTHUSIAST/M/S +ENTHUSIASTIC +ENTHUSIASTICALLY +ENTICE/D/R/Z/G/S +ENTIRE/Y +ENTIRETY/S +ENTITLE/D/G/S +ENTITY/M/S +ENTRANCE/D/S +ENTREAT/D +ENTREATY +ENTRENCH/D/G/S +ENTREPRENEUR/M/S +ENTROPY +ENTRUST/D/G/S +ENTRY/M/S +ENUMERABLE +ENUMERATE/D/G/N/V/S +ENUMERATOR/S +ENUNCIATION +ENVELOP/S +ENVELOPE/D/R/G/S +ENVIOUS/P/Y +ENVIRON/G/S +ENVIRONMENT/M/S +ENVIRONMENTAL +ENVISAGE/D/S +ENVISION/D/G/S +ENVOY/M/S +ENVY/D/S +EOF +EPAULET/M/S +EPHEMERAL +EPIC/M/S +EPIDEMIC/M/S +EPISCOPAL +EPISODE/M/S +EPISTEMOLOGICAL/Y +EPISTEMOLOGY +EPISTLE/M/S +EPITAPH +EPITAPHS +EPITAXIAL/Y +EPITHET/M/S +EPITOMIZE/D/G/S +EPOCH +EPOCHS +EPSILON +EQUAL/D/G/Y/S +EQUALITY/M/S +EQUALIZE/D/R/Z/G/S +EQUATE/D/G/N/X/S +EQUATOR/M/S +EQUATORIAL +EQUILIBRIUM/S +EQUIP/S +EQUIPMENT +EQUIPPED +EQUIPPING +EQUITABLE +EQUITABLY +EQUITY +EQUIVALENCE/S +EQUIVALENT/Y/S +ERA/M/S +ERADICATE/D/G/N/S +ERASABLE +ERASE/D/R/Z/G/S +ERASURE +ERE +ERECT/D/G/S +ERECTION/M/S +ERECTOR/M/S +ERGO +ERGONOMIC/S +ERMINE/M/S +ERR/D/G/S +ERRAND +ERRATIC +ERRINGLY +ERRONEOUS/P/Y +ERROR/M/S +ERUPTION +ESCALATE/D/G/N/S +ESCAPABLE +ESCAPADE/M/S +ESCAPE/D/G/S +ESCAPEE/M/S +ESCHEW/D/G/S +ESCORT/D/G/S +ESOTERIC +ESPECIAL/Y +ESPERANTO +ESPIONAGE +ESPOUSE/D/G/S +ESPRIT +ESPY +ESQUIRE/S +ESSAY/D/S +ESSENCE/M/S +ESSENTIAL/Y/S +ESTABLISH/D/G/S +ESTABLISHMENT/M/S +ESTATE/M/S +ESTEEM/D/G/S +ESTIMATE/D/G/N/X/S +ETA +ETC +ETERNAL/Y +ETERNITY/S +ETHER/M/S +ETHEREAL/Y +ETHERNET +ETHICAL/Y +ETHICS +ETHNIC +ETHNOCENTRIC +ETIQUETTE +ETYMOLOGICAL +ETYMOLOGY +EUNUCH +EUNUCHS +EUPHEMISM/M/S +EUPHORIA +EUROPE +EUROPEAN/S +EVACUATE/D/N +EVADE/D/G/S +EVALUATE/D/G/N/X/V/S +EVALUATOR/M/S +EVAPORATE/D/G/N/V +EVE/R +EVEN/P/D/Y/S +EVENHANDED/P/Y +EVENING/M/S +EVENT/M/S +EVENTFUL/Y +EVENTUAL/Y +EVENTUALITY/S +EVERGREEN +EVERLASTING/Y +EVERMORE +EVERY +EVERYBODY +EVERYDAY +EVERYONE/M +EVERYTHING +EVERYWHERE +EVICT/D/G/S +EVICTION/M/S +EVIDENCE/D/G/S +EVIDENT/Y +EVIL/Y/S +EVINCE/D/S +EVOKE/D/G/S +EVOLUTE/M/S +EVOLUTION/M/S +EVOLUTIONARY +EVOLVE/D/G/S +EWE/M/S +EXACERBATE/D/G/N/X/S +EXACT/P/D/G/Y/S +EXACTINGLY +EXACTION/M/S +EXACTITUDE +EXAGGERATE/D/G/N/X/S +EXALT/D/G/S +EXAM/M/S +EXAMINATION/M/S +EXAMINE/D/R/Z/G/S +EXAMPLE/M/S +EXASPERATE/D/G/N/S +EXCAVATE/D/G/N/X/S +EXCEED/D/G/S +EXCEEDINGLY +EXCEL/S +EXCELLED +EXCELLENCE/S +EXCELLENCY +EXCELLENT/Y +EXCELLING +EXCEPT/D/G/S +EXCEPTION/M/S +EXCEPTIONAL/Y +EXCERPT/D/S +EXCESS/V/S +EXCESSIVELY +EXCHANGE/D/G/S +EXCHANGEABLE +EXCHEQUER/M/S +EXCISE/D/G/N/S +EXCITABLE +EXCITATION/M/S +EXCITATORY +EXCITE/D/G/S +EXCITEDLY +EXCITEMENT +EXCITINGLY +EXCLAIM/D/R/Z/G/S +EXCLAMATION/M/S +EXCLUDE/D/G/S +EXCLUSION/S +EXCLUSIVE/P/Y +EXCLUSIVITY +EXCOMMUNICATE/D/G/N/S +EXCRETE/D/G/N/X/S +EXCURSION/M/S +EXCUSABLE +EXCUSABLY +EXCUSE/D/G/S +EXECUTABLE +EXECUTE/D/G/N/X/V/S +EXECUTIONAL +EXECUTIVE/M/S +EXECUTOR/M/S +EXEMPLAR +EXEMPLARY +EXEMPLIFY/D/R/Z/G/N/S +EXEMPT/D/G/S +EXERCISE/D/R/Z/G/S +EXERT/D/G/S +EXERTION/M/S +EXHALE/D/G/S +EXHAUST/D/G/V/S +EXHAUSTEDLY +EXHAUSTIBLE +EXHAUSTION +EXHAUSTIVELY +EXHIBIT/D/G/S +EXHIBITION/M/S +EXHIBITOR/M/S +EXHORTATION/M/S +EXILE/D/G/S +EXIST/D/G/S +EXISTENCE +EXISTENT +EXISTENTIAL/Y +EXISTENTIALISM +EXISTENTIALIST/M/S +EXIT/D/G/S +EXORBITANT/Y +EXOTIC +EXPAND/D/G/S +EXPANDABLE +EXPANDER/M/S +EXPANSE/N/X/V/S +EXPANSIONISM +EXPECT/D/G/S +EXPECTANCY +EXPECTANT/Y +EXPECTATION/M/S +EXPECTEDLY +EXPECTINGLY +EXPEDIENT/Y +EXPEDITE/D/G/S +EXPEDITION/M/S +EXPEDITIOUS/Y +EXPEL/S +EXPELLED +EXPELLING +EXPEND/D/G/S +EXPENDABLE +EXPENDITURE/M/S +EXPENSE/V/S +EXPENSIVELY +EXPERIENCE/D/G/S +EXPERIMENT/D/R/Z/G/S +EXPERIMENTAL/Y +EXPERIMENTATION/M/S +EXPERT/P/Y/S +EXPERTISE +EXPIRATION/M/S +EXPIRE/D/S +EXPLAIN/D/R/Z/G/S +EXPLAINABLE +EXPLANATION/M/S +EXPLANATORY +EXPLICIT/P/Y +EXPLODE/D/G/S +EXPLOIT/D/R/Z/G/S +EXPLOITABLE +EXPLOITATION/M/S +EXPLORATION/M/S +EXPLORATORY +EXPLORE/D/R/Z/G/S +EXPLOSION/M/S +EXPLOSIVE/Y/S +EXPONENT/M/S +EXPONENTIAL/Y/S +EXPONENTIATE/D/G/S +EXPONENTIATION/M/S +EXPORT/D/R/Z/G/S +EXPOSE/D/R/Z/G/S +EXPOSITION/M/S +EXPOSITORY +EXPOSURE/M/S +EXPOUND/D/R/G/S +EXPRESS/D/G/V/Y/S +EXPRESSIBILITY +EXPRESSIBLE +EXPRESSIBLY +EXPRESSION/M/S +EXPRESSIVELY +EXPRESSIVENESS +EXPULSION +EXPUNGE/D/G/S +EXQUISITE/P/Y +EXTANT +EXTEND/D/G/S +EXTENDIBLE +EXTENSIBILITY +EXTENSIBLE +EXTENSION/M/S +EXTENSIVE/Y +EXTENT/M/S +EXTENUATE/D/G/N +EXTERIOR/M/S +EXTERMINATE/D/G/N/S +EXTERNAL/Y +EXTINCT +EXTINCTION +EXTINGUISH/D/R/G/S +EXTOL +EXTRA/S +EXTRACT/D/G/S +EXTRACTION/M/S +EXTRACTOR/M/S +EXTRACURRICULAR +EXTRANEOUS/P/Y +EXTRAORDINARILY +EXTRAORDINARY/P +EXTRAPOLATE/D/G/N/X/S +EXTRAVAGANCE +EXTRAVAGANT/Y +EXTREMAL +EXTREME/Y/S +EXTREMIST/M/S +EXTREMITY/M/S +EXTRINSIC +EXUBERANCE +EXULT +EXULTATION +EYE/D/R/Z/G/S +EYEBROW/M/S +EYEGLASS/S +EYEING +EYELID/M/S +EYEPIECE/M/S +EYESIGHT +EYEWITNESS/M/S +FABLE/D/S +FABRIC/M/S +FABRICATE/D/G/N/S +FABULOUS/Y +FACADE/D/S +FACE/D/G/J/S +FACET/D/S +FACIAL +FACILE/Y +FACILITATE/D/G/S +FACILITY/M/S +FACSIMILE/M/S +FACT/M/S +FACTION/M/S +FACTO +FACTOR/D/G/S +FACTORIAL +FACTORIZATION/M/S +FACTORY/M/S +FACTUAL/Y +FACULTY/M/S +FADE/D/R/Z/G/S +FAG/S +FAHLMAN/M +FAHRENHEIT +FAIL/D/G/J/S +FAILURE/M/S +FAIN +FAINT/P/D/T/R/G/Y/S +FAIR/P/T/R/G/Y/S +FAIRY/M/S +FAIRYLAND +FAITH +FAITHFUL/P/Y +FAITHLESS/P/Y +FAITHS +FAKE/D/R/G/S +FALCON/R/S +FALL/G/N/S +FALLACIOUS +FALLACY/M/S +FALLIBILITY +FALLIBLE +FALSE/P/Y +FALSEHOOD/M/S +FALSIFY/D/G/N/S +FALSITY +FALTER/D/S +FAME/D/S +FAMILIAR/P/Y +FAMILIARITY/S +FAMILIARIZATION +FAMILIARIZE/D/G/S +FAMILY/M/S +FAMINE/M/S +FAMISH +FAMOUS/Y +FAN/M/S +FANATIC/M/S +FANCIER/M/S +FANCIFUL/Y +FANCILY +FANCY/P/D/T/G/S +FANG/M/S +FANNED +FANNING +FANTASTIC +FANTASY/M/S +FAR +FARADAY/M +FARAWAY +FARCE/M/S +FARE/D/G/S +FAREWELL/S +FARM/D/R/Z/G/S +FARMHOUSE/M/S +FARMINGTON +FARMYARD/M/S +FARTHER +FARTHEST +FARTHING +FASCINATE/D/G/N/S +FASHION/D/G/S +FASHIONABLE +FASHIONABLY +FAST/P/D/T/R/G/X/S +FASTEN/D/R/Z/G/J/S +FAT/P/S +FATAL/Y/S +FATALITY/M/S +FATE/D/S +FATHER/D/M/Y/S +FATHERLAND +FATHOM/D/G/S +FATIGUE/D/G/S +FATTEN/D/R/Z/G/S +FATTER +FATTEST +FAULT/D/G/S +FAULTLESS/Y +FAULTY +FAVOR/D/R/G/S +FAVORABLE +FAVORABLY +FAVORITE/S +FAWN/D/G/S +FEAR/D/G/S +FEARFUL/Y +FEARLESS/P/Y +FEASIBILITY +FEASIBLE +FEAST/D/G/S +FEAT/M/S +FEATHER/D/R/Z/G/S +FEATHERY +FEATURE/D/G/S +FEBRUARY/M/S +FED +FEDERAL/Y/S +FEDERATION +FEE/S +FEEBLE/P/T/R +FEEBLY +FEED/G/J/R/S/Z +FEEDBACK +FEEL/R/Z/G/J/S +FEELINGLY +FEET +FEIGN/D/G +FELICITY/S +FELINE +FELL/D/G +FELLOW/M/S +FELLOWSHIP/M/S +FELT/S +FEMALE/M/S +FEMININE +FEMININITY +FEMUR/M/S +FEN/S +FENCE/D/R/Z/G/S +FERMENT/D/G/S +FERMENTATION/M/S +FERN/M/S +FEROCIOUS/P/Y +FEROCITY +FERRITE +FERRY/D/S +FERTILE/Y +FERTILITY +FERTILIZATION +FERTILIZE/D/R/Z/G/S +FERVENT/Y +FERVOR/M/S +FESTIVAL/M/S +FESTIVE/Y +FESTIVITY/S +FETCH/D/G/S +FETCHINGLY +FETTER/D/S +FEUD/M/S +FEUDAL +FEUDALISM +FEVER/D/S +FEVERISH/Y +FEW/P/T/R +FIBER/M/S +FIBROSITY/S +FIBROUS/Y +FICKLE/P +FICTION/M/S +FICTIONAL/Y +FICTITIOUS/Y +FIDDLE/R/G/S +FIDELITY +FIELD/D/R/Z/G/S +FIEND +FIERCE/P/T/R/Y +FIERY +FIFE +FIFO +FIFTEEN/H/S +FIFTH +FIFTY/H/S +FIG/M/S +FIGHT/R/Z/G/S +FIGURATIVE/Y +FIGURE/D/G/J/S +FILAMENT/M/S +FILE/D/R/M/G/J/S +FILENAME/M/S +FILIAL +FILL/D/R/Z/G/J/S +FILLABLE +FILM/D/G/S +FILTER/D/M/G/S +FILTH +FILTHY/P/T/R +FIN/M/S +FINAL/Y/S +FINALITY +FINALIZATION +FINALIZE/D/G/S +FINANCE/D/G/S +FINANCIAL/Y +FINANCIER/M/S +FIND/R/Z/G/J/S +FINE/P/D/T/R/G/Y/S +FINGER/D/G/J/S +FINISH/D/R/Z/G/S +FINITE/P/Y +FIR +FIRE/D/R/Z/G/J/S +FIREARM/M/S +FIREFLY/M/S +FIRELIGHT +FIREMAN +FIREPLACE/M/S +FIRESIDE +FIREWOOD +FIREWORKS +FIRM/P/D/T/R/G/Y/S +FIRMAMENT +FIRMWARE +FIRST/Y/S +FIRSTHAND +FISCAL/Y +FISH/D/R/Z/G/S +FISHERMAN +FISHERY +FISSURE/D +FIST/D/S +FIT/P/Y/S +FITFUL/Y +FITTED +FITTER/M/S +FITTING/Y/S +FIVE/S +FIX/D/R/Z/G/J/S +FIXATE/D/G/N/X/S +FIXEDLY +FIXEDNESS +FIXNUM +FIXTURE/M/S +FLAG/M/S +FLAGGED +FLAGGING +FLAGRANT/Y +FLAKE/D/G/S +FLAME/D/R/Z/G/S +FLAMINGO +FLAMMABLE +FLANK/D/R/G/S +FLANNEL/M/S +FLAP/M/S +FLARE/D/G/S +FLASH/D/R/Z/G/S +FLASHLIGHT/M/S +FLASK +FLAT/P/Y/S +FLATTEN/D/G +FLATTER/D/R/G +FLATTERY +FLATTEST +FLAUNT/D/G/S +FLAVOR/D/G/J/S +FLAW/D/S +FLAWLESS/Y +FLAX/N +FLEA/M/S +FLED +FLEDGED +FLEDGLING/M/S +FLEE/S +FLEECE/M/S +FLEECY +FLEEING +FLEET/P/T/G/Y/S +FLESH/D/G/Y/S +FLESHY +FLEW +FLEXIBILITY/S +FLEXIBLE +FLEXIBLY +FLICK/D/R/G/S +FLICKERING +FLIGHT/M/S +FLINCH/D/G/S +FLING/M/S +FLINT +FLIP/S +FLIRT/D/G/S +FLIT +FLOAT/D/R/G/S +FLOCK/D/G/S +FLOOD/D/G/S +FLOOR/D/G/J/S +FLOP/M/S +FLOPPILY +FLOPPY +FLORA +FLORIDA +FLORIN +FLOSS/D/G/S +FLOUNDER/D/G/S +FLOUR/D +FLOURISH/D/G/S +FLOW/D/Z/G/S +FLOWCHART/G/S +FLOWER/D/G/S +FLOWERY/P +FLOWN +FLUCTUATE/G/N/X/S +FLUENT/Y +FLUFFY/T/R +FLUID/Y/S +FLUIDITY +FLUNG +FLURRY/D +FLUSH/D/G/S +FLUTE/D/G +FLUTTER/D/G/S +FLY/R/Z/G/S +FLYABLE +FLYER/M/S +FOAM/D/G/S +FOCAL/Y +FOCI +FOCUS/D/G/S +FODDER +FOE/M/S +FOG/M/S +FOGGED +FOGGILY +FOGGING +FOGGY/T/R +FOIL/D/G/S +FOLD/D/R/Z/G/S +FOLIAGE +FOLK/M/S +FOLKLORE +FOLLOW/D/R/Z/G/J/S +FOLLY/S +FOND/P/R/Y +FONDLE/D/G/S +FONT/M/S +FOOD/M/S +FOODSTUFF/M/S +FOOL/D/G/S +FOOLISH/P/Y +FOOLPROOF +FOOT/D/R/Z/G +FOOTBALL/M/S +FOOTHOLD +FOOTMAN +FOOTNOTE/M/S +FOOTPRINT/M/S +FOOTSTEP/S +FOR/H +FORAGE/D/G/S +FORAY/M/S +FORBADE +FORBEAR/M/S +FORBEARANCE +FORBES +FORBID/S +FORBIDDEN +FORBIDDING +FORCE/D/R/M/G/S +FORCEFUL/P/Y +FORCIBLE +FORCIBLY +FORD/S +FORE/T +FOREARM/M/S +FOREBODING +FORECAST/D/R/Z/G/S +FORECASTLE +FOREFATHER/M/S +FOREFINGER/M/S +FOREGO/G +FOREGOES +FOREGONE +FOREGROUND +FOREHEAD/M/S +FOREIGN/R/Z/S +FOREMAN +FOREMOST +FORENOON +FORESEE/S +FORESEEABLE +FORESEEN +FORESIGHT/D +FOREST/D/R/Z/S +FORESTALL/D/G/S +FORESTALLMENT +FORETELL/G/S +FORETOLD +FOREVER +FOREWARN/D/G/J/S +FORFEIT/D +FORGAVE +FORGE/D/R/G/S +FORGERY/M/S +FORGET/S +FORGETFUL/P +FORGETTABLE +FORGETTABLY +FORGETTING +FORGIVABLE +FORGIVABLY +FORGIVE/P/G/S +FORGIVEN +FORGIVINGLY +FORGOT +FORGOTTEN +FORK/D/G/S +FORLORN/Y +FORM/D/R/G/S +FORMAL/Y +FORMALISM/M/S +FORMALITY/S +FORMALIZATION/M/S +FORMALIZE/D/G/S +FORMANT/S +FORMAT/V/S +FORMATION/M/S +FORMATIVELY +FORMATTED +FORMATTER/M/S +FORMATTING +FORMERLY +FORMIDABLE +FORMULA/M/S +FORMULAE +FORMULATE/D/G/N/X/S +FORMULATOR/M/S +FORNICATION +FORSAKE/G/S +FORSAKEN +FORT/M/S +FORTE +FORTHCOMING +FORTHWITH +FORTIFY/D/G/N/X/S +FORTITUDE +FORTNIGHT/Y +FORTRAN +FORTRESS/M/S +FORTUITOUS/Y +FORTUNATE/Y +FORTUNE/M/S +FORTY/R/H/S +FORUM/M/S +FORWARD/P/D/R/G/S +FOSSIL +FOSTER/D/G/S +FOUGHT +FOUL/P/D/T/G/Y/S +FOUND/D/R/Z/G/S +FOUNDATION/M/S +FOUNDERED +FOUNDRY/M/S +FOUNT/M/S +FOUNTAIN/M/S +FOUR/H/S +FOURIER +FOURSCORE +FOURTEEN/H/S +FOWL/R/S +FOX/M/S +FRACTION/M/S +FRACTIONAL/Y +FRACTURE/D/G/S +FRAGILE +FRAGMENT/D/G/S +FRAGMENTARY +FRAGRANCE/M/S +FRAGRANT/Y +FRAIL/T +FRAILTY +FRAME/D/R/G/S +FRAMEWORK/M/S +FRANC/S +FRANCE/M/S +FRANCHISE/M/S +FRANCISCO +FRANK/P/D/T/R/G/Y/S +FRANTIC +FRANTICALLY +FRATERNAL/Y +FRATERNITY/M/S +FRAUD/M/S +FRAUGHT +FRAY/D/G/S +FREAK/M/S +FRECKLE/D/S +FREE/P/D/T/R/Y/S +FREEDOM/M/S +FREEING/S +FREEMAN +FREEZE/R/Z/G/S +FREIGHT/D/R/Z/G/S +FRENCH +FRENZY/D +FREQUENCY/S +FREQUENT/D/R/Z/G/Y/S +FRESH/P/T/R/X/Y +FRESHEN/D/R/Z/G/S +FRESHMAN +FRESHMEN +FRET +FRETFUL/P/Y +FRIAR/M/S +FRICATIVE/S +FRICTION/M/S +FRICTIONLESS +FRIDAY/M/S +FRIEND/M/S +FRIENDLESS +FRIENDLY/P/T/R +FRIENDSHIP/M/S +FRIEZE/M/S +FRIGATE/M/S +FRIGHT/X +FRIGHTEN/D/G/S +FRIGHTENINGLY +FRIGHTFUL/P/Y +FRILL/M/S +FRINGE/D +FRISK/D/G/S +FRIVOLOUS/Y +FROCK/M/S +FROG/M/S +FROLIC/S +FROM +FRONT/D/G/S +FRONTAL +FRONTIER/M/S +FROST/D/G/S +FROSTY +FROTH/G +FROWN/D/G/S +FROZE +FROZEN/Y +FRUGAL/Y +FRUIT/M/S +FRUITFUL/P/Y +FRUITION +FRUITLESS/Y +FRUSTRATE/D/G/N/X/S +FRY/D/S +FUDGE +FUEL/D/G/S +FUGITIVE/M/S +FUGUE +FULFILL/D/G/S +FULFILLMENT/S +FULL/P/T/R +FULLY +FUMBLE/D/G +FUME/D/G/S +FUN +FUNCTION/D/M/G/S +FUNCTIONAL/Y/S +FUNCTIONALITY/S +FUNCTOR/M/S +FUND/D/R/Z/G/S +FUNDAMENTAL/Y/S +FUNERAL/M/S +FUNGUS +FUNNEL/D/G/S +FUNNILY +FUNNY/P/T/R +FUR/M/S +FURIOUS/R/Y +FURNACE/M/S +FURNISH/D/G/J/S +FURNITURE +FURROW/D/S +FURTHER/D/G/S +FURTHERMORE +FURTIVE/P/Y +FURY/M/S +FUSE/D/G/N/S +FUSS/G +FUTILE +FUTILITY +FUTURE/M/S +FUZZY/P/R +GABARDINE +GABLE/D/R/S +GAD +GADGET/M/S +GAG/G/S +GAGGED +GAGGING +GAIETY/S +GAILY +GAIN/D/R/Z/G/S +GAIT/D/R/Z +GALAXY/M/S +GALE +GALL/D/G/S +GALLANT/Y/S +GALLANTRY +GALLERY/D/S +GALLEY/M/S +GALLON/M/S +GALLOP/D/R/G/S +GALLOWS +GAMBLE/D/R/Z/G/S +GAME/P/D/G/Y/S +GAMMA +GANG/M/S +GANGRENE +GANGSTER/M/S +GAP/M/S +GAPE/D/G/S +GARAGE/D/S +GARB/D +GARBAGE/M/S +GARDEN/D/R/Z/G/S +GARGLE/D/G/S +GARLAND/D +GARLIC +GARMENT/M/S +GARNER/D +GARNET +GARNISH +GARRISON/D +GARTER/M/S +GARY/M +GAS/M/S +GASEOUS/Y +GASH/M/S +GASOLINE +GASP/D/G/S +GASSED +GASSER +GASSING/S +GASTRIC +GASTROINTESTINAL +GATE/D/G/S +GATEWAY/M/S +GATHER/D/R/Z/G/J/S +GAUDY/P +GAUGE/D/S +GAUNT/P +GAUZE +GAVE +GAY/P/T/R/Y +GAZE/D/R/Z/G/S +GAZORCH/D/G +GCD +GEAR/D/G/S +GEESE +GEL/M/S +GELATIN +GELLED +GELLING +GEM/M/S +GENDER/M/S +GENE/M/S +GENERAL/Y/S +GENERALIST/M/S +GENERALITY/S +GENERALIZATION/M/S +GENERALIZE/D/R/Z/G/S +GENERATE/D/G/N/S/V/X +GENERATOR/M/S +GENERIC +GENERICALLY +GENEROSITY/M/S +GENEROUS/P/Y +GENETIC/S +GENETICALLY +GENEVA +GENIAL/Y +GENIUS/M/S +GENRE/M/S +GENTEEL +GENTLE/P/T/R +GENTLEMAN/Y +GENTLEWOMAN +GENTLY +GENTRY +GENUINE/P/Y +GENUS +GEOGRAPHIC +GEOGRAPHICAL/Y +GEOGRAPHY +GEOLOGICAL +GEOLOGIST/M/S +GEOMETRIC +GEOMETRICAL +GEOMETRY/S +GEORGETOWN +GERANIUM +GERM/M/S +GERMAN/M/S +GERMANE +GERMANY +GERMINATE/D/G/N/S +GESTALT +GESTURE/D/G/S +GET/S +GETTER/M/S +GETTING +GHASTLY +GHOST/D/Y/S +GIANT/M/S +GIBBERISH +GIDDY/P +GIFT/D/S +GIG +GIGANTIC +GIGGLE/D/G/S +GILD/D/G/S +GILL/M/S +GILT +GIMMICK/M/S +GIN/M/S +GINGER/Y +GINGERBREAD +GINGHAM/S +GIPSY/M/S +GIRAFFE/M/S +GIRD +GIRDER/M/S +GIRDLE +GIRL/M/S +GIRT +GIRTH +GIVE/R/Z/G/S +GIVEN +GLACIAL +GLACIER/M/S +GLAD/P/Y +GLADDER +GLADDEST +GLADE +GLAMOROUS +GLAMOUR +GLANCE/D/G/S +GLAND/M/S +GLARE/D/G/S +GLARINGLY +GLASS/D/S +GLASSY +GLAZE/D/R/G/S +GLEAM/D/G/S +GLEAN/D/R/G/J/S +GLEE/S +GLEEFUL/Y +GLEN/M/S +GLIDE/D/R/Z/S +GLIMMER/D/G/S +GLIMPSE/D/S +GLINT/D/G/S +GLISTEN/D/G/S +GLITCH/S +GLITTER/D/G/S +GLOBAL/Y +GLOBE/M/S +GLOBULAR +GLOBULARITY +GLOOM +GLOOMILY +GLOOMY +GLORIFY/D/N/S +GLORIOUS/Y +GLORY/G/S +GLOSS/D/G/S +GLOSSARY/M/S +GLOSSY +GLOTTAL +GLOVE/D/R/Z/G/S +GLOW/D/R/Z/G/S +GLOWINGLY +GLUE/D/G/S +GLYPH/S +GNAT/M/S +GNAW/D/G/S +GNU +GO/G/J +GOAD/D +GOAL/M/S +GOAT/M/S +GOATEE/M/S +GOBBLE/D/R/Z/S +GOBLET/M/S +GOBLIN/M/S +GOD/M/Y/S +GODDESS/M/S +GODLIKE +GODMOTHER/M/S +GOES +GOLD/G/N/S +GOLDENLY +GOLDENNESS +GOLDSMITH +GOLF/R/Z/G +GONE/R +GONG/M/S +GOOD/P/Y/S +GOODY/M/S +GOOSE +GORDON/M +GORE +GORGE/G/S +GORGEOUS/Y +GORILLA/M/S +GOSH +GOSLING/M +GOSPEL/Z/S +GOSSIP/D/G/S +GOT +GOTHIC +GOTO +GOTTEN +GOUGE/D/G/S +GOURD +GOVERN/D/G/S +GOVERNESS +GOVERNMENT/M/S +GOVERNMENTAL/Y +GOVERNOR/M/S +GOWN/D/S +GRAB/S +GRABBED +GRABBER/M/S +GRABBING/S +GRACE/D/G/S +GRACEFUL/P/Y +GRACIOUS/P/Y +GRAD +GRADATION/M/S +GRADE/D/R/Z/G/J/S +GRADIENT/M/S +GRADUAL/Y +GRADUATE/D/G/N/X/S +GRAFT/D/R/G/S +GRAHAM/M/S +GRAIN/D/G/S +GRAM/S +GRAMMAR/M/S +GRAMMATICAL/Y +GRANARY/M/S +GRAND/P/T/R/Y/S +GRANDEUR +GRANDFATHER/M/S +GRANDIOSE +GRANDMA +GRANDMOTHER/M/S +GRANDPA +GRANDPARENT/S/M +GRANDSON/M/S +GRANGE +GRANITE +GRANNY +GRANT/D/R/G/S +GRANULARITY +GRANULATE/D/G/S +GRAPE/M/S +GRAPH/D/M/G +GRAPHIC/S +GRAPHICAL/Y +GRAPHITE +GRAPHS +GRAPPLE/D/G +GRASP/D/G/S +GRASPABLE +GRASPING/Y +GRASS/D/Z/S +GRASSY/T/R +GRATE/D/R/G/J/S +GRATEFUL/P/Y +GRATIFY/D/G/N +GRATITUDE +GRATUITOUS/P/Y +GRATUITY/M/S +GRAVE/P/T/R/Y/S +GRAVEL/Y +GRAVITATION +GRAVITATIONAL +GRAVITY +GRAVY +GRAY/P/D/T/R/G +GRAZE/D/R/G +GREASE/D/S +GREASY +GREAT/P/T/R/Y +GREED +GREEDILY +GREEDY/P +GREEK/M/S +GREEN/P/T/R/G/Y/S +GREENHOUSE/M/S +GREENISH +GREET/D/R/G/J/S +GRENADE/M/S +GREW +GREY/T/G +GRID/M/S +GRIEF/M/S +GRIEVANCE/M/S +GRIEVE/D/R/Z/G/S +GRIEVINGLY +GRIEVOUS/Y +GRIFFIN +GRILL/D/G/S +GRIM/P/D/Y +GRIN/S +GRIND/R/Z/G/J/S +GRINDSTONE/M/S +GRIP/D/G/S +GRIPE/D/G/S +GRIPPED +GRIPPING/Y +GRIT/M/S +GRIZZLY +GROAN/D/R/Z/G/S +GROCER/M/S +GROCERY/S +GROOM/D/G/S +GROOVE/D/S +GROPE/D/G/S +GROSS/P/D/T/R/G/Y/S +GROTESQUE/Y/S +GROTTO/M/S +GROUND/D/R/Z/G/S +GROUNDWORK +GROUP/D/G/J/S +GROUSE +GROVE/R/Z/S +GROVEL/D/G/S +GROW/R/Z/G/H/S +GROWL/D/G/S +GROWN +GROWNUP/M/S +GROWTHS +GRUB/M/S +GRUDGE/M/S +GRUESOME +GRUFF/Y +GRUMBLE/D/G/S +GRUNT/D/G/S +GUARANTEE/D/R/Z/S +GUARANTEEING +GUARANTY +GUARD/D/G/S +GUARDEDLY +GUARDIAN/M/S +GUARDIANSHIP +GUERRILLA/M/S +GUESS/D/G/S +GUEST/M/S +GUIDANCE +GUIDE/D/G/S +GUIDEBOOK/M/S +GUIDELINE/M/S +GUILD/R +GUILE +GUILT +GUILTILY +GUILTLESS/Y +GUILTY/P/T/R +GUINEA +GUISE/M/S +GUITAR/M/S +GULCH/M/S +GULF/M/S +GULL/D/G/S +GULLY/M/S +GULP/D/S +GUM/M/S +GUN/M/S +GUNFIRE +GUNNED +GUNNER/M/S +GUNNING +GUNPOWDER +GURGLE +GUSH/D/R/G/S +GUST/M/S +GUT/S +GUTTER/D/S +GUY/D/G/S +GUYER/S +GYMNASIUM/M/S +GYMNAST/M/S +GYMNASTIC/S +GYPSY/M/S +GYROSCOPE/M/S +HA +HABIT/M/S +HABITAT/M/S +HABITATION/M/S +HABITUAL/P/Y +HACK/D/R/Z/G/S +HAD +HADN'T +HAG +HAGGARD/Y +HAIL/D/G/S +HAIR/M/S +HAIRCUT/M/S +HAIRDRYER/M/S +HAIRLESS +HAIRY/P/R +HALE/R +HALF +HALFTONE +HALFWAY +HALL/M/S +HALLMARK/M/S +HALLOW/D +HALLWAY/M/S +HALT/D/R/Z/G/S +HALTINGLY +HALVE/D/Z/G/S +HAM/M/S +HAMBURGER/M/S +HAMLET/M/S +HAMMER/D/G/S +HAMMOCK/M/S +HAMPER/D/S +HAND/D/G/S +HANDBAG/M/S +HANDBOOK/M/S +HANDCUFF/D/G/S +HANDFUL/S +HANDICAP/M/S +HANDICAPPED +HANDILY +HANDIWORK +HANDKERCHIEF/M/S +HANDLE/D/R/Z/G/S +HANDSOME/P/T/R/Y +HANDWRITING +HANDWRITTEN +HANDY/P/T/R +HANG/D/R/Z/G/S +HANGAR/M/S +HANGOVER/M/S +HAP/Y +HAPHAZARD/P/Y +HAPLESS/P/Y +HAPPEN/D/G/J/S +HAPPILY +HAPPY/P/T/R +HARASS/D/G/S +HARASSMENT +HARBOR/D/G/S +HARD/P/T/R/N/Y +HARDCOPY +HARDSHIP/M/S +HARDWARE +HARDWIRED +HARDY/P +HARE/M/S +HARK/N +HARLOT/M/S +HARM/D/G/S +HARMFUL/P/Y +HARMLESS/P/Y +HARMONIOUS/P/Y +HARMONIZE +HARMONY/S +HARNESS/D/G +HARP/R/Z/G +HARROW/D/G/S +HARRY/D/R +HARSH/P/R/Y +HART +HARVARD +HARVEST/D/R/G/S +HAS +HASH/D/R/G/S +HASN'T +HASTE/J +HASTEN/D/G/S +HASTILY +HASTY/P +HAT/M/S +HATCH/D/G +HATCHET/M/S +HATE/D/R/G/S +HATEFUL/P/Y +HATRED +HAUGHTILY +HAUGHTY/P +HAUL/D/R/G/S +HAUNCH/M/S +HAUNT/D/R/G/S +HAVE/G/S +HAVEN'T +HAVEN/M/S +HAVOC +HAWAII +HAWK/D/R/Z/S +HAY/G/S +HAZARD/M/S +HAZARDOUS +HAZE/M/S +HAZEL +HAZY/P +HE'D +HE'LL +HE/D/M/V +HEAD/D/R/Z/G/S +HEADACHE/M/S +HEADGEAR +HEADING/M/S +HEADLAND/M/S +HEADLINE/D/G/S +HEADLONG +HEADQUARTERS +HEADWAY +HEAL/D/R/Z/G/H/S +HEALTHFUL/P/Y +HEALTHILY +HEALTHY/P/T/R +HEALY/M +HEAP/D/G/S +HEAR/R/Z/G/H/J/S +HEARD +HEARKEN +HEARSAY +HEART/N/S +HEARTILY +HEARTLESS +HEARTY/P/T +HEAT/D/R/Z/G/S +HEATABLE +HEATEDLY +HEATH/R/N +HEAVE/D/R/Z/G/S +HEAVEN/Y/S +HEAVILY +HEAVY/P/T/R +HEBREW +HEDGE/D/S +HEDGEHOG/M/S +HEED/D/S +HEEDLESS/P/Y +HEEL/D/Z/G/S +HEIDELBERG +HEIFER +HEIGHT/X/S +HEIGHTEN/D/G/S +HEINOUS/Y +HEIR/M/S +HEIRESS/M/S +HELD +HELL/M/S +HELLO +HELM +HELMET/M/S +HELP/D/R/Z/G/S +HELPFUL/P/Y +HELPLESS/P/Y +HELVETICA +HEM/M/S +HEMISPHERE/M/S +HEMLOCK/M/S +HEMOSTAT/S +HEMP/N +HEN/M/S +HENCE +HENCEFORTH +HENCHMAN +HENCHMEN +HER/S +HERALD/D/G/S +HERB/M/S +HERBERT/M +HERBIVORE +HERBIVOROUS +HERD/D/R/G/S +HERE/M/S +HEREABOUT/S +HEREAFTER +HEREBY +HEREDITARY +HEREDITY +HEREIN +HEREINAFTER +HERESY +HERETIC/M/S +HERETOFORE +HEREWITH +HERITAGE/S +HERMIT/M/S +HERO +HEROES +HEROIC/S +HEROICALLY +HEROIN +HEROINE/M/S +HEROISM +HERON/M/S +HERRING/M/S +HERSELF +HESITANT/Y +HESITATE/D/G/N/X/S +HESITATINGLY +HETEROGENEITY +HETEROGENEOUS/P/Y +HEURISTIC/M/S +HEURISTICALLY +HEW/D/R/S +HEX +HEXAGONAL/Y +HEY +HIATUS +HICKORY +HID +HIDDEN +HIDE/G/S +HIDEOUS/P/Y +HIDEOUT/M/S +HIERARCHICAL/Y +HIERARCHY/M/S +HIGH/T/R/Y +HIGHLAND/R/S +HIGHLIGHT/D/G/S +HIGHNESS/M/S +HIGHWAY/M/S +HIKE/D/R/G/S +HILARIOUS/Y +HILL/M/S +HILLOCK +HILLSIDE +HILLTOP/M/S +HILT/M/S +HIM +HIMSELF +HIND/R/Z +HINDERED +HINDERING +HINDRANCE/S +HINDSIGHT +HINGE/D/S +HINT/D/G/S +HIP/M/S +HIRE/D/R/Z/G/J/S +HIS +HISS/D/G/S +HISTOGRAM/M/S +HISTORIAN/M/S +HISTORIC +HISTORICAL/Y +HISTORY/M/S +HIT/M/S +HITCH/D/G +HITCHHIKE/D/R/Z/G/S +HITHER +HITHERTO +HITTER/M/S +HITTING +HOAR +HOARD/R/G +HOARSE/P/Y +HOARY/P +HOBBLE/D/G/S +HOBBY/M/S +HOBBYIST/M/S +HOCKEY +HOE/M/S +HOG/M/S +HOIST/D/G/S +HOLD/R/Z/G/N/J/S +HOLE/D/S +HOLIDAY/M/S +HOLISTIC +HOLLAND +HOLLOW/P/D/G/Y/S +HOLLY +HOLOCAUST +HOLOGRAM/M/S +HOLY/P/S +HOMAGE +HOME/D/R/Z/G/Y/S +HOMELESS +HOMEMADE +HOMEMAKER/M/S +HOMEOMORPHIC +HOMEOMORPHISM/M/S +HOMESICK/P +HOMESPUN +HOMESTEAD/R/Z/S +HOMEWARD/S +HOMEWORK +HOMOGENEITY/M/S +HOMOGENEOUS/P/Y +HOMOMORPHIC +HOMOMORPHISM/M/S +HONE/D/T/R/G/S +HONESTLY +HONESTY +HONEY +HONEYCOMB/D +HONEYMOON/D/R/Z/G/S +HONEYSUCKLE +HONG +HONOLULU +HONOR/D/R/G/S +HONORABLE/P +HONORABLY +HONORARY/S +HOOD/D/S +HOODWINK/D/G/S +HOOF/M/S +HOOK/D/R/Z/G/S +HOOP/R/S +HOOT/D/R/G/S +HOOVER/M +HOP/S +HOPE/D/G/S +HOPEFUL/P/Y/S +HOPELESS/P/Y +HOPPER/M/S +HORDE/M/S +HORIZON/M/S +HORIZONTAL/Y +HORMONE/M/S +HORN/D/S +HORNET/M/S +HORRENDOUS/Y +HORRIBLE/P +HORRIBLY +HORRID/Y +HORRIFY/D/G/S +HORROR/M/S +HORSE/Y/S +HORSEBACK +HORSEMAN +HORSEPOWER +HORSESHOE/R +HOSE/M/S +HOSPITABLE +HOSPITABLY +HOSPITAL/M/S +HOSPITALITY +HOSPITALIZE/D/G/S +HOST/D/G/S +HOSTAGE/M/S +HOSTESS/M/S +HOSTILE/Y +HOSTILITY/S +HOT/P/Y +HOTEL/M/S +HOTTER +HOTTEST +HOUND/D/G/S +HOUR/Y/S +HOUSE/D/G/S +HOUSEFLY/M/S +HOUSEHOLD/R/Z/S +HOUSEKEEPER/M/S +HOUSEKEEPING +HOUSETOP/M/S +HOUSEWIFE/Y +HOUSEWORK +HOUSTON +HOVEL/M/S +HOVER/D/G/S +HOW +HOWARD +HOWEVER +HOWL/D/R/G/S +HUB/M/S +HUBRIS +HUDDLE/D/G +HUDSON +HUE/M/S +HUG +HUGE/P/Y +HUH +HULL/M/S +HUM/S +HUMAN/P/Y/S +HUMANE/P/Y +HUMANITY/M/S +HUMBLE/P/D/T/R/G +HUMBLY +HUMID/Y +HUMIDIFY/D/R/Z/G/N/S +HUMIDITY +HUMILIATE/D/G/N/X/S +HUMILITY +HUMMED +HUMMING +HUMOR/D/R/Z/G/S +HUMOROUS/P/Y +HUMP/D +HUNCH/D/S +HUNDRED/H/S +HUNG/R/Z +HUNGER/D/G +HUNGRILY +HUNGRY/T/R +HUNK/M/S +HUNT/D/R/Z/G/S +HUNTSMAN +HURL/D/R/Z/G +HURRAH +HURRICANE/M/S +HURRIEDLY +HURRY/D/G/S +HURT/G/S +HUSBAND/M/S +HUSBANDRY +HUSH/D/G/S +HUSK/D/R/G/S +HUSKY/P +HUSTLE/D/R/G/S +HUT/M/S +HYACINTH +HYATT +HYBRID +HYDRAULIC +HYDRODYNAMIC/S +HYDROGEN/M/S +HYGIENE +HYMN/M/S +HYPER +HYPERBOLIC +HYPERCUBE/S +HYPERMEDIA +HYPERTEXT +HYPERTEXTUAL +HYPHEN/M/S +HYPOCRISY/S +HYPOCRITE/M/S +HYPODERMIC/S +HYPOTHESES +HYPOTHESIS +HYPOTHESIZE/D/R/G/S +HYPOTHETICAL/Y +HYSTERESIS +HYSTERICAL/Y +I'D +I'LL +I'M +I'VE +IBM +ICE/D/G/J/S +ICEBERG/M/S +ICON/S +ICONIC +ICONOCLASTIC +ICY/P +IDEA/M/S +IDEAL/Y/S +IDEALISM +IDEALISTIC +IDEALIZATION/M/S +IDEALIZE/D/G/S +IDENTICAL/Y +IDENTIFIABLE +IDENTIFIABLY +IDENTIFY/D/R/Z/G/N/X/S +IDENTITY/M/S +IDEOLOGICAL/Y +IDEOLOGY/S +IDIOM/S +IDIOMATIC +IDIOSYNCRASY/M/S +IDIOSYNCRATIC +IDIOT/M/S +IDIOTIC +IDLE/P/D/T/R/G/S +IDLERS +IDLY +IDOL/M/S +IDOLATRY +IEEE +IF +IGNITION +IGNOBLE +IGNORANCE +IGNORANT/Y +IGNORE/D/G/S +III +ILL/S +ILLEGAL/Y +ILLEGALITY/S +ILLICIT/Y +ILLINOIS +ILLITERATE +ILLNESS/M/S +ILLOGICAL/Y +ILLUMINATE/D/G/N/X/S +ILLUSION/M/S +ILLUSIVE/Y +ILLUSTRATE/D/G/N/X/V/S +ILLUSTRATIVELY +ILLUSTRATOR/M/S +ILLUSTRIOUS/P +ILLY +IMAGE/G/S +IMAGINABLE +IMAGINABLY +IMAGINARY +IMAGINATION/M/S +IMAGINATIVE/Y +IMAGINE/D/G/J/S +IMBALANCE/S +IMITATE/D/G/N/X/V/S +IMMACULATE/Y +IMMATERIAL/Y +IMMATURE +IMMATURITY +IMMEDIACY/S +IMMEDIATE/Y +IMMEMORIAL +IMMENSE/Y +IMMERSE/D/N/S +IMMIGRANT/M/S +IMMIGRATE/D/G/N/S +IMMINENT/Y +IMMORTAL/Y +IMMORTALITY +IMMOVABILITY +IMMOVABLE +IMMOVABLY +IMMUNE +IMMUNITY/M/S +IMMUTABLE +IMP +IMPACT/D/G/S +IMPACTION +IMPACTOR/M/S +IMPAIR/D/G/S +IMPART/D/S +IMPARTIAL/Y +IMPASSE/V +IMPATIENCE +IMPATIENT/Y +IMPEACH +IMPEDANCE/M/S +IMPEDE/D/G/S +IMPEDIMENT/M/S +IMPEL +IMPENDING +IMPENETRABILITY +IMPENETRABLE +IMPENETRABLY +IMPERATIVE/Y/S +IMPERFECT/Y +IMPERFECTION/M/S +IMPERIAL +IMPERIALISM +IMPERIALIST/M/S +IMPERIL/D +IMPERIOUS/Y +IMPERMANENCE +IMPERMANENT +IMPERMISSIBLE +IMPERSONAL/Y +IMPERSONATE/D/G/N/X/S +IMPERTINENT/Y +IMPERVIOUS/Y +IMPETUOUS/Y +IMPETUS +IMPINGE/D/G/S +IMPIOUS +IMPLANT/D/G/S +IMPLAUSIBLE +IMPLEMENT/D/G/S +IMPLEMENTABLE +IMPLEMENTATION/M/S +IMPLEMENTOR/M/S +IMPLICANT/M/S +IMPLICATE/D/G/N/X/S +IMPLICIT/P/Y +IMPLORE/D/G +IMPLY/D/G/N/X/S +IMPORT/D/R/Z/G/S +IMPORTANCE +IMPORTANT/Y +IMPORTATION +IMPOSE/D/G/S +IMPOSITION/M/S +IMPOSSIBILITY/S +IMPOSSIBLE +IMPOSSIBLY +IMPOSTOR/M/S +IMPOTENCE +IMPOTENT +IMPOVERISH/D +IMPOVERISHMENT +IMPRACTICABLE +IMPRACTICAL/Y +IMPRACTICALITY +IMPRECISE/N/Y +IMPREGNABLE +IMPRESS/D/R/G/V/S +IMPRESSION/M/S +IMPRESSIONABLE +IMPRESSIONIST +IMPRESSIONISTIC +IMPRESSIVE/P/Y +IMPRESSMENT +IMPRINT/D/G/S +IMPRISON/D/G/S +IMPRISONMENT/M/S +IMPROBABLE +IMPROMPTU +IMPROPER/Y +IMPROVE/D/G/S +IMPROVEMENT/S +IMPROVISATION/M/S +IMPROVISATIONAL +IMPROVISE/D/R/Z/G/S +IMPUDENT/Y +IMPULSE/N/V/S +IMPUNITY +IMPURE +IMPURITY/M/S +IMPUTE/D +IN +INABILITY +INACCESSIBLE +INACCURACY/S +INACCURATE +INACTIVE +INACTIVITY +INADEQUACY/S +INADEQUATE/P/Y +INADMISSIBILITY +INADVERTENT/Y +INADVISABLE +INANIMATE/Y +INAPPLICABLE +INAPPROPRIATE/P +INASMUCH +INAUGURAL +INAUGURATE/D/G/N +INC +INCAPABLE +INCAPACITATING +INCARNATION/M/S +INCENDIARY/S +INCENSE/D/S +INCENTIVE/M/S +INCEPTION +INCESSANT/Y +INCH/D/G/S +INCIDENCE +INCIDENT/M/S +INCIDENTAL/Y/S +INCIPIENT +INCITE/D/G/S +INCLINATION/M/S +INCLINE/D/G/S +INCLOSE/D/G/S +INCLUDE/D/G/S +INCLUSION/M/S +INCLUSIVE/P/Y +INCOHERENT/Y +INCOME/G/S +INCOMMENSURATE +INCOMPARABLE +INCOMPARABLY +INCOMPATIBILITY/M/S +INCOMPATIBLE +INCOMPATIBLY +INCOMPETENCE +INCOMPETENT/M/S +INCOMPLETE/P/Y +INCOMPREHENSIBILITY +INCOMPREHENSIBLE +INCOMPREHENSIBLY +INCONCEIVABLE +INCONCLUSIVE +INCONSEQUENTIAL/Y +INCONSIDERATE/P/Y +INCONSISTENCY/M/S +INCONSISTENT/Y +INCONVENIENCE/D/G/S +INCONVENIENT/Y +INCORPORATE/D/G/N/S +INCORRECT/P/Y +INCREASE/D/G/S +INCREASINGLY +INCREDIBLE +INCREDIBLY +INCREDULOUS/Y +INCREMENT/D/G/S +INCREMENTAL/Y +INCUBATE/D/G/N/S +INCUBATOR/M/S +INCUR/S +INCURABLE +INCURRED +INCURRING +INDEBTED/P +INDECISION +INDEED +INDEFINITE/P/Y +INDEMNITY +INDENT/D/G/S +INDENTATION/M/S +INDEPENDENCE +INDEPENDENT/Y/S +INDESCRIBABLE +INDETERMINACY/M/S +INDETERMINATE/Y +INDEX/D/G/S +INDEXABLE +INDIA +INDIAN/M/S +INDIANA +INDICATE/D/G/N/X/V/S +INDICATOR/M/S +INDICES +INDICTMENT/M/S +INDIFFERENCE +INDIFFERENT/Y +INDIGENOUS/P/Y +INDIGESTION +INDIGNANT/Y +INDIGNATION +INDIGNITY/S +INDIGO +INDIRECT/D/G/Y/S +INDIRECTION/S +INDISCRIMINATE/Y +INDISPENSABILITY +INDISPENSABLE +INDISPENSABLY +INDISTINGUISHABLE +INDIVIDUAL/M/Y/S +INDIVIDUALISTIC +INDIVIDUALITY +INDIVIDUALIZE/D/G/S +INDIVISIBILITY +INDIVISIBLE +INDOCTRINATE/D/G/N/S +INDOLENT/Y +INDOMITABLE +INDOOR/S +INDUCE/D/R/G/S +INDUCEMENT/M/S +INDUCT/D/G/S +INDUCTANCE/S +INDUCTION/M/S +INDUCTIVE/Y +INDUCTOR/M/S +INDULGE/D/G +INDULGENCE/M/S +INDUSTRIAL/Y/S +INDUSTRIALIST/M/S +INDUSTRIALIZATION +INDUSTRIOUS/P/Y +INDUSTRY/M/S +INEFFECTIVE/P/Y +INEFFICIENCY/S +INEFFICIENT/Y +INELEGANT +INEQUALITY/S +INERT/P/Y +INERTIA +INESCAPABLE +INESCAPABLY +INESSENTIAL +INESTIMABLE +INEVITABILITY/S +INEVITABLE +INEVITABLY +INEXACT +INEXCUSABLE +INEXCUSABLY +INEXORABLE +INEXORABLY +INEXPENSIVE/Y +INEXPERIENCE/D +INEXPLICABLE +INFALLIBILITY +INFALLIBLE +INFALLIBLY +INFAMOUS/Y +INFANCY +INFANT/M/S +INFANTRY +INFEASIBLE +INFECT/D/G/V/S +INFECTION/M/S +INFECTIOUS/Y +INFER/S +INFERENCE/M/S +INFERENTIAL +INFERIOR/M/S +INFERIORITY +INFERNAL/Y +INFERNO/M/S +INFERRED +INFERRING +INFEST/D/G/S +INFIDEL/M/S +INFINITE/P/Y +INFINITESIMAL +INFINITIVE/M/S +INFINITUM +INFINITY +INFIRMITY +INFIX +INFLAME/D +INFLAMMABLE +INFLATABLE +INFLATE/D/G/N/S +INFLATIONARY +INFLEXIBILITY +INFLEXIBLE +INFLICT/D/G/S +INFLUENCE/D/G/S +INFLUENTIAL/Y +INFLUENZA +INFO +INFORM/D/R/Z/G/S +INFORMAL/Y +INFORMALITY +INFORMANT/M/S +INFORMATION +INFORMATIONAL +INFORMATIVE/Y +INFREQUENT/Y +INFRINGE/D/G/S +INFRINGEMENT/M/S +INFURIATE/D/G/N/S +INFUSE/D/G/N/X/S +INGENIOUS/P/Y +INGENUITY +INGRATITUDE +INGREDIENT/M/S +INGRES +INHABIT/D/G/S +INHABITABLE +INHABITANCE +INHABITANT/M/S +INHALE/D/R/G/S +INHERE/S +INHERENT/Y +INHERIT/D/G/S +INHERITABLE +INHERITANCE/M/S +INHERITOR/M/S +INHERITRESS/M/S +INHERITRICES +INHERITRIX +INHIBIT/D/G/S +INHIBITION/M/S +INHIBITORS +INHIBITORY +INHOMOGENEITY/S +INHUMAN +INHUMANE +INIQUITY/M/S +INITIAL/D/G/Y/S +INITIALIZATION/M/S +INITIALIZE/D/R/Z/G/S +INITIATE/D/G/N/X/V/S +INITIATIVE/M/S +INITIATOR/M/S +INJECT/D/G/V/S +INJECTION/M/S +INJUNCTION/M/S +INJURE/D/G/S +INJURIOUS +INJURY/M/S +INJUSTICE/M/S +INK/D/R/Z/G/J/S +INKLING/M/S +INLAID +INLAND +INLET/M/S +INLINE +INMATE/M/S +INN/R/G/J/S +INNARDS +INNATE/Y +INNERMOST +INNOCENCE +INNOCENT/Y/S +INNOCUOUS/P/Y +INNOVATE/N/X/V +INNOVATION/M/S +INNUMERABILITY +INNUMERABLE +INNUMERABLY +INORDINATE/Y +INPUT/M/S +INQUIRE/D/R/Z/G/S +INQUIRY/M/S +INQUISITION/M/S +INQUISITIVE/P/Y +INROAD/S +INSANE/Y +INSANITY +INSCRIBE/D/G/S +INSCRIPTION/M/S +INSECT/M/S +INSECURE/Y +INSENSIBLE +INSENSITIVE/Y +INSENSITIVITY +INSEPARABLE +INSERT/D/G/S +INSERTION/M/S +INSIDE/R/Z/S +INSIDIOUS/P/Y +INSIGHT/M/S +INSIGNIA +INSIGNIFICANCE +INSIGNIFICANT +INSINUATE/D/G/N/X/S +INSIST/D/G/S +INSISTENCE +INSISTENT/Y +INSOFAR +INSOLENCE +INSOLENT/Y +INSOLUBLE +INSPECT/D/G/S +INSPECTION/M/S +INSPECTOR/M/S +INSPIRATION/M/S +INSPIRE/D/R/G/S +INSTABILITY/S +INSTALL/D/R/Z/G/S +INSTALLATION/M/S +INSTALLMENT/M/S +INSTANCE/S +INSTANT/R/Y/S +INSTANTANEOUS/Y +INSTANTIATE/D/G/N/X/S +INSTANTIATION/M/S +INSTEAD +INSTIGATE/D/G/S +INSTIGATOR/M/S +INSTINCT/M/V/S +INSTINCTIVELY +INSTITUTE/D/R/Z/G/N/X/S +INSTITUTIONAL/Y +INSTITUTIONALIZE/D/G/S +INSTRUCT/D/G/V/S +INSTRUCTION/M/S +INSTRUCTIONAL +INSTRUCTIVELY +INSTRUCTOR/M/S +INSTRUMENT/D/G/S +INSTRUMENTAL/Y/S +INSTRUMENTALIST/M/S +INSTRUMENTATION +INSUFFICIENT/Y +INSULATE/D/G/N/S +INSULATOR/M/S +INSULT/D/G/S +INSUPERABLE +INSURANCE +INSURE/D/R/Z/G/S +INSURGENT/M/S +INSURMOUNTABLE +INSURRECTION/M/S +INTACT +INTANGIBLE/M/S +INTEGER/M/S +INTEGRAL/M/S +INTEGRATE/D/G/N/X/V/S +INTEGRITY +INTELLECT/M/S +INTELLECTUAL/Y/S +INTELLIGENCE +INTELLIGENT/Y +INTELLIGIBILITY +INTELLIGIBLE +INTELLIGIBLY +INTEND/D/G/S +INTENSE/V/Y +INTENSIFY/D/R/Z/G/N/S +INTENSITY/S +INTENSIVELY +INTENT/P/Y/S +INTENTION/D/S +INTENTIONAL/Y +INTER +INTERACT/D/G/V/S +INTERACTION/M/S +INTERACTIVELY +INTERACTIVITY +INTERCEPT/D/G/S +INTERCHANGE/D/G/J/S +INTERCHANGEABILITY +INTERCHANGEABLE +INTERCHANGEABLY +INTERCITY +INTERCOMMUNICATE/D/G/N/S +INTERCONNECT/D/G/S +INTERCONNECTION/M/S +INTERCOURSE +INTERDEPENDENCE +INTERDEPENDENCY/S +INTERDEPENDENT +INTERDISCIPLINARY +INTEREST/D/G/S +INTERESTINGLY +INTERFACE/D/R/G/S +INTERFERE/D/G/S +INTERFERENCE/S +INTERFERINGLY +INTERIM +INTERIOR/M/S +INTERLACE/D/G/S +INTERLEAVE/D/G/S +INTERLINK/D/S +INTERLISP +INTERMEDIARY +INTERMEDIATE/M/S +INTERMINABLE +INTERMINGLE/D/G/S +INTERMITTENT/Y +INTERMIXED +INTERMODULE +INTERN/D/S +INTERNAL/Y/S +INTERNALIZE/D/G/S +INTERNATIONAL/Y +INTERNATIONALITY +INTERNET +INTERNIST +INTERPERSONAL +INTERPLAY +INTERPOLATE/D/G/N/X/S +INTERPOSE/D/G/S +INTERPRET/D/R/Z/G/V/S +INTERPRETABLE +INTERPRETATION/M/S +INTERPRETIVELY +INTERPROCESS +INTERRELATE/D/G/N/X/S +INTERRELATIONSHIP/M/S +INTERROGATE/D/G/N/X/V/S +INTERRUPT/D/G/V/S +INTERRUPTIBLE +INTERRUPTION/M/S +INTERSECT/D/G/S +INTERSECTION/M/S +INTERSPERSE/D/G/N/S +INTERSTAGE +INTERSTATE +INTERTEXUALITY +INTERTWINE/D/G/S +INTERVAL/M/S +INTERVENE/D/G/S +INTERVENTION/M/S +INTERVIEW/D/R/Z/G/S +INTERWOVEN +INTESTINAL +INTESTINE/M/S +INTIMACY +INTIMATE/D/G/N/X/Y +INTIMIDATE/D/G/N/S +INTO +INTOLERABLE +INTOLERABLY +INTOLERANCE +INTOLERANT +INTONATION/M/S +INTOXICATE/D/G/N +INTRA +INTRACTABILITY +INTRACTABLE +INTRACTABLY +INTRAMURAL +INTRANSIGENT +INTRANSITIVE/Y +INTRAPROCESS +INTRICACY/S +INTRICATE/Y +INTRIGUE/D/G/S +INTRINSIC +INTRINSICALLY +INTRODUCE/D/G/S +INTRODUCTION/M/S +INTRODUCTORY +INTROSPECT/V +INTROSPECTION/S +INTROVERT/D +INTRUDE/D/R/G/S +INTRUDER/M/S +INTRUSION/M/S +INTRUST +INTUBATE/D/N/S +INTUITION/M/S +INTUITIONIST +INTUITIVE/Y +INTUITIVENESS +INVADE/D/R/Z/G/S +INVALID/Y/S +INVALIDATE/D/G/N/X/S +INVALIDITY/S +INVALUABLE +INVARIABLE +INVARIABLY +INVARIANCE +INVARIANT/Y/S +INVASION/M/S +INVENT/D/G/V/S +INVENTION/M/S +INVENTIVELY +INVENTIVENESS +INVENTOR/M/S +INVENTORY/M/S +INVERSE/N/X/Y/S +INVERT/D/R/Z/G/S +INVERTEBRATE/M/S +INVERTIBLE +INVEST/D/G/S +INVESTIGATE/D/G/N/X/V/S +INVESTIGATOR/M/S +INVESTMENT/M/S +INVESTOR/M/S +INVINCIBLE +INVISIBILITY +INVISIBLE +INVISIBLY +INVITATION/M/S +INVITE/D/G/S +INVOCABLE +INVOCATION/M/S +INVOICE/D/G/S +INVOKE/D/R/G/S +INVOLUNTARILY +INVOLUNTARY +INVOLVE/D/G/S +INVOLVEMENT/M/S +INWARD/P/Y/S +IODINE +ION/S +IPC +IQ +IRATE/P/Y +IRE/M/S +IRELAND/M +IRIS +IRK/D/G/S +IRKSOME +IRON/D/G/J/S +IRONICAL/Y +IRONY/S +IRRATIONAL/Y/S +IRRECOVERABLE +IRREDUCIBLE +IRREDUCIBLY +IRREFLEXIVE +IRREFUTABLE +IRREGULAR/Y/S +IRREGULARITY/S +IRRELEVANCE/S +IRRELEVANT/Y +IRREPRESSIBLE +IRRESISTIBLE +IRRESPECTIVE/Y +IRRESPONSIBLE +IRRESPONSIBLY +IRREVERSIBLE +IRRIGATE/D/G/N/S +IRRITATE/D/G/N/X/S +IS +ISLAND/R/Z/S +ISLE/M/S +ISLET/M/S +ISN'T +ISOLATE/D/G/N/X/S +ISOMETRIC +ISOMORPHIC +ISOMORPHICALLY +ISOMORPHISM/M/S +ISOTOPE/M/S +ISRAEL +ISSUANCE +ISSUE/D/R/Z/G/S +ISTHMUS +IT/M +ITALIAN/M/S +ITALIC/S +ITALICIZE/D +ITALY +ITCH/G/S +ITEM/M/S +ITEMIZATION/M/S +ITEMIZE/D/G/S +ITERATE/D/G/N/X/V/S +ITERATIVE/Y +ITERATOR/M/S +ITS +ITSELF +ITT +IV +IVORY +IVY/M/S +JAB/M/S +JABBED +JABBING +JACK +JACKET/D/S +JADE/D +JAIL/D/R/Z/G/S +JAM/S +JAMES +JAMMED +JAMMING +JANITOR/M/S +JANUARY/M/S +JAPAN +JAPANESE +JAR/M/S +JARGON +JARRED +JARRING/Y +JASMINE/M +JAUNDICE +JAUNT/M/S +JAUNTY/P +JAVELIN/M/S +JAW/M/S +JAY +JAZZ +JEALOUS/Y +JEALOUSY/S +JEAN/M/S +JEEP/M/S +JEER/M/S +JELLY/M/S +JELLYFISH +JENNY +JEOPARDIZE/D/G/S +JERK/D/G/J/S +JERKY/P +JERSEY/M/S +JEST/D/R/G/S +JET/M/S +JETTED +JETTING +JEWEL/D/R/S +JEWELRY/S +JIG/M/S +JILL +JIM/M +JINGLE/D/G +JOAN/M +JOB/M/S +JOCUND +JOE/M +JOG/S +JOHN/M +JOIN/D/R/Z/G/S +JOINT/M/Y/S +JOKE/D/R/Z/G/S +JOLLY +JOLT/D/G/S +JOSE/M +JOSTLE/D/G/S +JOT/S +JOTTED +JOTTING +JOURNAL/M/S +JOURNALISM +JOURNALIST/M/S +JOURNALIZE/D/G/S +JOURNEY/D/G/J/S +JOUST/D/G/S +JOY/M/S +JOYFUL/Y +JOYOUS/P/Y +JOYSTICK +JR +JUBILEE +JUDGE/D/G/S +JUDGMENT/M/S +JUDICABLE +JUDICIAL +JUDICIARY +JUDICIOUS/Y +JUDY/M +JUG/M/S +JUGGLE/R/Z/G/S +JUICE/M/S +JUICY/T +JULY/M/S +JUMBLE/D/S +JUMP/D/R/Z/G/S +JUMPY +JUNCTION/M/S +JUNCTURE/M/S +JUNE +JUNGLE/M/S +JUNIOR/M/S +JUNIPER +JUNK/R/Z/S +JURISDICTION/M/S +JUROR/M/S +JURY/M/S +JUST/P/Y +JUSTICE/M/S +JUSTIFIABLE +JUSTIFIABLY +JUSTIFIER'S +JUSTIFY/D/R/Z/G/N/X/S +JUT +JUVENILE/M/S +JUXTAPOSE/D/G/S +KAISER +KANJI +KEEL/D/G/S +KEEN/P/T/R/Y +KEEP/R/Z/G/S +KEN +KENNEL/M/S +KEPT +KERCHIEF/M/S +KERNEL/M/S +KERNING +KEROSENE +KETCHUP +KETTLE/M/S +KEY/D/G/S +KEYBOARD/M/S +KEYNOTE +KEYPAD/M/S +KEYSTROKE/M/S +KEYWORD/M/S +KICK/D/R/Z/G/S +KID/M/S +KIDDED +KIDDING +KIDNAP/S/R/D/G/M +KIDNAPPED +KIDNAPPER/M/S +KIDNAPPING/M/S +KIDNEY/M/S +KILL/D/R/Z/G/J/S +KILLINGLY +KILOGRAM/S +KILOMETER/S +KIN +KIND/P/T/R/Y/S +KINDERGARTEN +KINDHEARTED +KINDLE/D/G/S +KINDRED +KING/Y/S +KINGDOM/M/S +KINSHIP +KINSMAN +KISS/D/R/Z/G/S +KIT/M/S +KITCHEN/M/S +KITE/D/G/S +KITTEN/M/S +KITTY +KLUDGES +KNACK +KNAPSACK/M/S +KNAVE/M/S +KNEAD/S +KNEE/D/S +KNEEING +KNEEL/D/G/S +KNELL/M/S +KNELT +KNEW +KNICKERBOCKER/M/S +KNIFE/D/G/S +KNIGHT/D/G/Y/S +KNIGHTHOOD +KNIT/S +KNIVES +KNOB/M/S +KNOCK/D/R/Z/G/S +KNOLL/M/S +KNOT/M/S +KNOTTED +KNOTTING +KNOW/R/G/S +KNOWABLE +KNOWHOW +KNOWINGLY +KNOWLEDGE +KNOWLEDGEABLE +KNOWN +KNUCKLE/D/S +KONG +KYOTO +LAB/M/S +LABEL/S/D/R/G/M +LABOR/D/R/Z/G/J/S +LABORATORY/M/S +LABORIOUS/Y +LABYRINTH +LABYRINTHS +LACE/D/G/S +LACERATE/D/G/N/X/S +LACK/D/G/S +LACQUER/D/S +LAD/G/N/S +LADDER +LADLE +LADY/M/S +LAG/R/Z/S +LAGOON/M/S +LAGRANGIAN +LAID +LAIN +LAIR/M/S +LAKE/M/S +LAMB/M/S +LAMBDA +LAME/P/D/G/Y/S +LAMENT/D/G/S +LAMENTABLE +LAMENTATION/M/S +LAMINAR +LAMP/M/S +LANCE/D/R/S +LANCHESTER +LAND/D/R/Z/G/J/S +LANDLADY/M/S +LANDLORD/M/S +LANDMARK/M/S +LANDOWNER/M/S +LANDSCAPE/D/G/S +LANE/M/S +LANGUAGE/M/S +LANGUID/P/Y +LANGUISH/D/G/S +LANSING +LANTERN/M/S +LAP/M/S +LAPEL/M/S +LAPIDARY +LAPSE/D/G/S +LARD/R +LARGE/P/T/R/Y +LARK/M/S +LARVA +LARVAE +LAS +LASER/M/S +LASH/D/G/J/S +LASS/M/S +LAST/D/G/Y/S +LATCH/D/G/S +LATE/P/T/R/Y +LATENCY +LATENT +LATERAL/Y +LATITUDE/M/S +LATRINE/M/S +LATTER/Y +LATTICE/M/S +LAUGH/D/G +LAUGHABLE +LAUGHABLY +LAUGHINGLY +LAUGHS +LAUGHTER +LAUNCH/D/R/G/J/S +LAUNDER/D/R/G/J/S +LAUNDRY +LAURA/M +LAUREL/M/S +LAVA +LAVATORY/M/S +LAVENDER +LAVISH/D/G/Y +LAW/M/S +LAWFUL/Y +LAWLESS/P +LAWN/M/S +LAWRENCE/M +LAWSUIT/M/S +LAWYER/M/S +LAY/G/S +LAYER/D/G/S +LAYMAN +LAYMEN +LAYOFFS +LAYOUT/M/S +LAZED +LAZILY +LAZING +LAZY/P/T/R +LEAD/D/R/Z/G/N/J/S +LEADERSHIP/M/S +LEAF/D/G +LEAFLESS +LEAFLET/M/S +LEAFY/T +LEAGUE/D/R/Z/S +LEAK/D/G/S +LEAKAGE/M/S +LEAN/P/D/T/R/G/S +LEAP/D/G/S +LEAPT +LEARN/D/R/Z/G/S +LEASE/D/G/S +LEASH/M/S +LEAST +LEATHER/D/S +LEATHERN +LEAVE/D/G/J/S +LEAVEN/D/G +LECTURE/D/R/Z/G/S +LED +LEDGE/R/Z/S +LEE/R/S +LEECH/M/S +LEFT +LEFTIST/M/S +LEFTMOST +LEFTOVER/M/S +LEFTWARD +LEG/S +LEGACY/M/S +LEGAL/Y +LEGALITY +LEGALIZATION +LEGALIZE/D/G/S +LEGEND/M/S +LEGENDARY +LEGGED +LEGGINGS +LEGIBILITY +LEGIBLE +LEGIBLY +LEGION/M/S +LEGISLATE/D/G/N/V/S +LEGISLATOR/M/S +LEGISLATURE/M/S +LEGITIMACY +LEGITIMATE/Y +LEGUME/S +LEISURE/Y +LEMMA/M/S +LEMON/M/S +LEMONADE +LEND/R/Z/G/S +LENGTH/N/Y +LENGTHEN/D/G/S +LENGTHS +LENGTHWISE +LENGTHY +LENIENCY +LENIENT/Y +LENS/M/S +LENT/N +LENTIL/M/S +LEOPARD/M/S +LEPROSY +LESS/R +LESSEN/D/G/S +LESSON/M/S +LEST/R +LET/M/S +LETTER/D/R/G/S +LETTING +LETTUCE +LEUKEMIA +LEVEE/M/S +LEVEL/P/D/R/G/Y/S/T +LEVELLED +LEVELLER +LEVELLEST +LEVELLING +LEVER/M/S +LEVERAGE +LEVY/D/G/S +LEWD/P/Y +LEXIA/S +LEXICAL/Y +LEXICOGRAPHIC +LEXICOGRAPHICAL/Y +LEXICON/M/S +LIABILITY/M/S +LIABLE +LIAISON/M/S +LIAR/M/S +LIBERAL/Y/S +LIBERALIZE/D/G/S +LIBERATE/D/G/N/S +LIBERATOR/M/S +LIBERTY/M/S +LIBIDO +LIBRARIAN/M/S +LIBRARY/M/S +LICENSE/D/G/S +LICHEN/M/S +LICK/D/G/S +LID/M/S +LIE/D/S +LIEGE +LIEN/M/S +LIEU +LIEUTENANT/M/S +LIFE/R +LIFELESS/P +LIFELIKE +LIFELONG +LIFESTYLE/S +LIFETIME/M/S +LIFT/D/R/Z/G/S +LIGHT/P/D/T/G/N/X/Y/S +LIGHTER/M/S +LIGHTHOUSE/M/S +LIGHTNING/M/S +LIGHTWEIGHT +LIKE/D/G/S +LIKELIHOOD/S +LIKELY/P/T/R +LIKEN/D/G/S +LIKENESS/M/S +LIKEWISE +LILAC/M/S +LILY/M/S +LIMB/R/S +LIME/M/S +LIMESTONE +LIMIT/D/R/Z/G/S +LIMITABILITY +LIMITABLY +LIMITATION/M/S +LIMITLESS +LIMP/P/D/G/Y/S +LINDA/M +LINDEN +LINE'S +LINE/D/R/Z/G/J/S +LINEAR/Y +LINEARITY/S +LINEARIZABLE +LINEARIZE/D/G/S +LINEFEED +LINEN/M/S +LINGER/D/G/S +LINGUIST/M/S +LINGUISTIC/S +LINGUISTICALLY +LINK/D/R/G/S +LINKAGE/M/S +LINOLEUM +LINSEED +LION/M/S +LIONESS/M/S +LIP/M/S +LIPSTICK +LIQUEFY/D/R/Z/G/S +LIQUID/M/S +LIQUIDATION/M/S +LIQUIDITY +LIQUIFY/D/R/Z/G/S +LISBON +LISP/D/M/G/S +LIST/D/R/Z/G/X/S +LISTEN/D/R/Z/G/S +LISTING/M/S +LIT/R/Z +LITERACY +LITERAL/P/Y/S +LITERARY +LITERATE +LITERATURE/M/S +LITHE +LITTER/D/G/S +LITTLE/P/T/R +LIVABLE +LIVABLY +LIVE/P/D/R/Z/G/Y/S +LIVELIHOOD +LIVERY/D +LIZARD/M/S +LOAD/D/R/Z/G/J/S +LOAF/D/R +LOAN/D/G/S +LOATH/Y +LOATHE/D/G +LOATHSOME +LOAVES +LOBBY/D/S +LOBE/M/S +LOBSTER/M/S +LOCAL/Y/S +LOCALITY/M/S +LOCALIZATION +LOCALIZE/D/G/S +LOCATE/D/G/N/X/V/S +LOCATIVES +LOCATOR/M/S +LOCI +LOCK/D/R/Z/G/J/S +LOCKOUT/M/S +LOCKUP/M/S +LOCOMOTION +LOCOMOTIVE/M/S +LOCUS +LOCUST/M/S +LODGE/D/R/G/J/S +LOFT/M/S +LOFTY/P +LOG/M/S +LOGARITHM/M/S +LOGGED +LOGGER/M/S +LOGGING +LOGIC/M/S +LOGICAL/Y +LOGICIAN/M/S +LOGISTIC/S +LOIN/M/S +LOITER/D/R/G/S +LONDON +LONE/R/Z +LONELY/P/T/R +LONESOME +LONG/D/T/R/G/J/S +LONGITUDE/M/S +LOOK/D/R/Z/G/S +LOOKAHEAD +LOOKOUT +LOOKUP/M/S +LOOM/D/G/S +LOON +LOOP/D/G/S +LOOPHOLE/M/S +LOOSE/P/D/T/R/G/Y/S +LOOSEN/D/G/S +LOOT/D/R/G/S +LORD/Y/S +LORDSHIP +LORE +LORRY +LOSE/R/Z/G/S +LOSS/M/S +LOSSAGE +LOSSY/T/R +LOST +LOT/M/S +LOTTERY +LOUD/P/T/R/Y +LOUDSPEAKER/M/S +LOUNGE/D/G/S +LOUSY +LOVABLE +LOVABLY +LOVE/D/R/Z/G/S +LOVELY/P/T/R/S +LOVINGLY +LOW/P/T/Y/S +LOWER/D/G/S +LOWERCASE +LOWLAND/S +LOWLIEST +LOYAL/Y +LOYALTY/M/S +LTD +LUBRICANT/M +LUBRICATION +LUCID +LUCK/D/S +LUCKILY +LUCKLESS +LUCKY/T/R +LUDICROUS/P/Y +LUGGAGE +LUKEWARM +LULL/D/S +LULLABY +LUMBER/D/G +LUMINOUS/Y +LUMP/D/G/S +LUNAR +LUNATIC +LUNCH/D/G/S +LUNCHEON/M/S +LUNG/D/S +LURCH/D/G/S +LURE/D/G/S +LURK/D/G/S +LUSCIOUS/P/Y +LUST/R/S +LUSTILY +LUSTROUS +LUSTY/P +LUTE/M/S +LUXURIANT/Y +LUXURIOUS/Y +LUXURY/M/S +LYING +LYMPH +LYNCH/D/R/S +LYNX/M/S +LYRE +LYRIC/S +MA'AM +MACE/D/S +MACH +MACHINE/D/M/G/S +MACHINERY +MACLACHLAN/M +MACRO/M/S +MACROECONOMICS +MACROMOLECULAR +MACROMOLECULE/M/S +MACROSCOPIC +MACROSTEP/S +MACROSTRUCTURE +MAD/P/Y +MADAM +MADDEN/G +MADDER +MADDEST +MADE +MADEMOISELLE +MADISON +MADMAN +MADRAS +MAGAZINE/M/S +MAGGOT/M/S +MAGIC +MAGICAL/Y +MAGICIAN/M/S +MAGISTRATE/M/S +MAGNESIUM +MAGNET +MAGNETIC +MAGNETISM/M/S +MAGNIFICENCE +MAGNIFICENT/Y +MAGNIFY/D/R/G/N/S +MAGNITUDE/M/S +MAHOGANY +MAID/N/X/S +MAIL/D/R/G/J/S +MAILABLE +MAILBOX/M/S +MAIM/D/G/S +MAIN/Y/S +MAINE +MAINFRAME/M/S +MAINLAND +MAINSTAY +MAINSTREAM +MAINTAIN/D/R/Z/G/S +MAINTAINABILITY +MAINTAINABLE +MAINTENANCE/M/S +MAIZE +MAJESTIC +MAJESTY/M/S +MAJOR/D/S +MAJORITY/M/S +MAKABLE +MAKE/R/Z/G/J/S +MAKESHIFT +MAKEUP/S +MALADY/M/S +MALARIA +MALE/P/M/S +MALEFACTOR/M/S +MALFUNCTION/D/G/S +MALICE +MALICIOUS/P/Y +MALIGNANT/Y +MALLET/M/S +MALNUTRITION +MALT/D/S +MAMA +MAMMA/M/S +MAMMAL/M/S +MAMMOTH +MAN/M/Y/S +MANAGE/D/R/Z/G/S +MANAGEABLE/P +MANAGEMENT/M/S +MANAGER/M/S +MANAGERIAL +MANDATE/D/G/S +MANDATORY +MANDIBLE +MANE/M/S +MANEUVER/D/G/S +MANGER/M/S +MANGLE/D/R/G/S +MANHOOD +MANIAC/M/S +MANICURE/D/G/S +MANIFEST/D/G/Y/S +MANIFESTATION/M/S +MANIFOLD/M/S +MANILA +MANIPULABILITY +MANIPULABLE +MANIPULATABLE +MANIPULATE/D/G/N/X/V/S +MANIPULATOR/M/S +MANIPULATORY +MANKIND +MANNED +MANNER/D/Y/S +MANNING +MANOMETER/M/S +MANOR/M/S +MANPOWER +MANSION/M/S +MANTEL/M/S +MANTISSA/M/S +MANTLE/M/S +MANUAL/M/Y/S +MANUFACTURE/D/R/Z/G/S +MANUFACTURER/M/S +MANURE +MANUSCRIPT/M/S +MANY +MAP/M/S +MAPLE/M/S +MAPPABLE +MAPPED +MAPPING/M/S +MAR/S +MARBLE/G/S +MARC/M +MARCH/D/R/G/S +MARE/M/S +MARGIN/M/S +MARGINAL/Y +MARIGOLD +MARIJUANA +MARINE/R/S +MARIO/M +MARITAL +MARITIME +MARK/D/R/Z/G/J/S +MARKABLE +MARKEDLY +MARKET/D/G/J/S +MARKETABILITY +MARKETABLE +MARKETPLACE/M/S +MARKOV +MARQUIS +MARRIAGE/M/S +MARROW +MARRY/D/G/S +MARSH/M/S +MARSHAL/D/G/S +MART/N/S +MARTHA/M +MARTIAL +MARTIN/M +MARTYR/M/S +MARTYRDOM +MARVEL/D/S/G +MARVELLED +MARVELLING +MARVELOUS/P/Y +MARVIN/M +MARY/M +MARYLAND +MASCULINE/Y +MASCULINITY +MASH/D/G/S +MASK/D/R/G/J/S +MASOCHIST/M/S +MASON/M/S +MASONRY +MASQUERADE/R/G/S +MASS/D/G/V/S +MASSACHUSETTS +MASSACRE/D/S +MASSAGE/G/S +MASSIVE/Y +MAST/D/Z/S +MASTER/D/M/G/Y/J/S +MASTERFUL/Y +MASTERPIECE/M/S +MASTERY +MASTURBATE/D/G/N/S +MAT/M/S +MATCH/D/R/Z/G/J/S +MATCHABLE +MATCHLESS +MATE/D/R/M/G/J/S +MATERIAL/Y/S +MATERIALIZE/D/G/S +MATERNAL/Y +MATH +MATHEMATICAL/Y +MATHEMATICIAN/M/S +MATHEMATICS +MATRICES +MATRICULATION +MATRIMONY +MATRIX +MATRON/Y +MATTED +MATTER/D/S +MATTRESS/M/S +MATURATION +MATURE/D/G/Y/S +MATURITY/S +MAURICE/M +MAX +MAXIM/M/S +MAXIMAL/Y +MAXIMIZE/D/R/Z/G/S +MAXIMUM/S +MAY +MAYBE +MAYHAP +MAYHEM +MAYONNAISE +MAYOR/M/S +MAYORAL +MAZE/M/S +MCDONALD/M +ME +MEAD +MEADOW/M/S +MEAGER/P/Y +MEAL/M/S +MEAN/P/T/R/Y/S +MEANDER/D/G/S +MEANING/M/S +MEANINGFUL/P/Y +MEANINGLESS/P/Y +MEANT +MEANTIME +MEANWHILE +MEASLES +MEASURABLE +MEASURABLY +MEASURE/D/R/G/S +MEASUREMENT/M/S +MEAT/M/S +MECHANIC/M/S +MECHANICAL/Y +MECHANISM/M/S +MECHANIZATION/M/S +MECHANIZE/D/G/S +MEDAL/M/S +MEDALLION/M/S +MEDDLE/D/R/G/S +MEDIA +MEDIAN/M/S +MEDIATE/D/G/N/X/S +MEDIC/M/S +MEDICAL/Y +MEDICINAL/Y +MEDICINE/M/S +MEDIEVAL +MEDIOCRE +MEDITATE/D/G/N/X/V/S +MEDIUM/M/S +MEDUSA +MEEK/P/T/R/Y +MEET/G/J/S +MELANCHOLY +MELLON/M +MELLOW/P/D/G/S +MELODIOUS/P/Y +MELODRAMA/M/S +MELODY/M/S +MELON/M/S +MELT/D/G/S +MELTINGLY +MEMBER/M/S +MEMBERSHIP/M/S +MEMBRANE +MEMO/M/S +MEMOIR/S +MEMORABLE/P +MEMORANDA +MEMORANDUM +MEMORIAL/Y/S +MEMORIZATION +MEMORIZE/D/R/G/S +MEMORY/M/S +MEMORYLESS +MEN/M/S +MENACE/D/G +MENAGERIE +MEND/D/R/G/S +MENIAL/S +MENTAL/Y +MENTALITY/S +MENTION/D/R/Z/G/S +MENTIONABLE +MENTOR/M/S +MENU/M/S +MERCATOR +MERCENARY/P/M/S +MERCHANDISE/R/G +MERCHANT/M/S +MERCIFUL/Y +MERCILESS/Y +MERCURY +MERCY +MERE/T/Y +MERGE/D/R/Z/G/S +MERIDIAN +MERIT/D/G/S +MERITORIOUS/P/Y +MERRILY +MERRIMENT +MERRY/T +MESH +MESS/D/G/S +MESSAGE/M/S +MESSENGER/M/S +MESSIAH +MESSIAHS +MESSIEURS +MESSILY +MESSY/P/T/R +MET/S +META +METACIRCULAR +METACIRCULARITY +METACLASS/S +METAL/M/S +METALANGUAGE +METALLIC +METALLIZATION/S +METALLURGY +METAMATHEMATICAL +METAMORPHOSIS +METAPHOR/M/S +METAPHORICAL/Y +METAPHYSICAL/Y +METAPHYSICS +METAVARIABLE +METE/D/R/Z/G/S +METEOR/M/S +METEORIC +METEOROLOGY +METERING +METHOD/M/S +METHODICAL/P/Y +METHODIST/M/S +METHODOLOGICAL/Y +METHODOLOGISTS +METHODOLOGY/M/S +METRIC/M/S +METRICAL +METROPOLIS +METROPOLITAN +MEW/D/S +MICA +MICE +MICHAEL/M +MICHIGAN +MICRO +MICROBICIDAL +MICROBICIDE +MICROBIOLOGY +MICROCODE/D/G/S +MICROCOMPUTER/M/S +MICROECONOMICS +MICROFILM/M/S +MICROINSTRUCTION/M/S +MICROPHONE/G/S +MICROPROCESSING +MICROPROCESSOR/M/S +MICROPROGRAM/M/S +MICROPROGRAMMED +MICROPROGRAMMING +MICROSCOPE/M/S +MICROSCOPIC +MICROSECOND/M/S +MICROSOFT +MICROSTEP/S +MICROSTORE +MICROSTRUCTURE +MICROSYSTEM/S +MICROWORD/S +MID +MIDDAY +MIDDLE/G/S +MIDNIGHT/S +MIDPOINT/M/S +MIDST/S +MIDSUMMER +MIDWAY +MIDWEST +MIDWINTER +MIEN +MIGHT +MIGHTILY +MIGHTY/P/T/R +MIGRATE/D/G/N/X/S +MIKE/M +MILANO +MILD/P/T/R/Y +MILDEW +MILE/M/S +MILEAGE +MILESTONE/M/S +MILITANT/Y +MILITARILY +MILITARISM +MILITARY +MILITIA +MILK/D/R/Z/G/S +MILKMAID/M/S +MILKY/P +MILL/D/R/G/S +MILLET +MILLIMETER/S +MILLION/H/S +MILLIONAIRE/M/S +MILLIPEDE/M/S +MILLISECOND/S +MILLSTONE/M/S +MIMIC/S +MIMICKED +MIMICKING +MINCE/D/G/S +MIND/D/G/S +MINDFUL/P/Y +MINDLESS/Y +MINE/D/R/Z/G/N/S +MINERAL/M/S +MINGLE/D/G/S +MINI +MINIATURE/M/S +MINIATURIZATION +MINIATURIZE/D/G/S +MINICOMPUTER/M/S +MINIMA +MINIMAL/Y +MINIMIZATION/M/S +MINIMIZE/D/R/Z/G/S +MINIMUM +MINISTER/D/M/G/S +MINISTRY/M/S +MINK/M/S +MINNEAPOLIS +MINNESOTA/M +MINNOW/M/S +MINOR/M/S +MINORITY/M/S +MINSKY/M +MINSTREL/M/S +MINT/D/R/G/S +MINUS +MINUTE/P/R/Y/S +MIRACLE/M/S +MIRACULOUS/Y +MIRAGE +MIRE/D/S +MIRROR/D/G/S +MIRTH +MISBEHAVING +MISCALCULATION/M/S +MISCELLANEOUS/P/Y +MISCHIEF +MISCHIEVOUS/P/Y +MISCONCEPTION/M/S +MISCONSTRUE/D/S +MISER/Y/S +MISERABLE/P +MISERABLY +MISERY/M/S +MISFIT/M/S +MISFORTUNE/M/S +MISGIVING/S +MISHAP/M/S +MISINTERPRETATION +MISJUDGMENT +MISLEAD/G/S +MISLED +MISMATCH/D/G/S +MISNOMER +MISPLACE/D/G/S +MISREPRESENTATION/M/S +MISS/D/G/V/S +MISSILE/M/S +MISSION/R/S +MISSIONARY/M/S +MISSPELL/D/G/J/S +MIST/D/R/Z/G/S +MISTAKABLE +MISTAKE/G/S +MISTAKEN/Y +MISTRESS +MISTRUST/D +MISTY/P +MISTYPE/D/G/S +MISUNDERSTAND/R/Z/G +MISUNDERSTANDING/M/S +MISUNDERSTOOD +MISUSE/D/G/S +MIT/R/M +MITIGATE/D/G/N/V/S +MITTEN/M/S +MIX/D/R/Z/G/S +MIXTURE/M/S +MNEMONIC/M/S +MNEMONICALLY +MOAN/D/S +MOAT/M/S +MOB/M/S +MOCCASIN/M/S +MOCK/D/R/G/S +MOCKERY +MODAL/Y +MODALITY/M/S +MODE/T/S +MODEL/D/G/J/S/M +MODEM +MODERATE/P/D/G/N/Y/S +MODERATOR/M/S +MODERN/P/Y/S +MODERNISM +MODERNITY +MODERNIZE/D/R/G +MODESTLY +MODESTY +MODIFIABILITY +MODIFIABLE +MODIFY/D/R/Z/G/N/X/S +MODULAR/Y +MODULARITY +MODULARIZATION +MODULARIZE/D/G/S +MODULATE/D/G/N/X/S +MODULATOR/M/S +MODULE/M/S +MODULO +MODULUS +MODUS +MOHAWK +MOIST/P/N/Y +MOISTURE +MOLASSES +MOLD/D/R/G/S +MOLE/T/S +MOLECULAR +MOLECULE/M/S +MOLEST/D/G/S +MOLTEN +MOMENT/M/S +MOMENTARILY +MOMENTARY/P +MOMENTOUS/P/Y +MOMENTUM +MONARCH +MONARCHS +MONARCHY/M/S +MONASTERY/M/S +MONASTIC +MONDAY/M/S +MONETARY +MONEY/D/S +MONITOR/D/G/S +MONK/M/S +MONKEY/D/G/S +MONOCHROME +MONOGRAM/M/S +MONOGRAPH/M/S +MONOGRAPHS +MONOLITHIC +MONOPOLY/M/S +MONOTHEISM +MONOTONE +MONOTONIC +MONOTONICALLY +MONOTONICITY +MONOTONOUS/P/Y +MONOTONY +MONSTER/M/S +MONSTROUS/Y +MONTANA/M +MONTH/Y +MONTHS +MONUMENT/M/S +MONUMENTAL/Y +MOOD/M/S +MOODY/P +MOON/D/G/S +MOONLIGHT/R/G +MOONLIT +MOONSHINE +MOOR/D/G/J/S +MOOSE +MOOT +MOP/D/S +MORAL/Y/S +MORALE +MORALITY/S +MORASS +MORBID/P/Y +MORE/S +MOREOVER +MORN/G/J +MORPHISM/S +MORPHOLOGICAL +MORPHOLOGY +MORROW +MORSEL/M/S +MORTAL/Y/S +MORTALITY +MORTAR/D/G/S +MORTGAGE/M/S +MORTIFY/D/G/N/S +MOSAIC/M/S +MOSQUITO/S +MOSQUITOES +MOSS/M/S +MOSSY +MOST/Y +MOTEL/M/S +MOTH/Z +MOTHER'S +MOTHER/D/R/Z/G/Y/S +MOTIF/M/S +MOTION/D/G/S +MOTIONLESS/P/Y +MOTIVATE/D/G/N/X/S +MOTIVATIONAL +MOTIVE/S +MOTLEY +MOTOR/G/S +MOTORCAR/M/S +MOTORCYCLE/M/S +MOTORIST/M/S +MOTORIZE/D/G/S +MOTOROLA/M +MOTTO/S +MOTTOES +MOULD/G +MOUND/D/S +MOUNT/D/R/G/J/S +MOUNTAIN/M/S +MOUNTAINEER/G/S +MOUNTAINOUS/Y +MOURN/D/R/Z/G/S +MOURNFUL/P/Y +MOUSE/R/S +MOUTH/D/G +MOUTHFUL +MOUTHS +MOVABLE +MOVE/D/R/Z/G/J/S +MOVEMENT/M/S +MOVIE/M/S +MOW/D/R/S +MR +MRS +MS +MUCH +MUCK/R/G +MUD +MUDDLE/D/R/Z/G/S +MUDDY/P/D +MUFF/M/S +MUFFIN/M/S +MUFFLE/D/R/G/S +MUG/M/S +MULBERRY/M/S +MULE/M/S +MULTI +MULTICELLULAR +MULTIDIMENSIONAL +MULTILEVEL +MULTINATIONAL +MULTIPLE/M/S +MULTIPLEX/D/G/S +MULTIPLEXOR/M/S +MULTIPLICAND/M/S +MULTIPLICATIVE/S +MULTIPLICITY +MULTIPLY/D/R/Z/G/N/X/S +MULTIPROCESS/G +MULTIPROCESSOR/M/S +MULTIPROGRAM +MULTIPROGRAMMED +MULTIPROGRAMMING +MULTIPURPOSE +MULTISTAGE +MULTITUDE/M/S +MULTIVARIATE +MUMBLE/D/R/Z/G/J/S +MUMMY/M/S +MUNCH/D/G +MUNDANE/Y +MUNICIPAL/Y +MUNICIPALITY/M/S +MUNITION/S +MURAL +MURDER/D/R/Z/G/S +MURDEROUS/Y +MURKY +MURMUR/D/R/G/S +MUSCLE/D/G/S +MUSCULAR +MUSE/D/G/J/S +MUSEUM/M/S +MUSHROOM/D/G/S +MUSHY +MUSIC +MUSICAL/Y/S +MUSICIAN/Y/S +MUSK/S +MUSKET/M/S +MUSKRAT/M/S +MUSLIN +MUSSEL/M/S +MUST/R/S +MUSTACHE/D/S +MUSTARD +MUSTY/P +MUTABILITY +MUTABLE/P +MUTATE/D/G/N/X/V/S +MUTE/P/D/Y +MUTILATE/D/G/N/S +MUTINY/M/S +MUTTER/D/R/Z/G/S +MUTTON +MUTUAL/Y +MUZZLE/M/S +MY +MYRIAD +MYRTLE +MYSELF +MYSTERIOUS/P/Y +MYSTERY/M/S +MYSTIC/M/S +MYSTICAL +MYTH +MYTHICAL +MYTHOLOGY/M/S +NAG/M/S +NAIL/D/G/S +NAIVE/P/Y +NAIVETE +NAKED/P/Y +NAME/D/R/Z/G/Y/S +NAMEABLE +NAMELESS/Y +NAMESAKE/M/S +NANOSECOND/S +NAP/M/S +NAPKIN/M/S +NARCISSUS +NARCOTIC/S +NARRATIVE/M/S +NARROW/P/D/T/R/G/Y/S +NASAL/Y +NASTILY +NASTY/P/T/R +NATHANIEL/M +NATION/M/S +NATIONAL/Y/S +NATIONALIST/M/S +NATIONALITY/M/S +NATIONALIZATION +NATIONALIZE/D/G/S +NATIONWIDE +NATIVE/Y/S +NATIVITY +NATURAL/P/Y/S +NATURALISM +NATURALIST +NATURALIZATION +NATURE/D/M/S +NAUGHT +NAUGHTY/P/R +NAVAL/Y +NAVIGABLE +NAVIGATE/D/G/N/S +NAVIGATOR/M/S +NAVY/M/S +NAY +NAZI/M/S +NEAR/P/D/T/R/G/Y/S +NEARBY +NEAT/P/T/R/Y +NEBRASKA +NEBULA +NECESSARILY +NECESSARY/S +NECESSITATE/D/G/N/S +NECESSITY/S +NECK/G/S +NECKLACE/M/S +NECKTIE/M/S +NEE +NEED/D/G/S +NEEDFUL +NEEDLE/D/R/Z/G/S +NEEDLESS/P/Y +NEEDLEWORK +NEEDN'T +NEEDY +NEGATE/D/G/N/X/V/S +NEGATIVELY +NEGATIVES +NEGATOR/S +NEGLECT/D/G/S +NEGLIGENCE +NEGLIGIBLE +NEGOTIATE/D/G/N/X/S +NEGRO +NEGROES +NEIGH +NEIGHBOR/G/Y/S +NEIGHBORHOOD/M/S +NEITHER +NEOPHYTE/S +NEPAL +NEPHEW/M/S +NERVE/M/S +NERVOUS/P/Y +NEST/D/R/G/S +NESTLE/D/G/S +NET/M/S +NETHER +NETHERLANDS +NETMAIL +NETNEWS +NETTED +NETTING +NETTLE/D +NETWORK/D/M/G/S +NEUMANN/M +NEURAL +NEUROLOGICAL +NEUROLOGISTS +NEURON/M/S +NEUROPHYSIOLOGY +NEUROSCIENCE/S +NEUTRAL/Y +NEUTRALITY/S +NEUTRALIZE/D/G +NEUTRINO/M/S +NEVER +NEVERTHELESS +NEW/P/T/R/Y/S +NEWBORN +NEWCOMER/M/S +NEWLINE +NEWSMAN +NEWSMEN +NEWSPAPER/M/S +NEWTONIAN +NEXT +NIBBLE/D/R/Z/G/S +NICE/P/T/R/Y +NICHE/S +NICK/D/R/G/S +NICKEL/M/S +NICKNAME/D/S +NIECE/M/S +NIFTY +NIGH +NIGHT/Y/S +NIGHTFALL +NIGHTGOWN +NIGHTINGALE/M/S +NIGHTMARE/M/S +NIL +NIMBLE/P/R +NIMBLY +NINE/S +NINETEEN/H/S +NINETY/H/S +NINTH +NIP/S +NITROGEN +NO +NOBILITY +NOBLE/P/T/R/S +NOBLEMAN +NOBLY +NOBODY +NOCTURNAL/Y +NOD/M/S +NODDED +NODDING +NODE/M/S +NOISE/S +NOISELESS/Y +NOISILY +NOISY/P/R +NOMENCLATURE +NOMINAL/Y +NOMINATE/D/G/N/V +NON +NONBLOCKING +NONCONSERVATIVE +NONCYCLIC +NONDECREASING +NONDESCRIPT/Y +NONDESTRUCTIVELY +NONDETERMINACY +NONDETERMINATE/Y +NONDETERMINISM +NONDETERMINISTIC +NONDETERMINISTICALLY +NONE +NONEMPTY +NONETHELESS +NONEXISTENCE +NONEXISTENT +NONEXTENSIBLE +NONFUNCTIONAL +NONINTERACTING +NONINTERFERENCE +NONINTUITIVE +NONLINEAR/Y +NONLINEARITY/M/S +NONLOCAL +NONNEGATIVE +NONORTHOGONAL +NONORTHOGONALITY +NONPERISHABLE +NONPROCEDURAL/Y +NONPROGRAMMABLE +NONPROGRAMMER +NONSENSE +NONSENSICAL +NONSPECIALIST/M/S +NONTECHNICAL +NONTERMINAL/M/S +NONTERMINATING +NONTERMINATION +NONTRIVIAL +NONUNIFORM +NONZERO +NOODLE/S +NOOK/M/S +NOON/S +NOONDAY +NOONTIDE +NOR/H +NORM/M/S +NORMAL/Y/S +NORMALCY +NORMALITY +NORMALIZATION +NORMALIZE/D/G/S +NORTHEAST/R +NORTHEASTERN +NORTHERN/R/Z/Y +NORTHWARD/S +NORTHWEST +NORTHWESTERN +NOSE/D/G/S +NOSTRIL/M/S +NOT +NOTABLE/S +NOTABLY +NOTARIZE/D/G/S +NOTATION/M/S +NOTATIONAL +NOTCH/D/G/S +NOTE/D/G/N/X/S +NOTEBOOK/M/S +NOTEWORTHY +NOTHING/P/S +NOTICE/D/G/S +NOTICEABLE +NOTICEABLY +NOTIFY/D/R/Z/G/N/X/S +NOTORIOUS/Y +NOTWITHSTANDING +NOUN/M/S +NOURISH/D/G/S +NOURISHMENT +NOVEL/M/S +NOVELIST/M/S +NOVELTY/M/S +NOVEMBER +NOVICE/M/S +NOW +NOWADAYS +NOWHERE +NSF +NUANCES +NUCLEAR +NUCLEOTIDE/M/S +NUCLEUS +NUISANCE/M/S +NULL/D/S +NULLARY +NULLIFY/D/Z/G/S +NUMB/P/D/Z/G/Y/S +NUMBER/D/R/G/S +NUMBERLESS +NUMERAL/M/S +NUMERATOR/M/S +NUMERIC/S +NUMERICAL/Y +NUMEROUS +NUN/M/S +NUPTIAL +NURSE/D/G/S +NURSERY/M/S +NURTURE/D/G/S +NUT/M/S +NUTRITION +NYMPH +NYMPHS +O'CLOCK +OAK/N/S +OAR/M/S +OASIS +OAT/N/S +OATH +OATHS +OATMEAL +OBEDIENCE/S +OBEDIENT/Y +OBEY/D/G/S +OBJECT/D/G/M/S/V +OBJECTION/M/S +OBJECTIONABLE +OBJECTIVELY +OBJECTIVES +OBJECTOR/M/S +OBLIGATION/M/S +OBLIGATORY +OBLIGE/D/G/S +OBLIGINGLY +OBLIQUE/P/Y +OBLITERATE/D/G/N/S +OBLIVION +OBLIVIOUS/P/Y +OBLONG +OBSCENE +OBSCURE/D/R/G/Y/S +OBSCURITY/S +OBSERVABILITY +OBSERVABLE +OBSERVANCE/M/S +OBSERVANT +OBSERVATION/M/S +OBSERVATORY +OBSERVE/D/R/Z/G/S +OBSESSION/M/S +OBSOLESCENCE +OBSOLETE/D/G/S +OBSTACLE/M/S +OBSTINACY +OBSTINATE/Y +OBSTRUCT/D/G/V +OBSTRUCTION/M/S +OBTAIN/D/G/S +OBTAINABLE +OBTAINABLY +OBVIATE/D/G/N/X/S +OBVIOUS/P/Y +OCCASION/D/G/J/S +OCCASIONAL/Y +OCCLUDE/D/S +OCCLUSION/M/S +OCCUPANCY/S +OCCUPANT/M/S +OCCUPATION/M/S +OCCUPATIONAL/Y +OCCUPY/D/R/G/S +OCCUR/S +OCCURRED +OCCURRENCE/M/S +OCCURRING +OCEAN/M/S +OCTAL +OCTAVE/S +OCTOBER +OCTOPUS +ODD/P/T/R/Y/S +ODDITY/M/S +ODE/M/S +ODIOUS/P/Y +ODOR/M/S +ODOROUS/P/Y +ODYSSEY +OEDIPUS +OF +OFF/G +OFFEND/D/R/Z/G/S +OFFENSE/V/S +OFFENSIVELY +OFFENSIVENESS +OFFER/D/R/Z/G/J/S +OFFICE/R/Z/S +OFFICER'S +OFFICIAL/Y/S +OFFICIO +OFFICIOUS/P/Y +OFFSET/M/S +OFFSPRING +OFT/N +OFTENTIMES +OH +OHIO/M +OIL/D/R/Z/G/S +OILCLOTH +OILY/T/R +OINTMENT +OK +OKAY +OLD/P/T/R/N +OLIVE/M/S +OLIVETTI +OMEN/M/S +OMINOUS/P/Y +OMISSION/M/S +OMIT/S +OMITTED +OMITTING +OMNIPRESENT +OMNISCIENT/Y +OMNIVORE +ON/Y +ONANISM +ONBOARD +ONCE +ONCOLOGY +ONE/P/M/N/X/S +ONEROUS +ONESELF +ONGOING +ONLINE +ONSET/M/S +ONTO +ONWARD/S +OOZE/D +OPACITY +OPAL/M/S +OPAQUE/P/Y +OPCODE +OPEN/P/D/R/Z/Y/S +OPENING/M/S +OPERA/M/S +OPERABLE +OPERAND/M/S +OPERANDI +OPERATE/D/G/N/X/V/S +OPERATIONAL/Y +OPERATIVES +OPERATOR/M/S +OPINION/M/S +OPIUM +OPPONENT/M/S +OPPORTUNE/Y +OPPORTUNISM +OPPORTUNISTIC +OPPORTUNITY/M/S +OPPOSE/D/G/S +OPPOSITE/P/N/Y/S +OPPRESS/D/G/V/S +OPPRESSION +OPPRESSOR/M/S +OPT/D/G/S +OPTIC/S +OPTICAL/Y +OPTIMAL/Y +OPTIMALITY +OPTIMISM +OPTIMISTIC +OPTIMISTICALLY +OPTIMIZATION/M/S +OPTIMIZE/D/R/Z/G/S +OPTIMUM +OPTION/M/S +OPTIONAL/Y +OR/M/Y +ORACLE/M/S +ORAL/Y +ORANGE/M/S +ORATION/M/S +ORATOR/M/S +ORATORY/M/S +ORB +ORBIT/D/R/Z/G/S +ORBITAL/Y +ORCHARD/M/S +ORCHESTRA/M/S +ORCHID/M/S +ORDAIN/D/G/S +ORDEAL +ORDER/D/G/Y/J/S +ORDERLIES +ORDINAL +ORDINANCE/M/S +ORDINARILY +ORDINARY/P +ORDINATE/N/S +ORE/M/S +ORGAN/M/S +ORGANIC +ORGANISM/M/S +ORGANIST/M/S +ORGANIZABLE +ORGANIZATION/M/S +ORGANIZATIONAL/Y +ORGANIZE/D/R/Z/G/S +ORGY/M/S +ORIENT/D/G/S +ORIENTAL +ORIENTATION/M/S +ORIFICE/M/S +ORIGIN/M/S +ORIGINAL/Y/S +ORIGINALITY +ORIGINATE/D/G/N/S +ORIGINATOR/M/S +ORLEANS +ORNAMENT/D/G/S +ORNAMENTAL/Y +ORNAMENTATION +ORPHAN/D/S +ORTHODOX +ORTHOGONAL/Y +ORTHOGONALITY +ORTHOGRAPHIC +OSAKA +OSCILLATE/D/G/N/X/S +OSCILLATION/M/S +OSCILLATOR/M/S +OSCILLATORY +OSCILLOSCOPE/M/S +OSTRICH/M/S +OTHER/S +OTHERWISE +OTTER/M/S +OUGHT +OUNCE/S +OUR/S +OURSELF +OURSELVES +OUT/R/G/S +OUTBREAK/M/S +OUTBURST/M/S +OUTCAST/M/S +OUTCOME/M/S +OUTCRY/S +OUTDOOR/S +OUTERMOST +OUTFIT/M/S +OUTGOING +OUTGREW +OUTGROW/G/H/S +OUTGROWN +OUTLAST/S +OUTLAW/D/G/S +OUTLAY/M/S +OUTLET/M/S +OUTLINE/D/G/S +OUTLIVE/D/G/S +OUTLOOK +OUTPERFORM/D/G/S +OUTPOST/M/S +OUTPUT/M/S +OUTPUTTING +OUTRAGE/D/S +OUTRAGEOUS/Y +OUTRIGHT +OUTRUN/S +OUTSET +OUTSIDE/R +OUTSIDER/M/S +OUTSKIRTS +OUTSTANDING/Y +OUTSTRETCHED +OUTSTRIP/S +OUTSTRIPPED +OUTSTRIPPING +OUTVOTE/D/G/S +OUTWARD/Y +OUTWEIGH/D/G +OUTWEIGHS +OUTWIT/S +OUTWITTED +OUTWITTING +OVAL/M/S +OVARY/M/S +OVEN/M/S +OVER/Y +OVERALL/M/S +OVERBOARD +OVERCAME +OVERCOAT/M/S +OVERCOME/G/S +OVERCROWD/D/G/S +OVERDONE +OVERDRAFT/M/S +OVERDUE +OVEREMPHASIS +OVEREMPHASIZED +OVERESTIMATE/D/G/N/S +OVERFLOW/D/G/S +OVERHANG/G/S +OVERHAUL/G +OVERHEAD/S +OVERHEAR/G/S +OVERHEARD +OVERJOY/D +OVERLAND +OVERLAP/M/S +OVERLAPPED +OVERLAPPING +OVERLAY/G/S +OVERLOAD/D/G/S +OVERLOOK/D/G/S +OVERNIGHT/R/Z +OVERPOWER/D/G/S +OVERPRINT/D/G/S +OVERPRODUCTION +OVERRIDDEN +OVERRIDE/G/S +OVERRODE +OVERRULE/D/S +OVERRUN/S +OVERSEAS +OVERSEE/R/Z/S +OVERSEEING +OVERSHADOW/D/G/S +OVERSHOOT +OVERSHOT +OVERSIGHT/M/S +OVERSIMPLIFY/D/G/S +OVERSTATE/D/G/S +OVERSTATEMENT/M/S +OVERSTOCKS +OVERT/Y +OVERTAKE/R/Z/G/S +OVERTAKEN +OVERTHREW +OVERTHROW +OVERTHROWN +OVERTIME +OVERTONE/M/S +OVERTOOK +OVERTURE/M/S +OVERTURN/D/G/S +OVERUSE +OVERVIEW/M/S +OVERWHELM/D/G/S +OVERWHELMINGLY +OVERWORK/D/G/S +OVERWRITE/G/S +OVERWRITTEN +OVERZEALOUS +OWE/D/G/S +OWL/M/S +OWN/D/R/Z/G/S +OWNERSHIP/S +OX/N +OXFORD +OXIDE/M/S +OXIDIZE/D +OXYGEN +OYSTER/M/S +PA/H +PACE/D/R/Z/G/S +PACHELBEL +PACIFIC +PACIFY/R/N/S +PACK/D/R/Z/G/S +PACKAGE/D/R/Z/G/J/S +PACKET/M/S +PACT/M/S +PAD/M/S +PADDED +PADDING +PADDLE +PADDY +PAGAN/M/S +PAGE'S +PAGE/D/R/Z/G/S +PAGEANT/M/S +PAGINATE/D/G/N/S +PAID +PAIL/M/S +PAIN/D/S +PAINFUL/Y +PAINSTAKING/Y +PAINT/D/R/Z/G/J/S +PAIR/D/G/J/S +PAIRWISE +PAJAMA/S +PAL/M/S +PALACE/M/S +PALATE/M/S +PALE/P/D/T/R/G/Y/S +PALETTE +PALFREY +PALL +PALLIATE/V +PALLID +PALM/D/R/G/S +PALPATION +PAMPHLET/M/S +PAN/M/S +PANACEA/M/S +PANCAKE/M/S +PANDEMONIUM +PANE/M/S +PANEL/D/G/S +PANELIST/M/S +PANG/M/S +PANIC/M/S +PANNED +PANNING +PANSY/M/S +PANT/D/G/S +PANTHER/M/S +PANTRY/M/S +PANTY/S +PAPA +PAPAL +PAPER'S +PAPER/D/R/Z/G/J/S +PAPERBACK/M/S +PAPERWORK +PAPRIKA +PAR/S +PARACHUTE/M/S +PARADE/D/G/S +PARADIGM/M/S +PARADISE +PARADOX/M/S +PARADOXICAL/Y +PARAFFIN +PARAGON/M/S +PARAGRAPH/G +PARAGRAPHS +PARALLEL/D/G/S +PARALLELISM +PARALLELIZE/D/G/S +PARALLELLED +PARALLELLING +PARALLELOGRAM/M/S +PARALYSIS +PARALYZE/D/G/S +PARAMETER/M/S +PARAMETERIZABLE +PARAMETERIZATION/M/S +PARAMETERIZE/D/G/S +PARAMETERLESS +PARAMETRIC +PARAMILITARY +PARAMOUNT +PARANOIA +PARANOID +PARAPET/M/S +PARAPHRASE/D/G/S +PARASITE/M/S +PARASITIC/S +PARCEL/D/G/S +PARCH/D +PARCHMENT +PARDON/D/R/Z/G/S +PARDONABLE +PARDONABLY +PARE/G/J/S +PARENT/M/S +PARENTAGE +PARENTAL +PARENTHESES +PARENTHESIS +PARENTHESIZED +PARENTHETICAL/Y +PARENTHOOD +PARISH/M/S +PARITY +PARK/D/R/Z/G/S +PARLIAMENT/M/S +PARLIAMENTARY +PARLOR/M/S +PAROLE/D/G/S +PARROT/G/S +PARRY/D +PARSE/D/R/Z/G/J/S +PARSIMONY +PARSLEY +PARSON/M/S +PART/D/R/Z/G/Y/J/S +PARTAKE/R/G/S +PARTIAL/Y +PARTIALITY +PARTICIPANT/M/S +PARTICIPATE/D/G/N/S +PARTICLE/M/S +PARTICULAR/Y/S +PARTISAN/M/S +PARTITION/D/G/S +PARTNER/D/S +PARTNERSHIP +PARTRIDGE/M/S +PARTY/M/S +PASCAL +PASS +PASSAGE/M/S +PASSAGEWAY +PASSE/D/R/Z/G/N/X/S +PASSENGER/M/S +PASSIONATE/Y +PASSIVE/P/Y +PASSIVITY +PASSPORT/M/S +PASSWORD/M/S +PAST/P/M/S +PASTE/D/G/S +PASTEBOARD +PASTIME/M/S +PASTOR/M/S +PASTORAL +PASTRY +PASTURE/M/S +PAT/S +PATCH/D/G/S +PATCHWORK +PATENT/D/R/Z/G/Y/S +PATENTABLE +PATERNAL/Y +PATHETIC +PATHOLOGICAL +PATHOLOGY +PATHOS +PATHS +PATHWAY/M/S +PATIENCE +PATIENT/Y/S +PATRIARCH +PATRIARCHS +PATRICIAN/M/S +PATRIOT/M/S +PATRIOTIC +PATRIOTISM +PATROL/M/S +PATRON/M/S +PATRONAGE +PATRONIZE/D/G/S +PATTER/D/G/J/S +PATTERN/D/G/S +PATTY/M/S +PAUCITY +PAUL/M +PAUSE/D/G/S +PAVE/D/G/S +PAVEMENT/M/S +PAVILION/M/S +PAW/G/S +PAWN/M/S +PAY/G/S +PAYABLE +PAYCHECK/M/S +PAYER/M/S +PAYMENT/M/S +PAYOFF/M/S +PAYROLL +PC +PDP +PEA/M/S +PEACE +PEACEABLE +PEACEFUL/P/Y +PEACH/M/S +PEACOCK/M/S +PEAK/D/S +PEAL/D/G/S +PEANUT/M/S +PEAR/Y/S +PEARL/M/S +PEASANT/M/S +PEASANTRY +PEAT +PEBBLE/M/S +PECK/D/G/S +PECULIAR/Y +PECULIARITY/M/S +PEDAGOGIC +PEDAGOGICAL +PEDANTIC +PEDDLER/M/S +PEDESTAL +PEDESTRIAN/M/S +PEDIATRIC/S +PEEK/D/G/S +PEEL/D/G/S +PEEP/D/R/G/S +PEER/D/G/S +PEERLESS +PEG/M/S +PELT/G/S +PEN +PENALIZE/D/G/S +PENALTY/M/S +PENANCE +PENCE +PENCIL/D/S +PEND/D/G/S +PENDULUM/M/S +PENETRATE/D/G/N/X/V/S +PENETRATINGLY +PENETRATOR/M/S +PENGUIN/M/S +PENINSULA/M/S +PENITENT +PENITENTIARY +PENNED +PENNILESS +PENNING +PENNSYLVANIA +PENNY/M/S +PENS/V +PENSION/R/S +PENT +PENTAGON/M/S +PEOPLE/D/M/S +PEP +PEPPER/D/G/S +PER +PERCEIVABLE +PERCEIVABLY +PERCEIVE/D/R/Z/G/S +PERCENT/S +PERCENTAGE/S +PERCENTILE/S +PERCEPTIBLE +PERCEPTIBLY +PERCEPTION/S +PERCEPTIVE/Y +PERCEPTRON/S +PERCEPTUAL/Y +PERCH/D/G/S +PERCHANCE +PERCUSSION +PERCUTANEOUS +PEREMPTORY +PERENNIAL/Y +PERFECT/P/D/G/Y/S +PERFECTION +PERFECTIONIST/M/S +PERFORCE +PERFORM/D/R/Z/G/S +PERFORMANCE/M/S +PERFUME/D/G/S +PERHAPS +PERIL/M/S +PERILOUS/Y +PERIMETER/S +PERIOD/M/S +PERIODIC +PERIODICAL/Y/S +PERIPHERAL/Y/S +PERIPHERY/M/S +PERISH/D/R/Z/G/S +PERISHABLE/M/S +PERMANENCE +PERMANENT/Y +PERMEATE/D/G/N/S +PERMISSIBILITY +PERMISSIBLE +PERMISSIBLY +PERMISSION/S +PERMISSIVE/Y +PERMIT/M/S +PERMITTED +PERMITTING +PERMUTATION/M/S +PERMUTE/D/G/S +PERPENDICULAR/Y/S +PERPETRATE/D/G/N/X/S +PERPETRATOR/M/S +PERPETUAL/Y +PERPETUATE/D/G/N/S +PERPLEX/D/G +PERPLEXITY +PERSECUTE/D/G/N/S +PERSECUTOR/M/S +PERSEVERANCE +PERSEVERE/D/G/S +PERSIST/D/G/S +PERSISTENCE +PERSISTENT/Y +PERSON/M/S +PERSONAGE/M/S +PERSONAL/Y +PERSONALITY/M/S +PERSONALIZATION +PERSONALIZE/D/G/S +PERSONIFY/D/G/N/S +PERSONNEL +PERSPECTIVE/M/S +PERSPICUOUS/Y +PERSPIRATION +PERSUADABLE +PERSUADE/D/R/Z/G/S +PERSUASION/M/S +PERSUASIVE/P/Y +PERTAIN/D/G/S +PERTINENT +PERTURB/D +PERTURBATION/M/S +PERUSAL +PERUSE/D/R/Z/G/S +PERVADE/D/G/S +PERVASIVE/Y +PERVERT/D/S +PESSIMISTIC +PEST/R/S +PESTILENCE +PET/R/Z/S +PETAL/M/S +PETITION/D/R/G/S +PETROLEUM +PETTED +PETTER/M/S +PETTICOAT/M/S +PETTING +PETTY/P +PEW/M/S +PEWTER +PHANTOM/M/S +PHASE/D/R/Z/G/S +PHEASANT/M/S +PHENOMENA +PHENOMENAL/Y +PHENOMENOLOGICAL/Y +PHENOMENOLOGY/S +PHENOMENON +PHILADELPHIA +PHILOSOPHER/M/S +PHILOSOPHIC +PHILOSOPHICAL/Y +PHILOSOPHIZE/D/R/Z/G/S +PHILOSOPHY/M/S +PHONE/D/G/S +PHONEME/M/S +PHONEMIC +PHONETIC/S +PHONOGRAPH +PHONOGRAPHS +PHOSPHATE/M/S +PHOSPHORIC +PHOTO/M/S +PHOTOCOPY/D/G/S +PHOTOGRAPH/D/R/Z/G +PHOTOGRAPHIC +PHOTOGRAPHS +PHOTOGRAPHY +PHOTOTYPESETTER/S +PHRASE/D/G/J/S +PHYLA +PHYLUM +PHYSIC/S +PHYSICAL/P/Y/S +PHYSICIAN/M/S +PHYSICIST/M/S +PHYSIOLOGICAL/Y +PHYSIOLOGY +PHYSIQUE +PI +PIANO/M/S +PIAZZA/M/S +PICAYUNE +PICK/D/R/Z/G/J/S +PICKET/D/R/Z/G/S +PICKLE/D/G/S +PICKUP/M/S +PICKY +PICNIC/M/S +PICTORIAL/Y +PICTURE/D/G/S +PICTURESQUE/P +PIE/R/Z/S +PIECE/D/G/S +PIECEMEAL +PIECEWISE +PIERCE/D/G/S +PIETY +PIG/M/S +PIGEON/M/S +PIGMENT/D/S +PIKE/R/S +PILE/D/Z/G/J/S +PILFERAGE +PILGRIM/M/S +PILGRIMAGE/M/S +PILL/M/S +PILLAGE/D +PILLAR/D/S +PILLOW/M/S +PILOT/G/S +PIN/M/S +PINCH/D/G/S +PINE/D/G/N/S +PINEAPPLE/M/S +PING +PINK/P/T/R/Y/S +PINNACLE/M/S +PINNED +PINNING/S +PINPOINT/G/S +PINT/M/S +PIONEER/D/G/S +PIOUS/Y +PIPE/D/R/Z/G/S +PIPELINE/D/G/S +PIQUE +PIRATE/M/S +PISTIL/M/S +PISTOL/M/S +PISTON/M/S +PIT/M/S +PITCH/D/R/Z/G/S +PITEOUS/Y +PITFALL/M/S +PITH/D/G/S +PITHY/P/T/R +PITIABLE +PITIFUL/Y +PITILESS/Y +PITTED +PITTSBURGH/M +PITY/D/R/Z/G/S +PITYINGLY +PIVOT/G/S +PIVOTAL +PIXEL/S +PLACARD/M/S +PLACE/D/R/G/S +PLACEMENT/M/S +PLACID/Y +PLAGUE/D/G/S +PLAID/M/S +PLAIN/P/T/R/Y/S +PLAINTIFF/M/S +PLAINTIVE/P/Y +PLAIT/M/S +PLAN/M/S +PLANAR +PLANARITY +PLANE'S +PLANE/D/R/Z/G/S +PLANET/M/S +PLANETARY +PLANK/G/S +PLANNED +PLANNER/M/S +PLANNING +PLANT/D/R/Z/G/J/S +PLANTATION/M/S +PLASMA +PLASTER/D/R/G/S +PLASTIC/S +PLASTICITY +PLATE/D/G/S +PLATEAU/M/S +PLATELET/M/S +PLATEN/M/S +PLATFORM/M/S +PLATINUM +PLATO +PLATTER/M/S +PLAUSIBILITY +PLAUSIBLE +PLAY/D/G/S +PLAYABLE +PLAYER/M/S +PLAYFUL/P/Y +PLAYGROUND/M/S +PLAYMATE/M/S +PLAYTHING/M/S +PLAYWRIGHT/M/S +PLAZA +PLEA/M/S +PLEAD/D/R/G/S +PLEASANT/P/Y +PLEASE/D/G/S +PLEASINGLY +PLEASURE/S +PLEBEIAN +PLEBISCITE/M/S +PLEDGE/D/S +PLENARY +PLENTEOUS +PLENTIFUL/Y +PLENTY +PLEURISY +PLIGHT +PLOD +PLOT/M/S +PLOTTED +PLOTTER/M/S +PLOTTING +PLOUGH +PLOUGHMAN +PLOW/D/R/G/S +PLOWMAN +PLOY/M/S +PLUCK/D/G +PLUCKY +PLUG/M/S +PLUGGED +PLUGGING +PLUM/M/S +PLUMAGE +PLUMB/D/M/G/S +PLUME/D/S +PLUMMETING +PLUMP/P/D +PLUNDER/D/R/Z/G/S +PLUNGE/D/R/Z/G/S +PLURAL/S +PLURALITY +PLUS +PLUSH +PLY/D/Z/S +PNEUMONIA +POACH/R/S +POCKET/D/G/S +POCKETBOOK/M/S +POD/M/S +POEM/M/S +POET/M/S +POETIC/S +POETICAL/Y +POETRY/M/S +POINT/D/R/Z/G/S +POINTEDLY +POINTLESS +POINTY +POISE/D/S +POISON/D/R/G/S +POISONOUS/P +POKE/D/R/G/S +POLAND +POLAR +POLARITY/M/S +POLE/D/G/S +POLEMIC/S +POLICE/D/M/G/S +POLICEMAN +POLICEMEN +POLICY/M/S +POLISH/D/R/Z/G/S +POLITE/P/T/R/Y +POLITIC/S +POLITICAL/Y +POLITICIAN/M/S +POLL/D/G/N/S +POLLUTANT/S +POLLUTE/D/G/N/S +POLO +POLYGON/S +POLYGONAL +POLYHEDRA +POLYHEDRON +POLYLINE +POLYMER/M/S +POLYMORPHIC +POLYMORPHISM +POLYNOMIAL/M/S +POLYTECHNIC +POMP +POMPOUS/P/Y +POND/R/S +PONDER/D/G/S +PONDEROUS +PONY/M/S +POOL/D/G/S +POOR/P/T/R/Y +POP/M/S +POPLAR +POPPED +POPPING +POPPY/M/S +POPULACE +POPULAR/Y +POPULARITY +POPULARIZATION +POPULARIZE/D/G/S +POPULATE/D/G/N/X/S +POPULOUS/P +PORCELAIN +PORCH/M/S +PORCUPINE/M/S +PORE/D/G/S +PORK/R +PORNOGRAPHIC +PORRIDGE +PORT/R/Z/Y/S/D/G +PORTABILITY +PORTABLE +PORTAL/M/S +PORTEND/D/G/S +PORTION/M/S +PORTRAIT/M/S +PORTRAY/D/G/S +PORTUGUESE +POSE/D/R/Z/G/S +POSIT/D/G/S +POSITION/D/G/S +POSITIONAL +POSITIVE/P/Y/S +POSSESS/D/G/V/S +POSSESSION/M/S +POSSESSIONAL +POSSESSIVE/P/Y +POSSESSOR/M/S +POSSIBILITY/M/S +POSSIBLE +POSSIBLY +POSSUM/M/S +POST/D/R/Z/G/S +POSTAGE +POSTAL +POSTCONDITION +POSTDOCTORAL +POSTERIOR +POSTERITY +POSTMAN +POSTMASTER/M/S +POSTMODERNISM +POSTOFFICE/M/S +POSTPONE/D/G +POSTSCRIPT/M/S +POSTSTRUCTURALISM +POSTSTRUCTURALIST +POSTULATE/D/G/N/X/S +POSTURE/M/S +POT/M/S +POTASH +POTASSIUM +POTATO +POTATOES +POTENT +POTENTATE/M/S +POTENTIAL/Y/S +POTENTIALITY/S +POTENTIATING +POTENTIOMETER/M/S +POTTED +POTTER/M/S +POTTERY +POTTING +POUCH/M/S +POUGHKEEPSIE +POULTRY +POUNCE/D/G/S +POUND/D/R/Z/G/S +POUR/D/R/Z/G/S +POUT/D/G/S +POVERTY +POWDER/D/G/S +POWER/D/G/S +POWERFUL/P/Y +POWERLESS/P/Y +POWERSET/M/S +POX +PRACTICABLE +PRACTICABLY +PRACTICAL/Y +PRACTICALITY +PRACTICE/D/G/S +PRACTISE/D/G +PRACTITIONER/M/S +PRAGMATIC/S +PRAGMATICALLY +PRAIRIE +PRAISE/D/R/Z/G/S +PRAISINGLY +PRANCE/D/R/G +PRANK/M/S +PRATE +PRAY/D/G +PRAYER/M/S +PRE +PREACH/D/R/Z/G/S +PREAMBLE +PREASSIGN/D/G/S +PRECARIOUS/P/Y +PRECAUTION/M/S +PRECEDE/D/G/S +PRECEDENCE/M/S +PRECEDENT/D/S +PRECEPT/M/S +PRECINCT/M/S +PRECIOUS/P/Y +PRECIPICE +PRECIPITATE/P/D/G/N/Y/S +PRECIPITOUS/Y +PRECISE/P/N/X/Y +PRECLUDE/D/G/S +PRECOCIOUS/Y +PRECONCEIVE/D +PRECONCEPTION/M/S +PRECONDITION/D/S +PRECURSOR/M/S +PREDATE/D/G/S +PREDECESSOR/M/S +PREDEFINE/D/G/S +PREDEFINITION/M/S +PREDETERMINE/D/G/S +PREDICAMENT +PREDICATE/D/G/N/X/S +PREDICT/D/G/V/S +PREDICTABILITY +PREDICTABLE +PREDICTABLY +PREDICTION/M/S +PREDISPOSE/D/G +PREDOMINANT/Y +PREDOMINATE/D/G/N/Y/S +PREEMPT/D/G/V/S +PREEMPTION +PREFACE/D/G/S +PREFER/S +PREFERABLE +PREFERABLY +PREFERENCE/M/S +PREFERENTIAL/Y +PREFERRED +PREFERRING +PREFIX/D/S +PREGNANT +PREHISTORIC +PREINITIALIZE/D/G/S +PREJUDGE/D +PREJUDICE/D/S +PRELATE +PRELIMINARY/S +PRELUDE/M/S +PREMATURE/Y +PREMATURITY +PREMEDITATED +PREMIER/M/S +PREMISE/M/S +PREMIUM/M/S +PREOCCUPATION +PREOCCUPY/D/S +PREPARATION/M/S +PREPARATIVE/M/S +PREPARATORY +PREPARE/D/G/S +PREPOSITION/M/S +PREPOSITIONAL +PREPOSTEROUS/Y +PREPROCESS/D/G +PREPRODUCTION +PREPROGRAMMED +PREREQUISITE/M/S +PREROGATIVE/M/S +PRESBYTERIAN +PRESCRIBE/D/S +PRESCRIPTION/M/S +PRESCRIPTIVE +PRESELECT/D/G/S +PRESENCE/M/S +PRESENT/P/D/R/G/Y/S +PRESENTATION/M/S +PRESERVATION/S +PRESERVE/D/R/Z/G/S +PRESET +PRESIDE/D/G/S +PRESIDENCY +PRESIDENT/M/S +PRESIDENTIAL +PRESS/D/R/G/J/S +PRESSURE/D/G/S +PRESSURIZE/D +PRESTIGE +PRESTO +PRESUMABLY +PRESUME/D/G/S +PRESUMPTION/M/S +PRESUMPTUOUS/P +PRESUPPOSE/D/G/S +PRESYNAPTIC +PRETEND/D/R/Z/G/S +PRETENSE/N/X/S +PRETENTIOUS/P/Y +PRETEXT/M/S +PRETTILY +PRETTY/P/T/R +PREVAIL/D/G/S +PREVAILINGLY +PREVALENCE +PREVALENT/Y +PREVENT/D/G/V/S +PREVENTABLE +PREVENTABLY +PREVENTION +PREVENTIVES +PREVIEW/D/G/S +PREVIOUS/Y +PREY/D/G/S +PRICE/D/R/Z/G/S +PRICELESS +PRICK/D/G/Y/S +PRIDE/D/G/S +PRIMACY +PRIMARILY +PRIMARY/M/S +PRIME/P/D/R/Z/G/S +PRIMEVAL +PRIMITIVE/P/Y/S +PRIMROSE +PRINCE/Y/S +PRINCESS/M/S +PRINCETON +PRINCIPAL/Y/S +PRINCIPALITY/M/S +PRINCIPLE/D/S +PRINT/D/R/Z/G/S +PRINTABLE +PRINTABLY +PRINTOUT +PRIOR +PRIORI +PRIORITY/M/S +PRIORY +PRISM/M/S +PRISON/R/Z/S +PRISONER'S +PRIVACY/S +PRIVATE/N/X/Y/S +PRIVILEGE/D/S +PRIVY/M/S +PRIZE/D/R/Z/G/S +PRO/M/S +PROBABILISTIC +PROBABILISTICALLY +PROBABILITY/S +PROBABLE +PROBABLY +PROBATE/D/G/N/V/S +PROBE/D/G/J/S +PROBLEM/M/S +PROBLEMATIC +PROBLEMATICAL/Y +PROCEDURAL/Y +PROCEDURE/M/S +PROCEED/D/G/J/S +PROCESS/D/M/G/S +PROCESSION +PROCESSOR/M/S +PROCLAIM/D/R/Z/G/S +PROCLAMATION/M/S +PROCLIVITY/M/S +PROCRASTINATE/D/G/N/S +PROCURE/D/R/Z/G/S +PROCUREMENT/M/S +PRODIGAL/Y +PRODIGIOUS +PRODIGY +PRODUCE/D/R/Z/G/S +PRODUCIBLE +PRODUCT/M/V/S +PRODUCTION/M/S +PRODUCTIVELY +PRODUCTIVITY +PROFANE/Y +PROFESS/D/G/S +PROFESSION/M/S +PROFESSIONAL/Y/S +PROFESSIONALISM +PROFESSOR/M/S +PROFFER/D/S +PROFICIENCY +PROFICIENT/Y +PROFILE/D/G/S +PROFIT/D/G/S/R/M/Z +PROFITABILITY +PROFITABLE +PROFITABLY +PROFITEER/M/S +PROFOUND/T/Y +PROG +PROGENY +PROGRAM/M/S +PROGRAMMABILITY +PROGRAMMABLE +PROGRAMMED +PROGRAMMER/M/S +PROGRAMMING +PROGRESS/D/G/V/S +PROGRESSION/M/S +PROGRESSIVE/Y +PROHIBIT/D/G/V/S +PROHIBITION/M/S +PROHIBITIVELY +PROJECT/D/G/V/S/M +PROJECTION/M/S +PROJECTIVELY +PROJECTOR/M/S +PROLEGOMENA +PROLETARIAT +PROLIFERATE/D/G/N/S +PROLIFIC +PROLOG +PROLOGUE +PROLONG/D/G/S +PROMENADE/M/S +PROMINENCE +PROMINENT/Y +PROMISE/D/G/S +PROMONTORY +PROMOTE/D/R/Z/G/N/X/S +PROMOTIONAL +PROMPT/P/D/T/R/Y/S +PROMPTING/S +PROMULGATE/D/G/N/S +PRONE/P +PRONG/D/S +PRONOUN/M/S +PRONOUNCE/D/G/S +PRONOUNCEABLE +PRONOUNCEMENT/M/S +PRONUNCIATION/M/S +PROOF/M/S +PROP/R/S +PROPAGANDA +PROPAGATE/D/G/N/X/S +PROPEL/S +PROPELLED +PROPELLER/M/S +PROPENSITY +PROPERLY +PROPERNESS +PROPERTY/D/S +PROPHECY/M/S +PROPHESY/D/R/S +PROPHET/M/S +PROPHETIC +PROPITIOUS +PROPONENT/M/S +PROPORTION/D/G/S +PROPORTIONAL/Y +PROPORTIONATELY +PROPORTIONMENT +PROPOSAL/M/S +PROPOSE/D/R/G/S +PROPOSITION/D/G/S +PROPOSITIONAL/Y +PROPOUND/D/G/S +PROPRIETARY +PROPRIETOR/M/S +PROPRIETY +PROPULSION/M/S +PROSE +PROSECUTE/D/G/N/X/S +PROSELYTIZE/D/G/S +PROSODIC/S +PROSPECT/D/G/V/S +PROSPECTION/M/S +PROSPECTIVELY +PROSPECTIVES +PROSPECTOR/M/S +PROSPECTUS +PROSPER/D/G/S +PROSPERITY +PROSPEROUS +PROSTITUTION +PROSTRATE/N +PROTECT/D/G/V/S +PROTECTION/M/S +PROTECTIVELY +PROTECTIVENESS +PROTECTOR/M/S +PROTECTORATE +PROTEGE/M/S +PROTEIN/M/S +PROTEST/D/G/S/R/Z/M +PROTESTATION/S +PROTESTER'S +PROTESTINGLY +PROTESTOR/M/S +PROTOCOL/M/S +PROTON/M/S +PROTOPLASM +PROTOTYPE/D/G/S +PROTOTYPICAL/Y +PROTRUDE/D/G/S +PROTRUSION/M/S +PROVABILITY +PROVABLE +PROVABLY +PROVE/D/R/Z/G/S +PROVEN +PROVERB/M/S +PROVIDE/D/R/Z/G/S +PROVIDENCE +PROVINCE/M/S +PROVINCIAL +PROVINCIALISM +PROVISION/D/G/S +PROVISIONAL/Y +PROVOCATION +PROVOKE/D/S +PROW/M/S +PROWESS +PROWL/D/R/Z/G +PROXIMAL +PROXIMATE +PROXIMITY +PRUDENCE +PRUDENT/Y +PRUNE/D/R/Z/G/S +PRY/T/G +PSALM/M/S +PSEUDO +PSYCHE/M/S +PSYCHIATRIST/M/S +PSYCHIATRY +PSYCHOLOGICAL/Y +PSYCHOLOGIST/M/S +PSYCHOLOGY +PSYCHOMETRIC +PSYCHOSOCIAL +PUB/M/S +PUBLIC/Y +PUBLICATION/M/S +PUBLICITY +PUBLICIZE/D/G/S +PUBLISH/D/R/Z/G/S +PUCKER/D/G/S +PUDDING/M/S +PUDDLE/G/S +PUFF/D/G/S +PULL/D/R/G/J/S +PULLEY/M/S +PULMONARY +PULP/G +PULPIT/M/S +PULSE/D/G/S +PUMP/D/G/S +PUMPKIN/M/S +PUN/M/S +PUNCH/D/R/G/S +PUNCTUAL/Y +PUNCTUATION +PUNCTURE/D/M/G/S +PUNISH/D/G/S +PUNISHABLE +PUNISHMENT/M/S +PUNITIVE +PUNT/D/G/S +PUNY +PUP/M/S +PUPA +PUPIL/M/S +PUPPET/M/S +PUPPY/M/S +PURCHASABLE +PURCHASE/D/R/Z/G/S +PURCHASEABLE +PURE/T/R/Y +PURGE/D/G/S +PURIFY/D/R/Z/G/N/X/S +PURITY +PURPLE/T/R +PURPORT/D/R/Z/G/S +PURPORTEDLY +PURPOSE/D/V/Y/S +PURPOSEFUL/Y +PURR/D/G/S +PURSE/D/R/S +PURSUE/D/R/Z/G/S +PURSUIT/M/S +PURVIEW +PUSHDOWN +PUSS +PUSSY +PUT/S +PUTRID +PUTTER/G/S +PUTTING +PUZZLE/D/R/Z/G/J/S +PUZZLEMENT +PYGMY/M/S +PYRAMID/M/S +QUACK/D/S +QUADRANT/M/S +QUADRATIC/S +QUADRATICAL/Y +QUADRATURE/M/S +QUADRUPLE/D/G/S +QUAGMIRE/M/S +QUAIL/M/S +QUAINT/P/Y +QUAKE/D/R/Z/G/S +QUALIFY/D/R/Z/G/N/X/S +QUALITATIVE/Y +QUALITY/M/S +QUANDARY/M/S +QUANTA +QUANTIFIABLE +QUANTIFY/D/R/Z/G/N/X/S +QUANTITATIVE/Y +QUANTITY/M/S +QUANTIZATION +QUANTIZE/D/G/S +QUANTUM +QUARANTINE/M/S +QUARREL/D/G/S +QUARRELSOME +QUARRY/M/S +QUART/Z/S +QUARTER/D/G/Y/S +QUARTET/M/S +QUARTZ +QUASH/D/G/S +QUASI +QUAVER/D/G/S +QUAY +QUEEN/M/Y/S +QUEER/P/T/R/Y +QUELL/G +QUENCH/D/G/S +QUERY/D/G/S +QUEST/D/R/Z/G/S +QUESTION/D/R/Z/G/J/S +QUESTIONABLE +QUESTIONABLY +QUESTIONINGLY +QUESTIONNAIRE/M/S +QUEUE/D/R/Z/G/S +QUICK/P/T/R/N/X/Y +QUICKENED +QUICKENING +QUICKSILVER +QUIESCENT +QUIET/P/D/T/R/G/Y/S +QUIETUDE +QUILL +QUILT/D/G/S +QUININE +QUIT/S +QUITE +QUITTER/M/S +QUITTING +QUIVER/D/G/S +QUIXOTE +QUIZ +QUIZZED +QUIZZES +QUIZZING +QUO/H +QUOTA/M/S +QUOTATION/M/S +QUOTE/D/G/S +QUOTIENT +RABBIT/M/S +RABBLE +RACCOON/M/S +RACE/D/R/Z/G/S +RACIAL/Y +RACK/D/G/S +RACKET/M/S +RACKETEER/G/S +RADAR/M/S +RADIAL/Y +RADIAN/S +RADIANCE +RADIANT/Y +RADIATE/D/G/N/X/S +RADIATOR/M/S +RADICAL/Y/S +RADII +RADIO/D/G/S +RADIOLOGY +RADISH/M/S +RADIUS +RADIX +RAFT/R/Z/S +RAG/M/S +RAGE/D/G/S +RAGGED/P/Y +RAID/D/R/Z/G/S +RAIL/D/R/Z/G/S +RAILROAD/D/R/Z/G/S +RAILWAY/M/S +RAIMENT +RAIN/D/G/S +RAINBOW +RAINCOAT/M/S +RAINDROP/M/S +RAINFALL +RAINY/T/R +RAISE/D/R/Z/G/S +RAISIN +RAKE/D/G/S +RALLY/D/G/S +RAM/M/S +RAMBLE/R/G/J/S +RAMIFICATION/M/S +RAMP/M/S +RAMPART +RAN +RANCH/D/R/Z/G/S +RANDOLPH/M +RANDOM/P/Y +RANDY/M +RANG +RANGE/D/R/Z/G/S +RANK/P/D/T/Y/S +RANKER/M/S +RANKING/M/S +RANSACK/D/G/S +RANSOM/R/G/S +RANT/D/R/Z/G/S +RAP/M/S +RAPE/D/R/G/S +RAPID/Y/S +RAPIDITY +RAPT/Y +RAPTURE/M/S +RAPTUROUS +RARE/P/T/R/Y +RARITY/M/S +RASCAL/Y/S +RASH/P/R/Y +RASP/D/G/S +RASPBERRY +RASTER +RASTEROP +RAT/M/S +RATE/D/R/Z/G/N/X/J/S +RATHER +RATIFY/D/G/N/S +RATIO/M/S +RATIONAL/Y +RATIONALE/M/S +RATIONALITY/S +RATIONALIZE/D/G/S +RATTLE/D/R/Z/G/S +RATTLESNAKE/M/S +RAVAGE/D/R/Z/G/S +RAVE/D/G/J/S +RAVEN/G/S +RAVENOUS/Y +RAVINE/M/S +RAW/P/T/R/Y +RAY/M/S +RAZOR/M/S +RE/D/Y/J +REABBREVIATE/D/G/S +REACH/D/R/G/S +REACHABLE +REACHABLY +REACT/D/G/V/S +REACTION/M/S +REACTIONARY/M/S +REACTIVATE/D/G/N/S +REACTIVELY +REACTIVITY +REACTOR/M/S +READ/R/Z/G/J/S +READABILITY +READABLE +READILY +READJUSTED +READJUSTMENT +READOUT/M/S +READY/P/D/T/R/G/S +REAL/P/S/T/Y +REALIGN/D/G/S +REALISM +REALIST/M/S +REALISTIC +REALISTICALLY +REALITY/S +REALIZABLE +REALIZABLY +REALIZATION/M/S +REALIZE/D/G/S +REALM/M/S +REANALYZE/G/S +REAP/D/R/G/S +REAPPEAR/D/G/S +REAPPRAISAL/S +REAR/D/G/S +REARRANGE/D/G/S +REARRANGEABLE +REARRANGEMENT/M/S +REARREST/D +REASON/D/R/G/J/S +REASONABLE/P +REASONABLY +REASSEMBLE/D/G/S +REASSESSMENT/M/S +REASSIGN/D/G/S +REASSIGNMENT/M/S +REASSURE/D/G/S +REAWAKEN/D/G/S +REBATE/M/S +REBEL/M/S +REBELLION/M/S +REBELLIOUS/P/Y +REBOUND/D/G/S +REBROADCAST +REBUFF/D +REBUILD/G/S +REBUILT +REBUKE/D/G/S +REBUTTAL +RECALCULATE/D/G/N/X/S +RECALL/D/G/S +RECAPITULATE/D/N/S +RECAPTURE/D/G/S +RECAST/G/S +RECEDE/D/G/S +RECEIPT/M/S +RECEIVABLE +RECEIVE/D/R/Z/G/S +RECENT/P/Y +RECEPTACLE/M/S +RECEPTION/M/S +RECEPTIVE/P/Y +RECEPTIVITY +RECESS/D/V/S +RECESSION +RECIPE/M/S +RECIPIENT/M/S +RECIPROCAL/Y +RECIPROCATE/D/G/N/S +RECIPROCITY +RECIRCULATE/D/G/S +RECITAL/M/S +RECITATION/M/S +RECITE/D/R/G/S +RECKLESS/P/Y +RECKON/D/R/G/J/S +RECLAIM/D/R/Z/G/S +RECLAIMABLE +RECLAMATION/S +RECLASSIFY/D/G/N/S +RECLINE/G +RECODE/D/G/S +RECOGNITION/M/S +RECOGNIZABILITY +RECOGNIZABLE +RECOGNIZABLY +RECOGNIZE/D/R/Z/G/S +RECOIL/D/G/S +RECOLLECT/D/G +RECOLLECTION/M/S +RECOMBINE/D/G/S +RECOMMEND/D/R/G/S +RECOMMENDATION/M/S +RECOMPENSE +RECOMPILATION +RECOMPILE/D/G +RECOMPUTE/D/G/S +RECONCILE/D/R/G/S +RECONCILIATION +RECONFIGURABLE +RECONFIGURATION/M/S +RECONFIGURE/D/R/G/S +RECONNECT/D/G/S +RECONNECTION +RECONSIDER/D/G/S +RECONSIDERATION +RECONSTRUCT/D/G/S +RECONSTRUCTION +RECORD/D/R/Z/G/J/S +RECOUNT/D/G/S +RECOURSE +RECOVER/D/G/S +RECOVERABLE +RECOVERY/M/S +RECREATE/D/G/N/X/V/S +RECREATION/S +RECREATIONAL +RECRUIT/D/R/M/G/S +RECRUITMENT +RECTA +RECTANGLE/M/S +RECTANGULAR +RECTIFY +RECTOR/M/S +RECTUM/M/S +RECUR/S +RECURRENCE/M/S +RECURRENT/Y +RECURRING +RECURSE/D/G/N/S +RECURSION/M/S +RECURSIVE/Y +RECYCLABLE +RECYCLE/D/G/S +RED/P/Y/S +REDBREAST +REDDEN/D +REDDER +REDDEST +REDDISH/P +REDECLARE/D/G/S +REDEEM/D/R/Z/G/S +REDEFINE/D/G/S +REDEFINITION/M/S +REDEMPTION +REDESIGN/D/G/S +REDEVELOPMENT +REDIRECT/D/G +REDIRECTING +REDIRECTION/S +REDISPLAY/D/G/S +REDISTRIBUTE/D/G/S +REDONE +REDOUBLE/D +REDRAW/G +REDRAWN +REDRESS/D/G/S +REDUCE/D/R/Z/G/S +REDUCIBILITY +REDUCIBLE +REDUCIBLY +REDUCTION/M/S +REDUNDANCY/S +REDUNDANT/Y +REED/M/S +REEDUCATION +REEF/R/S +REEL/D/R/G/S +REELECT/D/G/S +REEMPHASIZE/D/G/S +REENFORCEMENT +REENTER/D/G/S +REENTRANT +REESTABLISH/D/G/S +REEVALUATE/D/G/N/S +REEXAMINE/D/G/S +REFER/S +REFEREE/D/S +REFEREEING +REFERENCE/D/R/G/S +REFERENDUM +REFERENT/M/S +REFERENTIAL/Y +REFERENTIALITY +REFERRAL/M/S +REFERRED +REFERRING +REFILL/D/G/S +REFILLABLE +REFINE/D/R/G/S +REFINEMENT/M/S +REFLECT/D/G/V/S +REFLECTION/M/S +REFLECTIVELY +REFLECTIVITY +REFLECTOR/M/S +REFLEX/M/S +REFLEXIVE/P/Y +REFLEXIVITY +REFORM/D/R/Z/G/S +REFORMABLE +REFORMAT/S +REFORMATION +REFORMATTED +REFORMATTING +REFORMULATE/D/G/N/S +REFRACTORY +REFRAIN/D/G/S +REFRESH/D/R/Z/G/S +REFRESHINGLY +REFRESHMENT/M/S +REFRIGERATOR/M/S +REFUEL/D/G/S +REFUGE +REFUGEE/M/S +REFUSAL +REFUSE/D/G/S +REFUTABLE +REFUTATION +REFUTE/D/R/G/S +REGAIN/D/G/S +REGAL/D/Y +REGARD/D/G/S +REGARDLESS +REGENERATE/D/G/N/V/S +REGENT/M/S +REGIME/M/S +REGIMEN +REGIMENT/D/S +REGION/M/S +REGIONAL/Y +REGISTER/D/G/S +REGISTRATION/M/S +REGRESS/D/G/V/S +REGRESSION/M/S +REGRET/S +REGRETFUL/Y +REGRETTABLE +REGRETTABLY +REGRETTED +REGRETTING +REGROUP/D/G +REGULAR/Y/S +REGULARITY/S +REGULATE/D/G/N/X/V/S +REGULATOR/M/S +REHABILITATE/D/G/N +REHEARSAL/M/S +REHEARSE/D/R/G/S +REIGN/D/G/S +REIMBURSED +REIMBURSEMENT/M/S +REIMPLEMENT/D/G +REIN/D/S +REINCARNATE/D/N +REINDEER +REINFORCE/D/R/G/S +REINFORCEMENT/M/S +REINITIALIZE/D/G +REINSERT/D/G/S +REINSTATE/D/G/S +REINSTATEMENT +REINTERPRET/D/G/S +REINTRODUCE/D/G/S +REINVENT/D/G/S +REITERATE/D/G/N/S +REJECT/D/G/S +REJECTION/M/S +REJECTOR/M/S +REJOICE/D/R/G/S +REJOIN/D/G/S +RELABEL/S/D/G/R/Z +RELAPSE +RELATE/D/R/G/N/X/S +RELATIONAL/Y +RELATIONSHIP/M/S +RELATIVE/P/Y/S +RELATIVISM +RELATIVISTIC +RELATIVISTICALLY +RELATIVITY +RELAX/D/R/G/S +RELAXATION/M/S +RELAY/D/G/S +RELEARN/D/G +RELEASE/D/G/S +RELEGATE/D/G/S +RELENT/D/G/S +RELENTLESS/P/Y +RELEVANCE/S +RELEVANT/Y +RELIABILITY +RELIABLE/P +RELIABLY +RELIANCE +RELIC/M/S +RELIEF +RELIEVE/D/R/Z/G/S +RELIGION/M/S +RELIGIOUS/P/Y +RELINQUISH/D/G/S +RELISH/D/G/S +RELIVE/G/S +RELOAD/D/R/G/S +RELOCATE/D/G/N/X/S +RELUCTANCE +RELUCTANT/Y +RELY/D/G/S +REMAIN/D/G/S +REMAINDER/M/S +REMARK/D/G/S +REMARKABLE/P +REMARKABLY +REMEDIAL +REMEDY/D/G/S +REMEMBER/D/G/S +REMEMBRANCE/M/S +REMIND/D/R/Z/G/S +REMINISCENCE/M/S +REMINISCENT/Y +REMITTANCE +REMNANT/M/S +REMODEL/D/G/S +REMONSTRATE/D/G/N/V/S +REMORSE +REMOTE/P/T/Y +REMOVABLE +REMOVAL/M/S +REMOVE/D/R/G/S +RENAISSANCE +RENAL +RENAME/D/G/S +REND/Z/G/S +RENDER/D/G/J/S +RENDEZVOUS +RENDITION/M/S +RENEW/D/R/G/S +RENEWAL +RENOUNCE/G/S +RENOWN/D +RENT/D/G/S +RENTAL/M/S +RENUMBER/G/S +REOPEN/D/G/S +REORDER/D/G/S +REORGANIZATION/M/S +REORGANIZE/D/G/S +REPAID +REPAIR/D/R/G/S +REPAIRMAN +REPARATION/M/S +REPAST/M/S +REPAY/G/S +REPEAL/D/R/G/S +REPEAT/D/R/Z/G/S +REPEATABLE +REPEATEDLY +REPEL/S +REPENT/D/G/S +REPENTANCE +REPERCUSSION/M/S +REPERTOIRE +REPETITION/M/S +REPETITIVE/P/Y +REPHRASE/D/G/S +REPINE +REPLACE/D/R/G/S +REPLACEABLE +REPLACEMENT/M/S +REPLAY/D/G/S +REPLENISH/D/G/S +REPLETE/P/N +REPLICA +REPLICATE/D/G/N/S +REPLY/D/G/N/X/S +REPORT/D/R/Z/G/S +REPORTEDLY +REPOSE/D/G/S +REPOSITION/D/G/S +REPOSITORY/M/S +REPRESENT/D/G/S +REPRESENTABLE +REPRESENTABLY +REPRESENTATION/M/S +REPRESENTATIONAL/Y +REPRESENTATIVE/P/Y/S +REPRESS/D/G/V/S +REPRESSION/M/S +REPRIEVE/D/G/S +REPRINT/D/G/S +REPRISAL/M/S +REPROACH/D/G/S +REPRODUCE/D/R/Z/G/S +REPRODUCIBILITY/S +REPRODUCIBLE +REPRODUCIBLY +REPRODUCTION/M/S +REPROGRAM/S +REPROGRAMMED +REPROGRAMMING +REPROOF +REPROVE/R +REPTILE/M/S +REPUBLIC/M/S +REPUBLICAN/M/S +REPUDIATE/D/G/N/X/S +REPULSE/D/G/N/X/V/S +REPUTABLE +REPUTABLY +REPUTATION/M/S +REPUTE/D/S +REPUTEDLY +REQUEST/D/R/Z/G/S +REQUIRE/D/G/S +REQUIREMENT/M/S +REQUISITE/X/S +REQUISITION/D/G/S +REREAD +REROUTE/D/G/S +RESCUE/D/R/Z/G/S +RESEARCH/D/R/Z/G/S +RESELECT/D/G/S +RESEMBLANCE/M/S +RESEMBLE/D/G/S +RESENT/D/G/S +RESENTFUL/Y +RESENTMENT +RESERVATION/M/S +RESERVE/D/R/G/S +RESERVOIR/M/S +RESET/S +RESETTING/S +RESHAPE/D/G +RESIDE/D/G/S +RESIDENCE/M/S +RESIDENT/M/S +RESIDENTIAL/Y +RESIDUE/M/S +RESIGN/D/G/S +RESIGNATION/M/S +RESIN/M/S +RESIST/D/G/V/S +RESISTANCE/S +RESISTANT/Y +RESISTIBLE +RESISTIBLY +RESISTIVITY +RESISTOR/M/S +RESIZE/D/G +RESOLUTE/P/N/X/Y +RESOLVABLE +RESOLVE/D/R/Z/G/S +RESONANCE/S +RESONANT +RESORT/D/G/S +RESOUND/G/S +RESOURCE/M/S +RESOURCEFUL/P/Y +RESPECT/D/R/G/V/S +RESPECTABILITY +RESPECTABLE +RESPECTABLY +RESPECTFUL/P/Y +RESPECTIVELY +RESPIRATION +RESPITE +RESPLENDENT/Y +RESPOND/D/R/G/S +RESPONDENT/M/S +RESPONSE/V/S +RESPONSIBILITY/S +RESPONSIBLE/P +RESPONSIBLY +RESPONSIVELY +RESPONSIVENESS +REST/D/G/V/S +RESTART/D/G/S +RESTATE/D/G/S +RESTATEMENT +RESTAURANT/M/S +RESTFUL/P/Y +RESTLESS/P/Y +RESTORATION/M/S +RESTORE/D/R/Z/G/S +RESTRAIN/D/R/Z/G/S +RESTRAINT/M/S +RESTRICT/D/G/V/S +RESTRICTION/M/S +RESTRICTIVELY +RESTRUCTURE/D/G/S +RESULT/D/G/S +RESULTANT/Y/S +RESUMABLE +RESUME/D/G/S +RESUMPTION/M/S +RESURRECT/D/G/S +RESURRECTION/M/S +RESURRECTOR/S +RETAIL/R/Z/G +RETAIN/D/R/Z/G/S +RETAINMENT +RETALIATION +RETARD/D/R/G +RETENTION/S +RETENTIVE/P/Y +RETHINK +RETICLE/M/S +RETICULAR +RETICULATE/D/G/N/Y/S +RETINA/M/S +RETINAL +RETINUE +RETIRE/D/G/S +RETIREMENT/M/S +RETORT/D/S +RETRACE/D/G +RETRACT/D/G/S +RETRACTION/S +RETRAIN/D/G/S +RETRANSMISSION/M/S +RETRANSMIT/S +RETRANSMITTED +RETRANSMITTING +RETREAT/D/G/S +RETRIEVABLE +RETRIEVAL/M/S +RETRIEVE/D/R/Z/G/S +RETROACTIVE +RETROACTIVELY +RETROSPECT/V +RETROSPECTION +RETRY/D/R/Z/G/S +RETURN/D/R/G/S +RETURNABLE +RETYPE/D/G/S +REUNION/M/S +REUNITE/D/G +REUSABILITY +REUSABLE +REUSE/D/G/S +REVAMP/D/G/S +REVEAL/D/G/S +REVEL/D/R/G/S +REVELATION/M/S +REVELRY +REVENGE/R +REVENUE/Z/S +REVERE/D/G/S +REVERENCE +REVEREND/M/S +REVERENTLY +REVERIFY/D/G/S +REVERSAL/M/S +REVERSE/D/R/G/N/Y/S +REVERSIBLE +REVERT/D/G/S +REVIEW/D/R/Z/G/S +REVILE/D/R/G +REVISE/D/R/G/N/X/S +REVISION/M/S +REVISIT/D/G/S +REVIVAL/M/S +REVIVE/D/R/G/S +REVOCATION +REVOKE/D/R/G/S +REVOLT/D/R/G/S +REVOLTINGLY +REVOLUTION/M/S +REVOLUTIONARY/M/S +REVOLUTIONIZE/D/R +REVOLVE/D/R/Z/G/S +REWARD/D/G/S +REWARDINGLY +REWIND/G/S +REWORK/D/G/S +REWOUND +REWRITE/G/S +REWRITTEN +RHETORIC +RHEUMATISM +RHEUMATOLOGY +RHINOCEROS +RHUBARB +RHYME/D/G/S +RHYTHM/M/S +RHYTHMIC +RHYTHMICALLY +RIB/M/S +RIBBED +RIBBING +RIBBON/M/S +RICE +RICH/P/T/R/Y/S +RICHARD/M +RICK/M +RICKSHAW/M/S +RID +RIDDEN +RIDDLE/D/G/S +RIDE/R/Z/G/S +RIDGE/M/S +RIDICULE/D/G/S +RIDICULOUS/P/Y +RIFLE/D/R/G/S +RIFLEMAN +RIFT +RIG/M/S +RIGGING +RIGHT/P/D/R/G/Y/S +RIGHTEOUS/P/Y +RIGHTFUL/P/Y +RIGHTMOST +RIGHTWARD +RIGID/Y +RIGIDITY +RIGOR/S +RIGOROUS/Y +RILL +RIM/M/S +RIME +RIND/M/S +RING/D/R/Z/G/J/S +RINGINGLY +RINSE/D/R/G/S +RIOT/D/R/Z/G/S +RIOTOUS +RIP/N/S +RIPE/P/Y +RIPPED +RIPPING +RIPPLE/D/G/S +RISE/R/Z/G/J/S +RISEN +RISK/D/G/S +RITE/M/S +RITUAL/Y/S +RIVAL/D/S/G +RIVALLED +RIVALLING +RIVALRY/M/S +RIVER/M/S +RIVERSIDE +RIVET/R/S +RIVULET/M/S +ROAD/M/S +ROADSIDE +ROADSTER/M/S +ROADWAY/M/S +ROAM/D/G/S +ROAR/D/R/G/S +ROAST/D/R/G/S +ROB/S/M +ROBBED +ROBBER/M/S +ROBBERY/M/S +ROBBING +ROBE/D/G/S +ROBERT/M +ROBIN/M/S +ROBOT/M/S +ROBOTIC +ROBOTICS +ROBUST/P/Y +ROCK/D/R/Z/G/S +ROCKET/D/G/S +ROCKY/S +ROD/M/S +RODE +ROE +ROGER/M +ROGUE/M/S +ROLE/M/S +ROLL/D/R/Z/G/S +ROMAN +ROMANCE/R/Z/G/S +ROMANTIC/M/S +ROMP/D/R/G/S +ROOF/D/R/G/S +ROOK +ROOM/D/R/Z/G/S +ROOST/R/Z +ROOT/D/R/M/G/S +ROPE/D/R/Z/G/S +ROSE/M/S +ROSEBUD/M/S +ROSY/P +ROT/S +ROTARY +ROTATE/D/G/N/X/S +ROTATOR +ROTTEN/P +ROUGE +ROUGH/P/D/T/R/N/Y +ROUND/P/D/T/R/G/Y/S +ROUNDABOUT +ROUNDEDNESS +ROUNDOFF +ROUSE/D/G/S +ROUT +ROUTE/D/R/Z/G/J/S +ROUTINE/Y/S +ROVE/D/R/G/S +ROW/D/R/G/S +ROY/M +ROYAL/Y +ROYALIST/M/S +ROYALTY/M/S +RUB/X/S +RUBBED +RUBBER/M/S +RUBBING +RUBBISH +RUBBLE +RUBLE/M/S +RUBOUT +RUBY/M/S +RUDDER/M/S +RUDDY/P +RUDE/P/Y +RUDIMENT/M/S +RUDIMENTARY +RUE +RUEFULLY +RUFFIAN/Y/S +RUFFLE/D/S +RUG/M/S +RUGGED/P/Y +RUIN/D/G/S +RUINATION/M/S +RUINOUS/Y +RULE/D/R/Z/G/J/S +RUM/N +RUMBLE/D/R/G/S +RUMOR/D/S +RUMP/Y +RUMPLE/D +RUN/S +RUNAWAY +RUNG/M/S +RUNNER/M/S +RUNNING +RUNTIME +RUPTURE/D/G/S +RURAL/Y +RUSH/D/R/G/S +RUSSELL/M +RUSSET +RUSSIAN/M/S +RUST/D/G/S +RUSTIC +RUSTICATE/D/G/N/S +RUSTLE/D/R/Z/G +RUSTY +RUT/M/S +RUTGERS +RUTH/M +RUTHLESS/P/Y +RYE +SABER/M/S +SABLE/M/S +SABOTAGE +SACK/R/G/S +SACRED/P/Y +SACRIFICE/D/R/Z/G/S +SACRIFICIAL/Y +SAD/P/Y +SADDEN/D/S +SADDER +SADDEST +SADDLE/D/S +SADISM +SADIST/M/S +SADISTIC +SADISTICALLY +SAFE/P/T/R/Y/S +SAFEGUARD/D/G/S +SAFETY/S +SAG/S +SAGACIOUS +SAGACITY +SAGE/Y/S +SAID +SAIL/D/G/S +SAILOR/Y/S +SAINT/D/Y/S +SAKE/S +SALABLE +SALAD/M/S +SALARY/D/S +SALE/M/S +SALESMAN +SALESMEN +SALIENT +SALINE +SALIVA +SALLOW +SALLY/G/S +SALMON +SALON/M/S +SALOON/M/S +SALT/D/R/Z/G/S +SALTY/P/T/R +SALUTARY +SALUTATION/M/S +SALUTE/D/G/S +SALVAGE/D/R/G/S +SALVATION +SALVE/R/S +SAM/M +SAME/P +SAMPLE/D/R/Z/G/J/S +SAN +SANCTIFY/D/N +SANCTION/D/G/S +SANCTITY +SANCTUARY/M/S +SAND/D/R/Z/G/S +SANDAL/M/S +SANDPAPER +SANDSTONE +SANDWICH/S +SANDY +SANE/T/R/Y +SANG +SANGUINE +SANITARIUM +SANITARY +SANITATION +SANITY +SANK +SANTA/M +SAP/M/S +SAPLING/M/S +SAPPHIRE +SARCASM/M/S +SARCASTIC +SASH +SAT +SATCHEL/M/S +SATE/D/G/S +SATELLITE/M/S +SATIN +SATIRE/M/S +SATISFACTION/M/S +SATISFACTORILY +SATISFACTORY +SATISFIABILITY +SATISFIABLE +SATISFY/D/G/S +SATURATE/D/G/N/S +SATURDAY/M/S +SATYR +SAUCE/R/Z/S +SAUCEPAN/M/S +SAUCY +SAUL/M +SAUNA +SAUNTER +SAUSAGE/M/S +SAVAGE/P/D/R/Z/G/Y/S +SAVE/D/R/Z/G/J/S +SAVIOR/M/S +SAVOR/D/G/S +SAVORY +SAW/D/G/S +SAWMILL/M/S +SAWTOOTH +SAY/R/Z/G/J/S +SCABBARD/M/S +SCAFFOLD/G/J/S +SCALABLE +SCALAR/M/S +SCALD/D/G +SCALE/D/G/J/S +SCALLOP/D/S +SCALP/M/S +SCALY +SCAMPER/G/S +SCAN/S +SCANDAL/M/S +SCANDALOUS +SCANNED +SCANNER/M/S +SCANNING +SCANT/Y +SCANTILY +SCANTY/P/T/R +SCAR/M/S +SCARCE/P/Y +SCARCITY +SCARE/D/G/S +SCARF +SCARLET +SCARY +SCATTER/D/G/S +SCENARIO/M/S +SCENE/M/S +SCENERY +SCENIC +SCENT/D/S +SCEPTER/M/S +SCHEDULE/D/R/Z/G/S +SCHEMA/M/S +SCHEMATA +SCHEMATIC/S +SCHEMATICALLY +SCHEME'S +SCHEME/D/R/Z/G/S +SCHENLEY +SCHIZOPHRENIA +SCHOLAR/Y/S +SCHOLARSHIP/M/S +SCHOLASTIC/S +SCHOLASTICALLY +SCHOOL/D/R/Z/G/S +SCHOOLBOY/M/S +SCHOOLHOUSE/M/S +SCHOOLMASTER/M/S +SCHOOLMATE +SCHOOLROOM/M/S +SCHOONER +SCIENCE/M/S +SCIENTIFIC +SCIENTIFICALLY +SCIENTIST/M/S +SCISSOR/D/G/S +SCOFF/D/R/G/S +SCOLD/D/G/S +SCOOP/D/G/S +SCOPE/D/G/S +SCORCH/D/R/G/S +SCORE/D/R/Z/G/J/S +SCORN/D/R/G/S +SCORNFUL/Y +SCORPION/M/S +SCOTLAND +SCOTT/M +SCOUNDREL/M/S +SCOUR/D/G/S +SCOURGE +SCOUT/D/G/S +SCOW +SCOWL/D/G/S +SCRAMBLE/D/R/G/S +SCRAP/M/S +SCRAPE/D/R/Z/G/J/S +SCRAPPED +SCRATCH/D/R/Z/G/S +SCRATCHPAD/M/S +SCRAWL/D/G/S +SCREAM/D/R/Z/G/S +SCREECH/D/G/S +SCREEN/D/G/J/S +SCREW/D/G/S +SCRIBBLE/D/R/S +SCRIBE/G/S +SCRIPT/M/S +SCRIPTURE/S +SCROLL/D/G/S +SCRUB +SCRUPLE +SCRUPULOUS/Y +SCRUTINIZE/D/G +SCRUTINY +SCS +SCUFFLE/D/G/S +SCULPT/D/S +SCULPTOR/M/S +SCULPTURE/D/S +SCURRY/D +SCUTTLE/D/G/S +SCYTHE/M/S +SEA/Y/S +SEABOARD +SEACOAST/M/S +SEAL/D/R/G/S +SEALEVEL +SEAM/D/G/N/S +SEAMAN +SEAN/M +SEAPORT/M/S +SEAR/D/G/S +SEARCH/D/R/Z/G/J/S +SEARCHINGLY +SEARING/Y +SEASHORE/M/S +SEASIDE +SEASON/D/R/Z/G/J/S +SEASONABLE +SEASONABLY +SEASONAL/Y +SEAT/D/G/S +SEAWARD +SEAWEED +SECEDE/D/G/S +SECLUDED +SECLUSION +SECOND/D/R/Z/G/Y/S +SECONDARILY +SECONDARY +SECONDHAND +SECRECY +SECRET/Y/S +SECRETARIAL +SECRETARY/M/S +SECRETE/D/G/N/X/V/S +SECRETIVELY +SECT/M/S +SECTION/D/G/S +SECTIONAL +SECTOR/M/S +SECULAR +SECURE/D/G/Y/J/S +SECURITY/S +SEDGE +SEDIMENT/M/S +SEDUCE/D/R/Z/G/S +SEDUCTIVE +SEE/R/Z/S +SEED/D/R/Z/G/J/S +SEEDLING/M/S +SEEING +SEEK/R/Z/G/S +SEEM/D/G/Y/S +SEEMINGLY +SEEN +SEEP/D/G/S +SEETHE/D/G/S +SEGMENT/D/G/S +SEGMENTATION/M/S +SEGREGATE/D/G/N/S +SEISMIC +SEIZE/D/G/S +SEIZURE/M/S +SELDOM +SELECT/D/G/V/S +SELECTABLE +SELECTION/M/S +SELECTIVE/Y +SELECTIVITY +SELECTOR/M/S +SELF +SELFISH/P/Y +SELFSAME +SELL/R/Z/G/S +SELVES +SEMANTIC/S +SEMANTICAL/Y +SEMANTICIST/M/S +SEMAPHORE/M/S +SEMBLANCE +SEMESTER/M/S +SEMI +SEMIAUTOMATED +SEMIAUTOMATIC +SEMICOLON/M/S +SEMICONDUCTOR/M/S +SEMINAL +SEMINAR/M/S +SEMINARY/M/S +SEMIPERMANENT/Y +SENATE/M/S +SENATOR/M/S +SEND/R/Z/G/S +SENIOR/M/S +SENIORITY +SENSATION/M/S +SENSATIONAL/Y +SENSE/D/G/S +SENSELESS/P/Y +SENSIBILITY/S +SENSIBLE +SENSIBLY +SENSITIVE/P/Y/S +SENSITIVITY/S +SENSOR/M/S +SENSORY +SENT +SENTENCE/D/G/S +SENTENTIAL +SENTIMENT/M/S +SENTIMENTAL/Y +SENTINEL/M/S +SENTRY/M/S +SEPARABLE +SEPARATE/P/D/G/N/X/Y/S +SEPARATOR/M/S +SEPTEMBER +SEPULCHER/M/S +SEQUEL/M/S +SEQUENCE/D/R/Z/G/J/S +SEQUENTIAL/Y +SEQUENTIALITY +SEQUENTIALIZE/D/G/S +SEQUESTER +SERENDIPITOUS +SERENDIPITY +SERENE/Y +SERENITY +SERF/M/S +SERGEANT/M/S +SERIAL/Y/S +SERIALIZATION/M/S +SERIALIZE/D/G/S +SERIES +SERIOUS/P/Y +SERMON/M/S +SERPENT/M/S +SERPENTINE +SERUM/M/S +SERVANT/M/S +SERVE/D/R/Z/G/J/S +SERVICE/D/G/S +SERVICEABLE +SERVILE +SERVITUDE +SESAME +SESSION/M/S +SET/M/S +SETTER/M/S +SETTING/S +SETTLE/D/R/Z/G/S +SETTLEMENT/M/S +SETUP/S +SEVEN/H/S +SEVENTEEN/H/S +SEVENTY/H/S +SEVER/S +SEVERAL/Y +SEVERANCE +SEVERE/D/T/R/G/Y +SEVERITY/M/S +SEW/D/R/Z/G/S +SEX/D/S +SEXUAL/Y +SEXUALITY +SHABBY +SHACK/D/S +SHACKLE/D/G/S +SHADE/D/G/J/S +SHADILY +SHADOW/D/G/S +SHADOWY +SHADY/P/T/R +SHAFT/M/S +SHAGGY +SHAKABLE +SHAKABLY +SHAKE/R/Z/G/S +SHAKEN +SHAKY/P +SHALE +SHALL +SHALLOW/P/R/Y +SHAM/M/S +SHAMBLES +SHAME/D/G/S +SHAMEFUL/Y +SHAMELESS/Y +SHAN'T +SHANGHAI +SHANTY/M/S +SHAPE/D/R/Z/G/Y/S +SHAPELESS/P/Y +SHARABLE +SHARE/D/R/Z/G/S +SHARECROPPER/M/S +SHAREHOLDER/M/S +SHARK/M/S +SHARON/M +SHARP/P/T/R/N/X/Y +SHARPENED +SHARPENING +SHATTER/D/G/S +SHAVE/D/G/J/S +SHAVEN +SHAWL/M/S +SHE'LL +SHE/M +SHEAF +SHEAR/D/R/G/S +SHEATH/G +SHEATHS +SHEAVES +SHED/S +SHEEP +SHEER/D +SHEET/D/G/S +SHELF +SHELL/D/R/G/S +SHELTER/D/G/S +SHELVE/D/G/S +SHEPHERD/M/S +SHERIFF/M/S +SHIELD/D/G/S +SHIFT/D/R/Z/G/S +SHIFTILY +SHIFTY/P/T/R +SHILLING/S +SHIMMER/G +SHIN +SHINE/D/R/Z/G/S +SHINGLE/M/S +SHININGLY +SHINY +SHIP/M/S +SHIPBOARD +SHIPBUILDING +SHIPMENT/M/S +SHIPPED +SHIPPER/M/S +SHIPPING +SHIPWRECK/D/S +SHIRK/R/G/S +SHIRT/G/S +SHIVER/D/R/G/S +SHOAL/M/S +SHOCK/D/R/Z/G/S +SHOCKINGLY +SHOD +SHOE/D/S +SHOEING +SHOEMAKER +SHONE +SHOOK +SHOOT/R/Z/G/J/S +SHOP/M/S +SHOPKEEPER/M/S +SHOPPED +SHOPPER/M/S +SHOPPING +SHORE/M/S +SHORN +SHORT/P/D/T/R/G/Y/S +SHORTAGE/M/S +SHORTCOMING/M/S +SHORTCUT/M/S +SHORTEN/D/G/S +SHORTHAND/D +SHOT/M/S +SHOTGUN/M/S +SHOULD/Z +SHOULDER/D/G/S +SHOULDN'T +SHOUT/D/R/Z/G/S +SHOVE/D/G/S +SHOVEL/D/S +SHOW/D/R/Z/G/J/S +SHOWER/D/G/S +SHOWN +SHRANK +SHRED/M/S +SHREW/M/S +SHREWD/P/T/Y +SHRIEK/D/G/S +SHRILL/P/D/G +SHRILLY +SHRIMP +SHRINE/M/S +SHRINK/G/S +SHRINKABLE +SHRIVEL/D +SHROUD/D +SHRUB/M/S +SHRUBBERY +SHRUG/S +SHRUNK/N +SHUDDER/D/G/S +SHUFFLE/D/G/S +SHUN/S +SHUT/S +SHUTDOWN/M/S +SHUTTER/D/S +SHUTTING +SHUTTLE/D/G/S +SHY/D/Y/S +SHYNESS +SIBLING/M/S +SICK/T/R/N/Y +SICKLE +SICKNESS/M/S +SIDE/D/G/J/S +SIDEBOARD/M/S +SIDEBURN/M/S +SIDELIGHT/M/S +SIDEWALK/M/S +SIDEWAYS +SIDEWISE +SIEGE/M/S +SIEMENS +SIERRA +SIEVE/M/S +SIFT/D/R/G +SIGH/D/G +SIGHS +SIGHT/D/G/Y/J/S +SIGMA +SIGN/D/R/Z/G/S +SIGNAL/D/G/Y/S/R +SIGNALLED +SIGNALLER +SIGNALLING +SIGNATURE/M/S +SIGNET +SIGNIFICANCE +SIGNIFICANT/Y/S +SIGNIFY/D/G/N/S +SIGNOR +SIKKIM +SILENCE/D/R/Z/G/S +SILENT/Y +SILHOUETTE/D/S +SILICON +SILICONE +SILK/N/S +SILKILY +SILKINE +SILKY/T/R +SILL/M/S +SILLY/P/T +SILT/D/G/S +SILVER/D/G/S +SILVERY +SIMILAR/Y +SIMILARITY/S +SIMILITUDE +SIMMER/D/G/S +SIMON/M +SIMPLE/P/T/R +SIMPLEX +SIMPLICITY/M/S +SIMPLIFY/D/R/Z/G/N/X/S +SIMPLISTIC +SIMPLY +SIMULATE/D/G/N/X/S +SIMULATOR/M/S +SIMULTANEITY +SIMULTANEOUS/Y +SIN/M/S +SINCE +SINCERE/T/Y +SINCERITY +SINE/S +SINEW/M/S +SINFUL/P/Y +SING/D/R/Z/G/Y/S +SINGABLE +SINGAPORE +SINGINGLY +SINGLE/P/D/G/S +SINGLETON/M/S +SINGULAR/Y +SINGULARITY/M/S +SINISTER +SINK/D/R/Z/G/S +SINNED +SINNER/M/S +SINNING +SINUSITIS +SINUSOIDAL +SINUSOIDS +SIP/S +SIR/N/X/S +SIRE/D/S +SIRUP +SISTER/Y/S +SIT/S +SITE/D/G/S +SITTER/M/S +SITTING/S +SITUATE/D/G/N/X/S +SITUATIONAL/Y +SIX/H/S +SIXPENCE +SIXTEEN/H/S +SIXTY/H/S +SIZABLE +SIZE/D/G/J/S +SKATE/D/R/Z/G/S +SKELETAL +SKELETON/M/S +SKEPTIC/M/S +SKEPTICAL/Y +SKETCH/D/G/S +SKETCHILY +SKETCHY +SKEW/D/R/Z/G/S +SKI/G/S +SKILL/D/S +SKILLFUL/P/Y +SKIM/M/S +SKIMP/D/G/S +SKIN/M/S +SKINNED +SKINNER/M/S +SKINNING +SKIP/S +SKIPPED +SKIPPER/M/S +SKIPPING +SKIRMISH/D/R/Z/G/S +SKIRT/D/G/S +SKULK/D/R/G/S +SKULL/M/S +SKUNK/M/S +SKY/M/S +SKYLARK/G/S +SKYLIGHT/M/S +SKYSCRAPER/M/S +SLAB +SLACK/P/R/G/N/Y/S +SLAIN +SLAM/S +SLAMMED +SLAMMING +SLANDER/R/S +SLANG +SLANT/D/G/S +SLAP/S +SLAPPED +SLAPPING +SLASH/D/G/S +SLAT/M/S +SLATE/D/R/S +SLAUGHTER/D/G/S +SLAVE/R/S +SLAVERY +SLAY/R/Z/G/S +SLED/M/S +SLEDGE/M/S +SLEEK +SLEEP/R/Z/G/S +SLEEPILY +SLEEPLESS/P/Y +SLEEPY/P +SLEET +SLEEVE/M/S +SLEIGH +SLEIGHS +SLENDER/R +SLEPT +SLEW/G +SLICE/D/R/Z/G/S +SLICK/R/Z/S +SLID +SLIDE/R/Z/G/S +SLIGHT/P/D/T/R/G/Y/S +SLIM/Y +SLIME/D +SLIMY +SLING/G/S +SLIP/M/S +SLIPPAGE +SLIPPED +SLIPPER/M/S +SLIPPERY/P +SLIPPING +SLIT/M/S +SLOGAN/M/S +SLOP/S +SLOPE/D/R/Z/G/S +SLOPPED +SLOPPING +SLOPPY/P +SLOT/M/S +SLOTH +SLOTHS +SLOTTED +SLOUCH/D/G/S +SLOW/P/D/T/R/G/Y/S +SLUG/S +SLUGGISH/P/Y +SLUM/M/S +SLUMBER/D +SLUMP/D/S +SLUNG +SLUR/M/S +SLY/Y +SMACK/D/G/S +SMALL/P/T/R +SMALLPOX +SMALLTALK +SMART/P/D/T/R/Y +SMASH/D/R/Z/G/S +SMASHINGLY +SMEAR/D/G/S +SMELL/D/G/S +SMELLY +SMELT/R/S +SMILE/D/G/S +SMILINGLY +SMITE +SMITH +SMITHS +SMITHY +SMITTEN +SMOCK/G/S +SMOG +SMOKABLE +SMOKE/D/R/Z/G/S +SMOKY/S +SMOLDER/D/G/S +SMOOTH/P/D/T/R/G/Y/S +SMOTE +SMOTHER/D/G/S +SMUGGLE/D/R/Z/G/S +SNAIL/M/S +SNAKE/D/S +SNAP/S +SNAPPED +SNAPPER/M/S +SNAPPILY +SNAPPING +SNAPPY +SNAPSHOT/M/S +SNARE/D/G/S +SNARL/D/G +SNATCH/D/G/S +SNEAK/D/R/Z/G/S +SNEAKILY +SNEAKY/P/T/R +SNEER/D/G/S +SNEEZE/D/G/S +SNIFF/D/G/S +SNOOP/D/G/S +SNORE/D/G/S +SNORT/D/G/S +SNOUT/M/S +SNOW/D/G/S +SNOWILY +SNOWMAN +SNOWMEN +SNOWSHOE/M/S +SNOWY/T/R +SNUFF/D/R/G/S +SNUG/P/Y +SNUGGLE/D/G/S +SO +SOAK/D/G/S +SOAP/D/G/S +SOAR/D/G/S +SOB/R/S +SOBER/P/D/G/Y/S +SOCCER +SOCIABILITY +SOCIABLE +SOCIABLY +SOCIAL/Y +SOCIALISM +SOCIALIST/M/S +SOCIALIZATION +SOCIALIZE/D/G/S +SOCIETAL +SOCIETY/M/S +SOCIOLOGICAL/Y +SOCIOLOGY +SOCK/D/G/S +SOCKET/M/S +SOD/M/S +SODA +SODIUM +SODOMY +SOFA/M/S +SOFT/P/T/R/X/Y +SOFTEN/D/G/S +SOFTWARE/M/S +SOIL/D/G/S +SOJOURN/R/Z +SOLACE/D +SOLAR +SOLD/R +SOLDIER/G/Y/S +SOLE/Y/S +SOLEMN/P/Y +SOLEMNITY +SOLICIT/D/G/S +SOLICITOR +SOLID/P/Y/S +SOLIDIFY/D/G/N/S +SOLIDITY +SOLITAIRE +SOLITARY +SOLITUDE/M/S +SOLO/M/S +SOLUBILITY +SOLUBLE +SOLUTION/M/S +SOLVABLE +SOLVE/D/R/Z/G/S +SOLVENT/M/S +SOMBER/Y +SOME +SOMEBODY +SOMEDAY +SOMEHOW +SOMEONE/M +SOMETHING +SOMETIME/S +SOMEWHAT +SOMEWHERE +SON/M/S +SONAR +SONG/M/S +SONNET/M/S +SOON/T/R +SOOT +SOOTH +SOOTHE/D/R/G/S +SOPHIE/M +SOPHISTICATED +SOPHISTICATION +SOPHOMORE/M/S +SORCERER/M/S +SORCERY +SORDID/P/Y +SORE/P/T/R/Y/S +SORROW/M/S +SORROWFUL/Y +SORRY/T/R +SORT/D/R/Z/G/S +SOUGHT +SOUL/M/S +SOUND/P/D/T/R/Y/S +SOUNDING/M/S +SOUP/M/S +SOUR/P/D/T/R/G/Y/S +SOURCE/M/S +SOUTH +SOUTHERN/R/Z +SOVEREIGN/M/S +SOVIET/M/S +SOY +SPACE/D/R/Z/G/J/S +SPACECRAFT/S +SPACESHIP/M/S +SPADE/D/G/S +SPAGHETTI +SPAIN +SPAN/M/S +SPANISH +SPANK/D/G/S +SPANKINGLY +SPANNED +SPANNER/M/S +SPANNING +SPARE/P/D/T/R/G/Y/S +SPARINGLY +SPARK/D/G/S +SPARROW/M/S +SPARSE/P/T/R/Y +SPAT +SPATE/M/S +SPATIAL/Y +SPATTER/D +SPAWN/D/G/S +SPEAK/R/Z/G/S +SPEAKABLE +SPEAR/D/S +SPECIAL/Y/S +SPECIALIST/M/S +SPECIALIZATION/M/S +SPECIALIZE/D/G/S +SPECIALTY/M/S +SPECIES +SPECIFIABLE +SPECIFIC/S +SPECIFICALLY +SPECIFICITY +SPECIFY/D/R/Z/G/N/X/S +SPECIMEN/M/S +SPECK/M/S +SPECKLE/D/S +SPECTACLE/D/S +SPECTACULAR/Y +SPECTATOR/M/S +SPECTER/M/S +SPECTRA +SPECTROGRAM/M/S +SPECTRUM +SPECULATE/D/G/N/X/V/S +SPECULATOR/M/S +SPED +SPEECH/M/S +SPEECHLESS/P +SPEED/D/R/Z/G/S +SPEEDILY +SPEEDUP/M/S +SPEEDY +SPELL/D/R/Z/G/J/S +SPENCER +SPEND/R/Z/G/S +SPENT +SPHERE/M/S +SPHERICAL/Y +SPICE/D/S +SPICY/P +SPIDER/M/S +SPIKE/D/S +SPILL/D/R/G/S +SPIN/S +SPINACH +SPINAL/Y +SPINDLE/G +SPINE +SPINNER/M/S +SPINNING +SPIRAL/D/G/Y +SPIRE/M/S +SPIRIT/D/G/S +SPIRITEDLY +SPIRITUAL/Y/S +SPIT/S +SPITE/D/G/S +SPITEFUL/P/Y +SPITTING +SPLASH/D/G/S +SPLEEN +SPLENDID/Y +SPLENDOR +SPLICE/D/R/Z/G/J/S +SPLINE/M/S +SPLINTER/D/S +SPLIT/M/S +SPLITTER/M/S +SPLITTING +SPOIL/D/R/Z/G/S +SPOKE/D/S +SPOKEN +SPOKESMAN +SPOKESMEN +SPONGE/D/R/Z/G/S +SPONSOR/D/G/S +SPONSORSHIP +SPONTANEOUS/Y +SPOOK +SPOOKY +SPOOL/D/R/G/S +SPOON/D/G/S +SPORE/M/S +SPORT/D/G/V/S +SPORTINGLY +SPORTSMAN +SPOT/M/S +SPOTLESS/Y +SPOTTED +SPOTTER/M/S +SPOTTING +SPOUSE/M/S +SPOUT/D/G/S +SPRANG +SPRAWL/D/G/S +SPRAY/D/R/G/S +SPREAD/R/Z/G/J/S +SPREE/M/S +SPRIG +SPRIGHTLY +SPRING/R/Z/G/S +SPRINGTIME +SPRINGY/P/T/R +SPRINKLE/D/R/G/S +SPRINT/D/R/Z/G/S +SPRITE +SPROUT/D/G +SPRUCE/D +SPRUNG +SPUN +SPUR/M/S +SPURIOUS +SPURN/D/G/S +SPURT/D/G/S +SPUTTER/D +SPY/G/S +SQUABBLE/D/G/S +SQUAD/M/S +SQUADRON/M/S +SQUALL/M/S +SQUARE/P/D/T/R/G/Y/S +SQUASH/D/G +SQUAT/S +SQUAWK/D/G/S +SQUEAK/D/G/S +SQUEAL/D/G/S +SQUEEZE/D/R/G/S +SQUID +SQUINT/D/G +SQUIRE/M/S +SQUIRM/D/S +SQUIRREL/D/G/S +SR +STAB/Y/S +STABBED +STABBING +STABILITY/M/S +STABILIZE/D/R/Z/G/S +STABLE/D/R/G/S +STACK/D/M/G/S +STAFF/D/R/Z/G/S +STAG/M/S +STAGE/D/R/Z/G/S +STAGECOACH +STAGGER/D/G/S +STAGNANT +STAID +STAIN/D/G/S +STAINLESS +STAIR/M/S +STAIRCASE/M/S +STAIRWAY/M/S +STAKE/D/S +STALE +STALK/D/G +STALL/D/G/J/S +STALWART/Y +STAMEN/M/S +STAMINA +STAMMER/D/R/G/S +STAMP/D/R/Z/G/S +STAMPEDE/D/G/S +STANCH/T +STAND/G/J/S +STANDARD/Y/S +STANDARDIZATION +STANDARDIZE/D/G/S +STANDBY +STANDPOINT/M/S +STANDSTILL +STANFORD +STANZA/M/S +STAPLE/R/G/S +STAR/M/S +STARBOARD +STARCH/D +STARE/D/R/G/S +STARFISH +STARK/Y +STARLIGHT +STARRED +STARRING +STARRY +START/D/R/Z/G/S +STARTLE/D/G/S +STARTUP/M/S +STARVATION +STARVE/D/G/S +STATE/D/M/G/X/Y/S +STATEMENT/M/S +STATESMAN +STATIC +STATICALLY +STATION/D/R/G/S +STATIONARY +STATISTIC/S +STATISTICAL/Y +STATISTICIAN/M/S +STATUE/M/S +STATUESQUE/P/Y +STATURE +STATUS/S +STATUTE/M/S +STATUTORILY +STATUTORY/P +STAUNCH/T/Y +STAVE/D/S +STAY/D/G/S +STEAD +STEADFAST/P/Y +STEADILY +STEADY/P/D/T/R/G/S +STEAK/M/S +STEAL/R/G/H/S +STEALTHILY +STEALTHY +STEAM/D/R/Z/G/S +STEAMBOAT/M/S +STEAMSHIP/M/S +STEED +STEEL/D/Z/G/S +STEEP/P/D/T/R/G/Y/S +STEEPLE/M/S +STEER/D/G/S +STELLAR +STEM/M/S +STEMMED +STEMMING +STENCH/M/S +STENCIL/M/S +STENOGRAPHER/M/S +STEP/M/S +STEPHEN/M +STEPMOTHER/M/S +STEPPED +STEPPING +STEPWISE +STEREO/M/S +STEREOGRAPHIC +STEREOTYPE/D/S +STEREOTYPICAL +STERILE +STERILIZATION/M/S +STERILIZE/D/R/G/S +STERLING +STERN/P/Y/S +STEVE/M +STEW/D/S +STEWARD/M/S +STICK/G/R/S/Z +STICKILY +STICKY/P/T/R +STIFF/P/T/R/N/X/Y/S +STIFLE/D/G/S +STIGMA +STILE/M/S +STILL/P/D/T/R/G/S +STIMULANT/M/S +STIMULATE/D/G/N/X/V/S +STIMULI +STIMULUS +STING/G/S +STINK/R/Z/G/S +STINT +STIPEND/M/S +STIPULATE/D/G/N/X/S +STIR/S +STIRRED +STIRRER/M/S +STIRRING/Y/S +STIRRUP +STITCH/D/G/S +STOCHASTIC +STOCHASTICALLY +STOCK/D/R/Z/G/J/S +STOCKADE/M/S +STOCKHOLDER/M/S +STOLE/M/S +STOLEN +STOMACH/D/R/G/S +STONE/D/G/S +STONY +STOOD +STOOL +STOOP/D/G/S +STOP/S +STOPCOCK/S +STOPPABLE +STOPPAGE +STOPPED +STOPPER/M/S +STOPPING +STORAGE/M/S +STORE/D/G/S +STOREHOUSE/M/S +STORK/M/S +STORM/D/G/S +STORMY/P/T/R +STORY/D/S +STOUT/P/T/R/Y +STOVE/M/S +STOW/D +STRAGGLE/D/R/Z/G/S +STRAIGHT/P/T/R/N/X +STRAIGHTFORWARD/P/Y +STRAIGHTWAY +STRAIN/D/R/Z/G/S +STRAIT/N/S +STRAND/D/G/S +STRANGE/P/R/Z/Y +STRANGEST +STRANGLE/D/R/Z/G/J/S +STRANGULATION/M/S +STRAP/M/S +STRATAGEM/M/S +STRATEGIC +STRATEGY/M/S +STRATIFY/D/N/X/S +STRATUM +STRAW/M/S +STRAWBERRY/M/S +STRAY/D/S +STREAK/D/S +STREAM/D/R/Z/G/S +STREAMLINE/D/R/G/S +STREET/Z/S +STREETCAR/M/S +STRENGTH/N +STRENGTHEN/D/R/G/S +STRENGTHS +STRENUOUS/Y +STRESS/D/G/S +STRETCH/D/R/Z/G/S +STREW/S +STREWN +STRICT/P/T/R/Y +STRIDE/R/G/S +STRIFE +STRIKE/R/Z/G/S +STRIKINGLY +STRING'S +STRING/D/R/Z/G/S +STRINGENT/Y +STRINGY/P/T/R +STRIP/M/S +STRIPE/D/S +STRIPPED +STRIPPER/M/S +STRIPPING +STRIVE/G/J/S +STRODE +STROKE/D/R/Z/G/S +STROLL/D/R/G/S +STRONG/T/R/Y +STRONGHOLD +STROVE +STRUCK +STRUCTURAL/Y +STRUCTURE/D/R/G/S +STRUGGLE/D/G/S +STRUNG +STRUT/S +STUB/M/S +STUBBLE +STUBBORN/P/Y +STUCK +STUD/M/S +STUDENT/M/S +STUDIO/M/S +STUDIOUS/Y +STUDY/D/G/S +STUFF/D/G/S +STUFFY/T/R +STUMBLE/D/G/S +STUMP/D/G/S +STUN +STUNG +STUNNING/Y +STUNT/M/S +STUPEFY/G +STUPENDOUS/Y +STUPID/T/Y +STUPIDITY/S +STUPOR +STURDY/P +STYLE/D/R/Z/G/S +STYLISH/P/Y +STYLISTIC +STYLISTICALLY +STYLIZED +SUB/S +SUBATOMIC +SUBCLASS/M/S +SUBCOMPONENT/M/S +SUBCOMPUTATION/M/S +SUBCONSCIOUS/Y +SUBCULTURE/M/S +SUBDIVIDE/D/G/S +SUBDIVISION/M/S +SUBDUE/D/G/S +SUBEXPRESSION/M/S +SUBFIELD/M/S +SUBFILE/M/S +SUBGOAL/M/S +SUBGRAPH +SUBGRAPHS +SUBGROUP/M/S +SUBINTERVAL/M/S +SUBJECT/D/G/V/S +SUBJECTION +SUBJECTIVELY +SUBJECTIVITY +SUBLIMATION/S +SUBLIME/D +SUBLIST/M/S +SUBMARINE/R/Z/S +SUBMERGE/D/G/S +SUBMISSION/M/S +SUBMIT/S +SUBMITTED +SUBMITTING +SUBMODE/S +SUBMODULE/M/S +SUBNETWORK/M/S +SUBORDINATE/D/N/S +SUBPROBLEM/M/S +SUBPROGRAM/M/S +SUBPROJECT +SUBPROOF/M/S +SUBRANGE/M/S +SUBROUTINE/M/S +SUBSCHEMA/M/S +SUBSCRIBE/D/R/Z/G/S +SUBSCRIPT/D/G/S +SUBSCRIPTION/M/S +SUBSECTION/M/S +SUBSEGMENT/M/S +SUBSEQUENCE/M/S +SUBSEQUENT/Y +SUBSET/M/S +SUBSIDE/D/G/S +SUBSIDIARY/M/S +SUBSIDIZE/D/G/S +SUBSIDY/M/S +SUBSIST/D/G/S +SUBSISTENCE +SUBSPACE/M/S +SUBSTANCE/M/S +SUBSTANTIAL/Y +SUBSTANTIATE/D/G/N/X/S +SUBSTANTIVE/Y +SUBSTANTIVITY +SUBSTITUTABILITY +SUBSTITUTABLE +SUBSTITUTE/D/G/N/X/S +SUBSTRATE/M/S +SUBSTRING/S +SUBSTRUCTURE/M/S +SUBSUME/D/G/S +SUBSYSTEM/M/S +SUBTASK/M/S +SUBTERRANEAN +SUBTITLE/S +SUBTLE/P/T/R +SUBTLETY/S +SUBTLY +SUBTRACT/D/G/S/R/Z +SUBTRACTER'S +SUBTRACTION/S +SUBTRAHEND/M/S +SUBTREE/M/S +SUBTYPE/S +SUBUNIT/M/S +SUBURB/M/S +SUBURBAN +SUBVERSION +SUBVERT/D/R/G/S +SUBWAY/M/S +SUCCEED/D/G/S +SUCCESS/V/S +SUCCESSFUL/Y +SUCCESSION/M/S +SUCCESSIVELY +SUCCESSOR/M/S +SUCCINCT/P/Y +SUCCOR +SUCCUMB/D/G/S +SUCH +SUCK/D/R/Z/G/S +SUCKLE/G +SUCTION +SUDDEN/P/Y +SUDS/G +SUE/D/G/S +SUFFER/D/R/Z/G/J/S +SUFFERANCE +SUFFICE/D/G/S +SUFFICIENCY +SUFFICIENT/Y +SUFFIX/D/R/G/S +SUFFOCATE/D/G/N/S +SUFFRAGE +SUGAR/D/G/J/S +SUGGEST/D/G/V/S +SUGGESTIBLE +SUGGESTION/M/S +SUGGESTIVELY +SUICIDAL/Y +SUICIDE/M/S +SUIT/M/S +SUITABILITY +SUITABLE/P +SUITABLY +SUITCASE/M/S +SUITE/D/Z/G/S +SUITOR/M/S +SULK/D/G/S +SULKY/P +SULLEN/P/Y +SULPHATE +SULPHUR/D +SULPHURIC +SULTAN/M/S +SULTRY +SUM/M/S +SUMMAND/M/S +SUMMARIZATION/M/S +SUMMARIZE/D/G/S +SUMMARY/M/S +SUMMATION/M/S +SUMMED +SUMMER/M/S +SUMMING +SUMMIT +SUMMON/D/R/Z/G/S +SUMMONSES +SUMPTUOUS +SUN/M/S +SUNBEAM/M/S +SUNBURN +SUNDAY/M/S +SUNDOWN +SUNDRY/S +SUNG +SUNGLASS/S +SUNK/N +SUNLIGHT +SUNNED +SUNNING +SUNNY +SUNNYVALE +SUNRISE +SUNSET +SUNSHINE +SUP/R +SUPERB/Y +SUPERCLASS/S +SUPERCOMPUTER/M/S +SUPERCOMPUTING +SUPEREGO/M/S +SUPERFICIAL/Y +SUPERFLUITY/M/S +SUPERFLUOUS/Y +SUPERHUMAN/Y +SUPERIMPOSE/D/G/S +SUPERINTEND +SUPERINTENDENT/M/S +SUPERIOR/M/S +SUPERIORITY +SUPERLATIVE/Y/S +SUPERMARKET/M/S +SUPERPOSE/D/G/S +SUPERSCRIPT/D/G/S +SUPERSEDE/D/G/S +SUPERSET/M/S +SUPERSTITION/M/S +SUPERSTITIOUS +SUPERVISE/D/G/N/S +SUPERVISOR/M/S +SUPERVISORY +SUPPER/M/S +SUPPLANT/D/G/S +SUPPLE/P +SUPPLEMENT/D/G/S +SUPPLEMENTAL +SUPPLEMENTARY +SUPPLY/D/R/Z/G/N/S +SUPPORT/D/R/Z/G/V/S +SUPPORTABLE +SUPPORTINGLY +SUPPORTIVELY +SUPPOSE/D/G/S +SUPPOSEDLY +SUPPOSITION/M/S +SUPPRESS/D/G/S +SUPPRESSION +SUPREMACY +SUPREME/Y/P +SURE/P/Y +SURETY/S +SURF +SURFACE/P/D/G/S +SURGE/D/G/S +SURGEON/M/S +SURGERY +SURGICAL/Y +SURLY/P +SURMISE/D/S +SURMOUNT/D/G/S +SURNAME/M/S +SURPASS/D/G/S +SURPLUS/M/S +SURPRISE/D/G/S +SURPRISINGLY +SURRENDER/D/G/S +SURROGATE/M/S +SURROUND/D/G/J/S +SURVEY/D/G/S +SURVEYOR/M/S +SURVIVAL/S +SURVIVE/D/G/S +SURVIVOR/M/S +SUSCEPTIBLE +SUSPECT/D/G/S +SUSPEND/D/G/S +SUSPENDER/M/S +SUSPENSE/N/X/S +SUSPICION/M/S +SUSPICIOUS/Y +SUSTAIN/D/G/S +SUTURE/S +SUZANNE/M +SWAGGER/D/G +SWAIN/M/S +SWALLOW/D/G/S +SWAM +SWAMP/D/G/S +SWAMPY +SWAN/M/S +SWAP/S +SWAPPED +SWAPPING +SWARM/D/G/S +SWARTHY +SWATTED +SWAY/D/G +SWEAR/R/G/S +SWEAT/D/R/Z/G/S +SWEEP/R/Z/G/J/S +SWEET/P/T/R/X/Y/S +SWEETEN/D/R/Z/G/J/S +SWEETHEART/M/S +SWELL/D/G/J/S +SWEPT +SWERVE/D/G/S +SWIFT/P/T/R/Y +SWIM/S +SWIMMER/M/S +SWIMMING/Y +SWINE +SWING/R/Z/G/S +SWIRL/D/G +SWISH/D +SWITCH/D/R/Z/G/J/S +SWITCHBOARD/M/S +SWITZERLAND +SWOLLEN +SWOON +SWOOP/D/G/S +SWORD/M/S +SWORE +SWORN +SWUM +SWUNG +SYCAMORE +SYLLABI +SYLLABLE/M/S +SYLLABUS +SYLLOGISM/M/S +SYMBIOSIS +SYMBIOTIC +SYMBOL/M/S +SYMBOLIC +SYMBOLICALLY +SYMBOLISM +SYMBOLIZATION +SYMBOLIZE/D/G/S +SYMMETRIC +SYMMETRICAL/Y +SYMMETRY/M/S +SYMPATHETIC +SYMPATHIZE/D/R/Z/G/S +SYMPATHIZINGLY +SYMPATHY/M/S +SYMPHONY/M/S +SYMPOSIUM/S +SYMPTOM/M/S +SYMPTOMATIC +SYNAPSE/M/S +SYNCHRONIZATION +SYNCHRONIZE/D/R/Z/G/S +SYNCHRONOUS/Y +SYNCHRONY +SYNDICATE/D/N/S +SYNDROME/M/S +SYNERGISM +SYNERGISTIC +SYNONYM/M/S +SYNONYMOUS/Y +SYNOPSES +SYNOPSIS +SYNTACTIC +SYNTACTICAL/Y +SYNTAX +SYNTHESIS +SYNTHESIZE/D/R/Z/G/S +SYNTHETIC/S +SYRACUSE +SYRINGE/S +SYRUP +SYSTEM/M/S +SYSTEMATIC +SYSTEMATICALLY +SYSTEMATIZE/D/G/S +SYSTOLIC +TAB/S +TABERNACLE/M/S +TABLE/D/G/S +TABLEAU/M/S +TABLECLOTH +TABLECLOTHS +TABLESPOON/M/S +TABLESPOONFUL/M/S +TABLET/M/S +TABOO/M/S +TABULAR +TABULATE/D/G/N/X/S +TABULATOR/M/S +TACHOMETER/M/S +TACIT/Y +TACK/D/G +TACKLE/M/S +TACT +TACTICS +TACTILE +TAG/M/S +TAGGED +TAGGING +TAIL/D/G/S +TAILOR/D/G/S +TAINT/D +TAIWAN +TAKE/R/Z/G/J/S +TAKEN +TALE/M/S +TALENT/D/S +TALK/D/R/Z/G/S +TALKATIVE/P/Y +TALKIE +TALL/P/T/R +TALLOW +TAME/P/D/R/G/Y/S +TAMPER/D/G/S +TAN +TANDEM +TANG +TANGENT/M/S +TANGENTIAL +TANGIBLE +TANGIBLY +TANGLE/D +TANGY +TANK/R/Z/S +TANNER/M/S +TANTALIZING/Y +TANTAMOUNT +TANTRUM/M/S +TAP/M/S +TAPE/D/R/Z/G/J/S +TAPERED +TAPERING +TAPESTRY/M/S +TAPPED +TAPPER/M/S +TAPPING +TAPROOT/M/S +TAR +TARDY/P +TARGET/D/G/S +TARIFF/M/S +TARRY +TART/P/Y +TASK/D/G/S +TASSEL/M/S +TASTE/D/R/Z/G/S +TASTEFUL/P/Y +TASTELESS/Y +TASTY +TATTER/D +TATTOO/D/S +TAU +TAUGHT +TAUNT/D/R/G/S +TAUT/P/Y +TAUTOLOGICAL/Y +TAUTOLOGY/M/S +TAVERN/M/S +TAWNY +TAX/D/G/S +TAXABLE +TAXATION +TAXI/D/G/S +TAXICAB/M/S +TAXONOMIC +TAXONOMICALLY +TAXONOMY +TAXPAYER/M/S +TEA/S +TEACH/R/Z/G/J/S +TEACHABLE +TEACHER'S +TEAHOUSE +TEAM/D/G/S +TEAR/D/G/S +TEARFUL/Y +TEASE/D/G/S +TEASPOON/M/S +TEASPOONFUL/M/S +TECHNICAL/Y +TECHNICALITY/M/S +TECHNICIAN/M/S +TECHNIQUE/M/S +TECHNOLOGICAL/Y +TECHNOLOGIST/M/S +TECHNOLOGY/S +TEDDY/M +TEDIOUS/P/Y +TEDIUM +TEEM/D/G/S +TEEN/S +TEENAGE/D/R/Z +TEETH +TEETHE/D/G/S +TEFLON +TELECOMMUNICATION/S +TELEGRAM/M/S +TELEGRAPH/D/R/Z/G +TELEGRAPHIC +TELEGRAPHS +TELEOLOGICAL/Y +TELEOLOGY +TELEPHONE/D/R/Z/G/S +TELEPHONIC +TELEPHONY +TELESCOPE/D/G/S +TELETYPE/M/S +TELEVISE/D/G/N/X/S +TELEVISOR/M/S +TELL/R/Z/G/S +TEMPER/D/G/S +TEMPERAMENT/S +TEMPERAMENTAL +TEMPERANCE +TEMPERATE/P/Y +TEMPERATURE/M/S +TEMPEST +TEMPESTUOUS/Y +TEMPLATE/M/S +TEMPLE/M/S +TEMPORAL/Y +TEMPORARILY +TEMPORARY/S +TEMPT/D/R/Z/G/S +TEMPTATION/M/S +TEMPTINGLY +TEN/H/S +TENACIOUS/Y +TENANT/M/S +TEND/D/R/Z/G/S +TENDENCY/S +TENDERLY +TENDERNESS +TENEMENT/M/S +TENNESSEE +TENNIS +TENOR/M/S +TENSE/P/D/T/R/G/N/X/Y/S +TENSOR +TENT/D/G/S +TENTACLE/D/S +TENTATIVE/Y +TENURE +TERM/D/G/S +TERMINAL/M/Y/S +TERMINATE/D/G/N/X/S +TERMINATOR/M/S +TERMINOLOGY/S +TERMINUS +TERMWISE +TERNARY +TERRACE/D/S +TERRAIN/M/S +TERRESTRIAL +TERRIBLE +TERRIBLY +TERRIER/M/S +TERRIFIC +TERRIFY/D/G/S +TERRITORIAL +TERRITORY/M/S +TERROR/M/S +TERRORISM +TERRORIST/M/S +TERRORISTIC +TERRORIZE/D/G/S +TERSE +TERTIARY +TEST/D/R/Z/G/J/S +TESTABILITY +TESTABLE +TESTAMENT/M/S +TESTICLE/M/S +TESTIFY/D/R/Z/G/S +TESTIMONY/M/S +TEXAS +TEXT/M/S +TEXTBOOK/M/S +TEXTILE/M/S +TEXTUAL/Y +TEXTURE/D/S +THAN +THANK/D/G/S +THANKFUL/P/Y +THANKLESS/P/Y +THANKSGIVING +THAT/M/S +THATCH/S +THAW/D/G/S +THE/G/J +THEATER/M/S +THEATRICAL/Y/S +THEFT/M/S +THEIR/S +THEM +THEMATIC +THEME/M/S +THEMSELVES +THEN +THENCE +THENCEFORTH +THEOLOGICAL +THEOLOGY +THEOREM/M/S +THEORETIC +THEORETICAL/Y +THEORETICIANS +THEORIST/M/S +THEORIZATION/M/S +THEORIZE/D/R/Z/G/S +THEORY/M/S +THERAPEUTIC +THERAPIST/M/S +THERAPY/M/S +THERE/M +THEREABOUTS +THEREAFTER +THEREBY +THEREFORE +THEREIN +THEREOF +THEREON +THERETO +THEREUPON +THEREWITH +THERMAL +THERMODYNAMIC/S +THERMOMETER/M/S +THERMOSTAT/M/S +THESAURI +THESE/S +THESIS +THETA +THEY +THEY'D +THEY'LL +THEY'RE +THEY'VE +THICK/P/T/R/N/X/Y +THICKET/M/S +THIEF +THIEVE/G/S +THIGH +THIGHS +THIMBLE/M/S +THIN/P/Y +THINK/R/Z/G/S +THINKABLE +THINKABLY +THINNER +THINNEST +THIRD/Y/S +THIRST/D/S +THIRSTY +THIRTEEN/H/S +THIRTY/H/S +THIS +THISTLE +THOMAS +THOMPSON/M +THONG +THORN/M/S +THORNY +THOROUGH/P/Y +THOROUGHFARE/M/S +THOSE +THOUGH +THOUGHT/M/S +THOUGHTFUL/P/Y +THOUGHTLESS/P/Y +THOUSAND/H/S +THRASH/D/R/G/S +THREAD/D/R/Z/G/S +THREAT/N/S +THREATEN/D/G/S +THREE/M/S +THREESCORE +THRESHOLD/M/S +THREW +THRICE +THRIFT +THRIFTY +THRILL/D/R/Z/G/S +THRILLING/Y +THRIVE/D/G/S +THROAT/D/S +THROB/S +THROBBED +THROBBING +THRONE/M/S +THRONG/M/S +THROTTLE/D/G/S +THROUGH +THROUGHOUT +THROUGHPUT +THROW/R/G/S +THROWN +THRUSH +THRUST/R/Z/G/S +THUD/S +THUG/M/S +THUMB/D/G/S +THUMP/D/G +THUNDER/D/R/Z/G/S +THUNDERBOLT/M/S +THUNDERSTORM/M/S +THURSDAY/M/S +THUS/Y +THWART/D/G +THYSELF +TICK/D/R/Z/G/S +TICKET/M/S +TICKLE/D/G/S +TIDAL/Y +TIDE/D/G/J/S +TIDY/P/D/G +TIE/D/R/Z/S +TIGER/M/S +TIGHT/P/T/R/X/Y +TIGHTEN/D/R/Z/G/J/S +TILDE +TILE/D/G/S +TILL/D/R/Z/G/S +TILLABLE +TILT/D/G/S +TIMBER/D/G/S +TIME/D/R/Z/G/Y/J/S +TIMESHARING +TIMETABLE/M/S +TIMID/Y +TIMIDITY +TIN/M/S +TINGE/D +TINGLE/D/G/S +TINILY +TINKER/D/G/S +TINKLE/D/G/S +TINNILY +TINNY/P/T/R +TINT/D/G/S +TINY/P/T/R +TIP/M/S +TIPPED +TIPPER/M/S +TIPPING +TIPTOE +TIRE/D/G/S +TIREDLY +TIRELESS/P/Y +TIRESOME/P/Y +TISSUE/M/S +TIT/R/Z/S +TITHE/R/S +TITLE/D/S +TO +TOAD/M/S +TOAST/D/R/G/S +TOBACCO +TODAY +TOE/M/S +TOFU +TOGETHER/P +TOGGLE/D/G/S +TOIL/D/R/G/S +TOILET/M/S +TOKEN/M/S +TOLD +TOLERABILITY +TOLERABLE +TOLERABLY +TOLERANCE/S +TOLERANT/Y +TOLERATE/D/G/N/S +TOLL/D/S +TOM/M +TOMAHAWK/M/S +TOMATO +TOMATOES +TOMB/M/S +TOMOGRAPHY +TOMORROW +TON/M/S +TONAL +TONE/D/R/G/S +TONGS +TONGUE/D/S +TONIC/M/S +TONIGHT +TONNAGE +TONSIL +TOO/H +TOOK +TOOL/D/R/Z/G/S +TOOLKIT/S +TOOTHBRUSH/M/S +TOOTHPICK/M/S +TOP/R/S +TOPIC/M/S +TOPICAL/Y +TOPMOST +TOPOGRAPHIC +TOPOGRAPHICAL +TOPOLOGIC +TOPOLOGICAL +TOPOLOGY/S +TOPPLE/D/G/S +TORCH/M/S +TORE +TORMENT/D/R/Z/G +TORN +TORNADO/S +TORNADOES +TORPEDO/S +TORPEDOES +TORQUE +TORRENT/M/S +TORRID +TORTOISE/M/S +TORTURE/D/R/Z/G/S +TORUS/M/S +TOSS/D/G/S +TOTAL/D/G/Y/S/R/Z/M +TOTALER'S +TOTALITY/M/S +TOTALLED +TOTALLER/S/M +TOTALLING +TOTTER/D/G/S +TOUCH/D/G/S +TOUCHABLE +TOUCHILY +TOUCHINGLY +TOUCHY/P/T/R +TOUGH/P/T/R/N/Y +TOUR/D/G/S +TOURETZKY/M +TOURISM +TOURIST/M/S +TOURNAMENT/M/S +TOW/D/Z +TOWARD/S +TOWEL/G/S/D/M +TOWELLED +TOWELLING +TOWER/D/G/S +TOWN/M/S +TOWNSHIP/M/S +TOY/D/G/S +TRACE/D/R/Z/G/J/S +TRACEABLE +TRACK/D/R/Z/G/S +TRACT/M/V/S +TRACTABILITY +TRACTABLE +TRACTOR/M/S +TRADE/D/R/Z/G/S +TRADEMARK/M/S +TRADESMAN +TRADITION/M/S +TRADITIONAL/Y +TRAFFIC/M/S +TRAFFICKED +TRAFFICKER/M/S +TRAFFICKING +TRAGEDY/M/S +TRAGIC +TRAGICALLY +TRAIL/D/R/Z/G/J/S +TRAIN/D/R/Z/G/S +TRAINABLE +TRAINEE/M/S +TRAIT/M/S +TRAITOR/M/S +TRAJECTORY/M/S +TRAMP/D/G/S +TRAMPLE/D/R/G/S +TRANCE/M/S +TRANQUIL/Y +TRANQUILITY +TRANQUILLITY +TRANSACT +TRANSACTION/M/S +TRANSCEND/D/G/S +TRANSCENDENT +TRANSCONTINENTAL +TRANSCRIBE/D/R/Z/G/S +TRANSCRIPT/M/S +TRANSCRIPTION/M/S +TRANSFER/M/S/D/G +TRANSFERABLE +TRANSFERAL/M/S +TRANSFERRAL/M/S +TRANSFERRED +TRANSFERRER/M/S +TRANSFERRING +TRANSFINITE +TRANSFORM/D/G/S +TRANSFORMABLE +TRANSFORMATION/M/S +TRANSFORMATIONAL +TRANSGRESS/D +TRANSGRESSION/M/S +TRANSIENT/Y/S +TRANSISTOR/M/S +TRANSIT +TRANSITION/D/S +TRANSITIONAL +TRANSITIVE/P/Y +TRANSITIVITY +TRANSITORY +TRANSLATABILITY +TRANSLATABLE +TRANSLATE/D/G/N/X/S +TRANSLATIONAL +TRANSLATOR/M/S +TRANSLITERATE/N/D/G +TRANSLUCENT +TRANSMISSION/M/S +TRANSMIT/S +TRANSMITTAL +TRANSMITTED +TRANSMITTER/M/S +TRANSMITTING +TRANSMOGRIFY/N +TRANSPARENCY/M/S +TRANSPARENT/Y +TRANSPIRE/D/G/S +TRANSPLANT/D/G/S +TRANSPORT/D/R/Z/G/S +TRANSPORTABILITY +TRANSPORTATION +TRANSPOSE/D/G/S +TRANSPOSITION +TRAP/M/S +TRAPEZOID/M/S +TRAPEZOIDAL +TRAPPED +TRAPPER/M/S +TRAPPING/S +TRASH +TRAUMA +TRAUMATIC +TRAVAIL +TRAVEL/D/R/Z/G/J/S +TRAVERSAL/M/S +TRAVERSE/D/G/S +TRAVESTY/M/S +TRAY/M/S +TREACHEROUS/Y +TREACHERY/M/S +TREAD/G/S +TREASON +TREASURE/D/R/G/S +TREASURY/M/S +TREAT/D/G/S +TREATISE/M/S +TREATMENT/M/S +TREATY/M/S +TREBLE +TREE/M/S +TREETOP/M/S +TREK/M/S +TREMBLE/D/G/S +TREMENDOUS/Y +TREMOR/M/S +TRENCH/R/S +TREND/G/S +TRESPASS/D/R/Z/S +TRESS/M/S +TRIAL/M/S +TRIANGLE/M/S +TRIANGULAR/Y +TRIBAL +TRIBE/M/S +TRIBUNAL/M/S +TRIBUNE/M/S +TRIBUTARY +TRIBUTE/M/S +TRICHOTOMY +TRICK/D/G/S +TRICKLE/D/G/S +TRICKY/P/T/R +TRIFLE/R/G/S +TRIGGER/D/G/S +TRIGONOMETRIC +TRIGONOMETRY +TRIHEDRAL +TRILL/D +TRILLION/H/S +TRIM/P/Y/S +TRIMMED +TRIMMER +TRIMMEST +TRIMMING/S +TRINKET/M/S +TRIP/M/S +TRIPLE/D/G/S +TRIPLET/M/S +TRIUMPH/D/G +TRIUMPHAL +TRIUMPHANTLY +TRIUMPHS +TRIVIA +TRIVIAL/Y +TRIVIALITY/S +TROD +TROLL/M/S +TROLLEY/M/S +TROOP/R/Z/S +TROPHY/M/S +TROPIC/M/S +TROPICAL +TROT/S +TROUBLE/D/G/S +TROUBLEMAKER/M/S +TROUBLESHOOT/R/Z/G/S +TROUBLESOME/Y +TROUGH +TROUSER/S +TROUT +TROWEL/M/S +TRUANT/M/S +TRUCE +TRUCK/D/R/Z/G/S +TRUDGE/D +TRUE/D/T/R/G/S +TRUISM/M/S +TRULY +TRUMP/D/S +TRUMPET/R +TRUNCATE/D/G/S +TRUNCATION/M/S +TRUNK/M/S +TRUST/D/G/S +TRUSTEE/M/S +TRUSTFUL/P/Y +TRUSTINGLY +TRUSTWORTHY/P +TRUSTY +TRUTH +TRUTHFUL/P/Y +TRUTHS +TRY/D/R/Z/G/S +TUB/M/S +TUBE/R/Z/G/S +TUBERCULOSIS +TUCK/D/R/G/S +TUESDAY/M/S +TUFT/M/S +TUG/S +TUITION +TULIP/M/S +TUMBLE/D/R/Z/G/S +TUMOR/S +TUMULT/M/S +TUMULTUOUS +TUNABLE +TUNE/D/R/Z/G/S +TUNIC/M/S +TUNNEL/D/S +TUPLE/M/S +TURBAN/M/S +TURBO +TURBULENT/Y +TURF +TURING +TURKEY/M/S +TURMOIL/M/S +TURN/D/R/Z/G/J/S +TURNABLE +TURNIP/M/S +TURNOVER +TURPENTINE +TURQUOISE +TURRET/M/S +TURTLE/M/S +TUTOR/D/G/S +TUTORIAL/M/S +TV +TWAIN +TWANG +TWAS +TWEED +TWELFTH +TWELVE/S +TWENTY/H/S +TWICE +TWIG/M/S +TWILIGHT/M/S +TWILL +TWIN/M/S +TWINE/D/R +TWINKLE/D/R/G/S +TWIRL/D/R/G/S +TWIST/D/R/Z/G/S +TWITCH/D/G +TWITTER/D/G +TWO/M/S +TWOFOLD +TYING +TYPE/D/M/G/S +TYPECHECK/G/S/R +TYPEOUT +TYPESCRIPT/S +TYPEWRITER/M/S +TYPHOID +TYPICAL/P/Y +TYPIFY/D/G/S +TYPIST/M/S +TYPOGRAPHICAL/Y +TYPOGRAPHY +TYRANNY +TYRANT/M/S +UBIQUITOUS/Y +UBIQUITY +UGH +UGLY/P/T/R +UIMS +ULCER/M/S +ULTIMATE/Y +UMBRELLA/M/S +UMPIRE/M/S +UNABATED +UNABBREVIATED +UNABLE +UNACCEPTABILITY +UNACCEPTABLE +UNACCEPTABLY +UNACCUSTOMED +UNACKNOWLEDGED +UNADULTERATED +UNAESTHETICALLY +UNAFFECTED/P/Y +UNAIDED +UNALIENABILITY +UNALIENABLE +UNALTERABLY +UNALTERED +UNAMBIGUOUS/Y +UNAMBITIOUS +UNANALYZABLE +UNANIMOUS/Y +UNANSWERED +UNANTICIPATED +UNARMED +UNARY +UNASSAILABLE +UNASSIGNED +UNATTAINABILITY +UNATTAINABLE +UNATTENDED +UNATTRACTIVE/Y +UNAUTHORIZED +UNAVAILABILITY +UNAVAILABLE +UNAVOIDABLE +UNAVOIDABLY +UNAWARE/P/S +UNBALANCED +UNBEARABLE +UNBELIEVABLE +UNBIASED +UNBLOCK/D/G/S +UNBORN +UNBOUND/D +UNBREAKABLE +UNBROKEN +UNBUFFERED +UNCANCELED +UNCANCELLED +UNCANNY +UNCAPITALIZED +UNCAUGHT +UNCERTAIN/Y +UNCERTAINTY/S +UNCHANGEABLE +UNCHANGED +UNCHANGING +UNCHARTED +UNCLAIMED +UNCLE/M/S +UNCLEAN/P/Y +UNCLEAR/D +UNCLOSED +UNCOMFORTABLE +UNCOMFORTABLY +UNCOMMITTED +UNCOMMON/Y +UNCOMPROMISING +UNCOMPUTABLE +UNCONCERNED/Y +UNCONDITIONAL/Y +UNCONNECTED +UNCONSCIOUS/P/Y +UNCONSTRAINED +UNCONTROLLABILITY +UNCONTROLLABLE +UNCONTROLLABLY +UNCONTROLLED +UNCONVENTIONAL/Y +UNCONVINCED +UNCONVINCING +UNCORRECTABLE +UNCORRECTED +UNCOUNTABLE +UNCOUNTABLY +UNCOUTH +UNCOVER/D/G/S +UNDAUNTED/Y +UNDECIDABLE +UNDECIDED +UNDECLARED +UNDECOMPOSABLE +UNDEFINABILITY +UNDEFINED +UNDELETE +UNDELETED +UNDENIABLY +UNDER +UNDERBRUSH +UNDERDONE +UNDERESTIMATE/D/G/N/S +UNDERFLOW/D/G/S +UNDERFOOT +UNDERGO/G +UNDERGOES +UNDERGONE +UNDERGRADUATE/M/S +UNDERGROUND +UNDERLIE/S +UNDERLINE/D/G/J/S +UNDERLING/M/S +UNDERLYING +UNDERMINE/D/G/S +UNDERNEATH +UNDERPINNING/S +UNDERPLAY/D/G/S +UNDERSCORE/D/S +UNDERSTAND/G/J/S +UNDERSTANDABILITY +UNDERSTANDABLE +UNDERSTANDABLY +UNDERSTANDINGLY +UNDERSTATED +UNDERSTOOD +UNDERTAKE/R/Z/G/J/S +UNDERTAKEN +UNDERTOOK +UNDERWAY +UNDERWEAR +UNDERWENT +UNDERWORLD +UNDERWRITE/R/Z/G/S +UNDESIRABILITY +UNDESIRABLE +UNDETECTABLE +UNDETECTED +UNDETERMINED +UNDEVELOPED +UNDID +UNDIRECTED +UNDISCIPLINED +UNDISCOVERED +UNDISTORTED +UNDISTURBED +UNDIVIDED +UNDO/G/J +UNDOCUMENTED +UNDOES +UNDONE +UNDOUBTEDLY +UNDRESS/D/G/S +UNDUE +UNDULY +UNEASILY +UNEASY/P +UNECONOMICAL +UNEMBELLISHED +UNEMPLOYED +UNEMPLOYMENT +UNENDING +UNENLIGHTENING +UNEQUAL/D/Y +UNEQUIVOCAL/Y +UNESSENTIAL +UNEVALUATED +UNEVEN/P/Y +UNEVENTFUL +UNEXCUSED +UNEXPANDED +UNEXPECTED/Y +UNEXPLAINED +UNEXPLORED +UNEXTENDED +UNFAIR/P/Y +UNFAITHFUL/P/Y +UNFAMILIAR/Y +UNFAMILIARITY +UNFAVORABLE +UNFETTERED +UNFINISHED +UNFIT/P +UNFLAGGING +UNFOLD/D/G/S +UNFORESEEN +UNFORGEABLE +UNFORGIVING +UNFORMATTED +UNFORTUNATE/Y/S +UNFOUNDED +UNFRIENDLY/P +UNFULFILLED +UNGRAMMATICAL +UNGRATEFUL/P/Y +UNGROUNDED +UNGUARDED +UNGUIDED +UNHAPPILY +UNHAPPY/P/T/R +UNHEALTHY +UNHEEDED +UNICORN/M/S +UNIDENTIFIED +UNIDIRECTIONAL/Y +UNIDIRECTIONALITY +UNIFORM/D/Y/S +UNIFORMITY +UNIFY/D/R/Z/G/N/X/S +UNILATERAL +UNILLUMINATING +UNIMAGINABLE +UNIMPEDED +UNIMPLEMENTED +UNIMPORTANT +UNINDENTED +UNINFORMED +UNINITIALIZED +UNINTELLIGIBLE +UNINTENDED +UNINTENTIONAL/Y +UNINTERESTING/Y +UNINTERPRETED +UNINTERRUPTED/Y +UNION/M/S +UNIONIZATION +UNIONIZE/D/R/Z/G/S +UNIQUE/P/Y +UNISON +UNIT/M/S +UNITE/D/G/S +UNITY/M/S +UNIVALVE/M/S +UNIVERSAL/Y/S +UNIVERSALITY +UNIVERSE/M/S +UNIVERSITY/M/S +UNIX +UNJUST/Y +UNJUSTIFIED +UNKIND/P/Y +UNKNOWABLE +UNKNOWING/Y +UNKNOWN/S +UNLABELED +UNLAWFUL/Y +UNLEASH/D/G/S +UNLESS +UNLIKE/P/Y +UNLIMITED +UNLINK/D/G/S +UNLOAD/D/G/S +UNLOCK/D/G/S +UNLUCKY +UNMANAGEABLE +UNMANAGEABLY +UNMANNED +UNMARKED +UNMARRIED +UNMASKED +UNMATCHED +UNMISTAKABLE +UNMODIFIED +UNMOVED +UNNAMED +UNNATURAL/P/Y +UNNECESSARILY +UNNECESSARY +UNNEEDED +UNNOTICED +UNOBSERVABLE +UNOBSERVED +UNOBTAINABLE +UNOCCUPIED +UNOFFICIAL/Y +UNOPENED +UNOPTIMIZED +UNORDERED +UNPACK/D/G/S +UNPARALLELED +UNPARSED +UNPLANNED +UNPLEASANT/P/Y +UNPOPULAR +UNPOPULARITY +UNPRECEDENTED +UNPREDICTABLE +UNPRESCRIBED +UNPRESERVED +UNPRIMED +UNPROFITABLE +UNPROJECTED +UNPROTECTED +UNPROVABILITY +UNPROVABLE +UNPROVEN +UNPUBLISHED +UNQUALIFIED/Y +UNQUESTIONABLY +UNQUESTIONED +UNQUOTED +UNRAVEL/D/G/S +UNREACHABLE +UNREADABLE +UNREAL +UNREALISTIC +UNREALISTICALLY +UNREASONABLE/P +UNREASONABLY +UNRECOGNIZABLE +UNRECOGNIZED +UNRELATED +UNRELIABILITY +UNRELIABLE +UNREPORTED +UNREPRESENTABLE +UNRESOLVED +UNRESPONSIVE +UNREST +UNRESTRAINED +UNRESTRICTED/Y +UNRESTRICTIVE +UNROLL/D/G/S +UNRULY +UNSAFE/Y +UNSANITARY +UNSATISFACTORY +UNSATISFIABILITY +UNSATISFIABLE +UNSATISFIED +UNSATISFYING +UNSCRUPULOUS +UNSEEDED +UNSEEN +UNSELECTED +UNSELFISH/P/Y +UNSENT +UNSETTLED +UNSETTLING +UNSHAKEN +UNSHARED +UNSIGNED +UNSKILLED +UNSOLVABLE +UNSOLVED +UNSOPHISTICATED +UNSOUND +UNSPEAKABLE +UNSPECIFIED +UNSTABLE +UNSTEADY/P +UNSTRUCTURED +UNSUCCESSFUL/Y +UNSUITABLE +UNSUITED +UNSUPPORTED +UNSURE +UNSURPRISING/Y +UNSYNCHRONIZED +UNTAPPED +UNTERMINATED +UNTESTED +UNTHINKABLE +UNTIDY/P +UNTIE/D/S +UNTIL +UNTIMELY +UNTO +UNTOLD +UNTOUCHABLE/M/S +UNTOUCHED +UNTOWARD +UNTRAINED +UNTRANSLATED +UNTREATED +UNTRIED +UNTRUE +UNTRUTHFUL/P +UNTYING +UNUSABLE +UNUSED +UNUSUAL/Y +UNVARYING +UNVEIL/D/G/S +UNWANTED +UNWELCOME +UNWHOLESOME +UNWIELDY/P +UNWILLING/P/Y +UNWIND/R/Z/G/S +UNWISE/Y +UNWITTING/Y +UNWORTHY/P +UNWOUND +UNWRITTEN +UP +UPBRAID +UPDATE/D/R/G/S +UPGRADE/D/G/S +UPHELD +UPHILL +UPHOLD/R/Z/G/S +UPHOLSTER/D/R/G/S +UPKEEP +UPLAND/S +UPLIFT +UPON +UPPER +UPPERMOST +UPRIGHT/P/Y +UPRISING/M/S +UPROAR +UPROOT/D/G/S +UPSET/S +UPSHOT/M/S +UPSIDE +UPSTAIRS +UPSTREAM +UPTURN/D/G/S +UPWARD/S +URBAN +URBANA +URCHIN/M/S +URGE/D/G/J/S +URGENT/Y +URINATE/D/G/N/S +URINE +URN/M/S +US +USA +USABILITY +USABLE +USABLY +USAGE/S +USE/D/R/Z/G/S +USEFUL/P/Y +USELESS/P/Y +USENIX +USER'S +USHER/D/G/S +USUAL/Y +USURP/D/R +UTAH +UTENSIL/M/S +UTILITY/M/S +UTILIZATION/M/S +UTILIZE/D/G/S +UTMOST +UTOPIAN/M/S +UTTER/D/G/Y/S +UTTERANCE/M/S +UTTERMOST +UUCP +UZI +VACANCY/M/S +VACANT/Y +VACATE/D/G/X/S +VACATION/D/R/Z/G/S +VACUO +VACUOUS/Y +VACUUM/D/G +VAGABOND/M/S +VAGARY/M/S +VAGINA/M/S +VAGRANT/Y +VAGUE/P/T/R/Y +VAINLY +VALE/M/S +VALENCE/M/S +VALENTINE/M/S +VALET/M/S +VALIANT/Y +VALID/P/Y +VALIDATE/D/G/N/S +VALIDITY +VALLEY/M/S +VALOR +VALUABLE/S +VALUABLY +VALUATION/M/S +VALUE/D/R/Z/G/S +VALVE/M/S +VAN/M/S +VANCOUVER +VANDALIZE/D/G/S +VANE/M/S +VANILLA +VANISH/D/R/G/S +VANISHINGLY +VANITY/S +VANQUISH/D/G/S +VANTAGE +VAPOR/G/S +VARIABILITY +VARIABLE/P/M/S +VARIABLY +VARIANCE/M/S +VARIANT/Y/S +VARIATION/M/S +VARIETY/M/S +VARIOUS/Y +VARNISH/M/S +VARY/D/G/J/S +VASE/M/S +VASSAL +VAST/P/T/R/Y +VAT/M/S +VAUDEVILLE +VAULT/D/R/G/S +VAUNT/D +VAX +VAXEN +VAXES +VEAL +VECTOR/M/S +VECTORIZATION +VECTORIZING +VEE +VEER/D/G/S +VEGAS +VEGETABLE/M/S +VEGETARIAN/M/S +VEGETATE/D/G/N/V/S +VEHEMENCE +VEHEMENT/Y +VEHICLE/M/S +VEHICULAR +VEIL/D/G/S +VEIN/D/G/S +VELOCITY/M/S +VELVET +VENDOR/M/S +VENERABLE +VENGEANCE +VENISON +VENOM +VENOMOUS/Y +VENT/D/S +VENTILATE/D/G/N/S +VENTRICLE/M/S +VENTURE/D/R/Z/G/J/S +VERACITY +VERANDA/M/S +VERB/M/S +VERBAL/Y +VERBATIM +VERBOSE +VERBOSITY +VERDICT +VERDURE +VERGE/R/S +VERIFIABILITY +VERIFIABLE +VERIFY/D/R/Z/G/N/X/S +VERILY +VERITABLE +VERMIN +VERNACULAR +VERSA +VERSATILE +VERSATILITY +VERSE/D/G/N/X/S +VERSUS +VERTEBRATE/M/S +VERTEX +VERTICAL/P/Y +VERTICES +VERY +VESSEL/M/S +VEST/D/S +VESTIGE/M/S +VESTIGIAL +VETERAN/M/S +VETERINARIAN/M/S +VETERINARY +VETO/D/R +VETOES +VEX/D/G/S +VEXATION +VIA +VIABILITY +VIABLE +VIABLY +VIAL/M/S +VIBRATE/D/G/N/X +VICE/M/S +VICEROY +VICINITY +VICIOUS/P/Y +VICISSITUDE/M/S +VICTIM/M/S +VICTIMIZE/D/R/Z/G/S +VICTOR/M/S +VICTORIA +VICTORIOUS/Y +VICTORY/M/S +VICTUAL/R/S +VIDEO +VIDEOTAPE/M/S +VIE/D/R/S +VIEW/D/R/Z/G/S +VIEWABLE +VIEWPOINT/M/S +VIEWPORT/S +VIGILANCE +VIGILANT/Y +VIGILANTE/M/S +VIGNETTE/M/S +VIGOR +VIGOROUS/Y +VILE/P/Y +VILIFY/D/G/N/X/S +VILLA/M/S +VILLAGE/R/Z/S +VILLAIN/M/S +VILLAINOUS/P/Y +VILLAINY +VINDICTIVE/P/Y +VINE/M/S +VINEGAR +VINEYARD/M/S +VINTAGE +VIOLATE/D/G/N/X/S +VIOLATOR/M/S +VIOLENCE +VIOLENT/Y +VIOLET/M/S +VIOLIN/M/S +VIOLINIST/M/S +VIPER/M/S +VIRGIN/M/S +VIRGINIA +VIRGINITY +VIRTUAL/Y +VIRTUE/M/S +VIRTUOSO/M/S +VIRTUOUS/Y +VIRUS/M/S +VISA/S +VISAGE +VISCOUNT/M/S +VISCOUS +VISIBILITY +VISIBLE +VISIBLY +VISION/M/S +VISIONARY +VISIT/D/G/S +VISITATION/M/S +VISITOR/M/S +VISOR/M/S +VISTA/M/S +VISUAL/Y +VISUALIZATION +VISUALIZE/D/R/G/S +VITA +VITAE +VITAL/Y/S +VITALITY +VIVID/P/Y +VIZIER +VLSI +VMS +VOCABULARY/S +VOCAL/Y/S +VOCATION/M/S +VOCATIONAL/Y +VOGUE +VOICE/D/R/Z/G/S +VOID/D/R/G/S +VOLATILE +VOLATILITY/S +VOLCANIC +VOLCANO/M/S +VOLLEY +VOLLEYBALL/M/S +VOLT/S +VOLTAGE/S +VOLUME/M/S +VOLUNTARILY +VOLUNTARY +VOLUNTEER/D/G/S +VOMIT/D/G/S +VON +VOTE/D/R/Z/G/V/S +VOUCH/R/Z/G/S +VOW/D/R/G/S +VOWEL/M/S +VOYAGE/D/R/Z/G/J/S +VS +VULGAR/Y +VULNERABILITY/S +VULNERABLE +VULTURE/M/S +WADE/D/R/G/S +WAFER/M/S +WAFFLE/M/S +WAFT +WAG/S +WAGE/D/R/Z/G/S +WAGON/R/S +WAIL/D/G/S +WAIST/M/S +WAISTCOAT/M/S +WAIT/D/R/Z/G/S +WAITRESS/M/S +WAIVE/D/R/G/S +WAIVERABLE +WAKE/D/G/S +WAKEN/D/G +WALK/D/R/Z/G/S +WALL/D/G/S +WALLET/M/S +WALLOW/D/G/S +WALNUT/M/S +WALRUS/M/S +WALTZ/D/G/S +WAN/Y +WAND/Z +WANDER/D/R/Z/G/J/S +WANE/D/G/S +WANG +WANT/D/G/S +WANTON/P/Y +WAR/M/S +WARBLE/D/R/G/S +WARD/R/N/X/S +WARDROBE/M/S +WARE/S +WAREHOUSE/G/S +WARFARE +WARILY +WARLIKE +WARM/D/T/G/H/Y/S +WARMER/S +WARN/D/R/G/J/S +WARNINGLY +WARP/D/G/S +WARRANT/D/G/S +WARRANTY/M/S +WARRED +WARRING +WARRIOR/M/S +WARSHIP/M/S +WART/M/S +WARY/P +WAS +WASH/D/R/Z/G/J/S +WASHINGTON +WASN'T +WASP/M/S +WASTE/D/G/S +WASTEFUL/P/Y +WATCH/D/R/Z/G/J/S +WATCHFUL/P/Y +WATCHMAN +WATCHWORD/M/S +WATER/D/G/J/S +WATERFALL/M/S +WATERMELON +WATERPROOF/G +WATERWAY/M/S +WATERY +WAVE/D/R/Z/G/S +WAVEFORM/M/S +WAVEFRONT/M/S +WAVELENGTH +WAVELENGTHS +WAX/D/R/Z/G/N/S +WAXY +WAY/M/S +WAYSIDE +WAYWARD +WE'D +WE'LL +WE'RE +WE'VE +WE/T +WEAK/T/R/N/X/Y +WEAKEN/D/G/S +WEAKNESS/M/S +WEALTH +WEALTHS +WEALTHY/T +WEAN/D/G +WEAPON/M/S +WEAR/R/G/S +WEARABLE +WEARILY +WEARISOME/Y +WEARY/P/D/T/R/G +WEASEL/M/S +WEATHER/D/G/S +WEATHERCOCK/M/S +WEAVE/R/G/S +WEB/M/S +WED/S +WEDDED +WEDDING/M/S +WEDGE/D/G/S +WEDNESDAY/M/S +WEE/D +WEEDS +WEEK/Y/S +WEEKEND/M/S +WEEP/G/R/S/Z +WEIGH/D/G/J +WEIGHS +WEIGHT/D/G/S +WEIRD/Y +WELCOME/D/G/S +WELD/D/R/G/S +WELFARE +WELL/D/G/S +WENCH/M/S +WENT +WEPT +WERE +WEREN'T +WESLEY +WESTERN/R/Z +WESTWARD/S +WET/P/Y/S +WETTED +WETTER +WETTEST +WETTING +WHACK/D/G/S +WHALE/R/G/S +WHARF +WHARVES +WHAT/M +WHATEVER +WHATSOEVER +WHEAT/N +WHEEL/D/R/Z/G/J/S +WHELP +WHEN +WHENCE +WHENEVER +WHERE/M +WHEREABOUTS +WHEREAS +WHEREBY +WHEREIN +WHEREUPON +WHEREVER +WHETHER +WHICH +WHICHEVER +WHILE +WHIM/M/S +WHIMPER/D/G/S +WHIMSICAL/Y +WHIMSY/M/S +WHINE/D/G/S +WHIP/M/S +WHIPPED +WHIPPER/M/S +WHIPPING/M/S +WHIRL/D/G/S +WHIRLPOOL/M/S +WHIRLWIND +WHIRR/G +WHISK/D/R/Z/G/S +WHISKEY +WHISPER/D/G/J/S +WHISTLE/D/R/Z/G/S +WHIT/X +WHITE/P/T/R/G/Y/S +WHITEN/D/R/Z/G/S +WHITESPACE +WHITEWASH/D +WHITTLE/D/G/S +WHIZ +WHIZZED +WHIZZES +WHIZZING +WHO/M +WHOEVER +WHOLE/P/S +WHOLEHEARTED/Y +WHOLESALE/R/Z +WHOLESOME/P +WHOLLY +WHOM +WHOMEVER +WHOOP/D/G/S +WHORE/M/S +WHORL/M/S +WHOSE +WHY +WICK/D/R/S +WICKED/P/Y +WIDE/T/R/Y +WIDEN/D/R/G/S +WIDESPREAD +WIDOW/D/R/Z/S +WIDTH +WIDTHS +WIELD/D/R/G/S +WIFE/M/Y +WIG/M/S +WIGWAM +WILD/P/T/R/Y +WILDCARD/S +WILDCAT/M/S +WILDERNESS +WILDLIFE +WILE/S +WILL/D/G/S +WILLFUL/Y +WILLIAM/M +WILLINGLY +WILLINGNESS +WILLOW/M/S +WILT/D/G/S +WILY/P +WIN/S +WINCE/D/G/S +WIND/D/R/Z/G/S +WINDMILL/M/S +WINDOW/M/S +WINDY +WINE/D/R/Z/G/S +WING/D/G/S +WINK/D/R/G/S +WINNER/M/S +WINNING/Y/S +WINTER/D/G/S +WINTRY +WIPE/D/R/Z/G/S +WIRE/D/G/S +WIRELESS +WIRETAP/M/S +WIRY/P +WISCONSIN +WISDOM/S +WISE/D/T/R/Y +WISH/D/R/Z/G/S +WISHFUL +WISP/M/S +WISTFUL/P/Y +WIT/M/S +WITCH/G/S +WITCHCRAFT +WITH/R/Z +WITHAL +WITHDRAW/G/S +WITHDRAWAL/M/S +WITHDRAWN +WITHDREW +WITHHELD +WITHHOLD/R/Z/G/J/S +WITHIN +WITHOUT +WITHSTAND/G/S +WITHSTOOD +WITNESS/D/G/S +WITTY +WIVES +WIZARD/M/S +WOE +WOEFUL/Y +WOKE +WOLF +WOLVES +WOMAN/M/Y +WOMANHOOD +WOMB/M/S +WOMEN/M +WON +WON'T +WONDER/D/G/S +WONDERFUL/P/Y +WONDERINGLY +WONDERMENT +WONDROUS/Y +WONT/D +WOO/D/R/G/S +WOOD/D/N/S +WOODCHUCK/M/S +WOODCOCK/M/S +WOODENLY +WOODENNESS +WOODLAND +WOODMAN +WOODPECKER/M/S +WOODWORK/G +WOODY +WOOF/D/R/Z/G/S +WOOL/N/Y/S +WORD/D/M/G/S +WORDILY +WORDY/P +WORE +WORK/D/R/Z/G/J/S +WORKABLE +WORKABLY +WORKBENCH/M/S +WORKBOOK/M/S +WORKHORSE/M/S +WORKINGMAN +WORKLOAD +WORKMAN +WORKMANSHIP +WORKMEN +WORKSHOP/M/S +WORKSTATION/S +WORLD/M/Y/S +WORLDLINESS +WORLDWIDE +WORM/D/G/S +WORN +WORRISOME +WORRY/D/R/Z/G/S +WORRYINGLY +WORSE +WORSHIP/D/R/G/S +WORSHIPFUL +WORST/D +WORTH +WORTHLESS/P +WORTHS +WORTHWHILE/P +WORTHY/P/T +WOULD +WOULDN'T +WOUND/D/G/S +WOVE +WOVEN +WRANGLE/D/R +WRAP/M/S +WRAPPED +WRAPPER/M/S +WRAPPING/S +WRATH +WREAK/S +WREATH/D/S +WRECK/D/R/Z/G/S +WRECKAGE +WREN/M/S +WRENCH/D/G/S +WREST +WRESTLE/R/G/J/S +WRETCH/D/S +WRETCHEDNESS +WRIGGLE/D/R/G/S +WRING/R/S +WRINKLE/D/S +WRIST/M/S +WRISTWATCH/M/S +WRIT/M/S +WRITABLE +WRITE/R/Z/G/J/S +WRITER'S +WRITHE/D/G/S +WRITTEN +WRONG/D/G/Y/S +WROTE +WROUGHT +WRUNG +XENIX +XEROX +YALE +YANK/D/G/S +YARD/M/S +YARDSTICK/M/S +YARN/M/S +YAWN/R/G +YEA/S +YEAR/M/Y/S +YEARN/D/G/J +YEAST/M/S +YELL/D/R/G +YELLOW/P/D/T/R/G/S +YELLOWISH +YELP/D/G/S +YEOMAN +YEOMEN +YES +YESTERDAY +YET +YIELD/D/G/S +YOKE/M/S +YON +YONDER +YORK/R/Z +YORKTOWN +YOU'D +YOU'LL +YOU'RE +YOU'VE +YOU/H +YOUNG/T/R/Y +YOUNGSTER/M/S +YOUR/S +YOURSELF +YOURSELVES +YOUTHFUL/P/Y +YOUTHS +YUGOSLAVIA +ZEAL +ZEALOUS/P/Y +ZEBRA/M/S +ZENITH +ZERO/D/G/H/S +ZEROES +ZEST +ZIGZAG +ZINC +ZODIAC +ZONAL/Y +ZONE/D/G/S +ZOO/M/S +ZOOLOGICAL/Y +ZOOM/G Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/bindings-gb.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/bindings-gb.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/bindings-gb.lisp (revision 8058) @@ -0,0 +1,10 @@ +(in-package :hemlock) + +(bind-key "Scroll Window Down" #k"pagedown") +(bind-key "Scroll Window Up" #k"pageup") +(bind-key "Undo" #k"control-\/") +(bind-key "Help" #k"control-h") + + + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/bindings.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/bindings.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/bindings.lisp (revision 8058) @@ -0,0 +1,959 @@ +;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Some bindings: +;;; + +(in-package :hemlock) + + + + +;;;; Default key translations: + +;;; This page defines prefix characters that set specified modifier bits on +;;; the next character typed. +;;; +(setf (key-translation #k"escape") '(:bits :meta)) +(setf (key-translation #k"control-z") '(:bits :control :meta)) +(setf (key-translation #k"control-Z") '(:bits :control :meta)) +(setf (key-translation #k"control-^") '(:bits :control)) +(setf (key-translation #k"control-c") '(:bits :hyper)) +(setf (key-translation #k"control-C") '(:bits :hyper)) + + + + +;;;; Most every binding. + +;;; Self insert letters: +;;; +(hemlock-ext:do-alpha-key-events (key-event :both) + (bind-key "Self Insert" key-event)) + +(bind-key "Beginning of Line" #k"control-a") +(bind-key "Select to Beginning of Line" #k"control-A") +(bind-key "Delete Next Character" #k"control-d") +(bind-key "Delete Next Character" #k"del") +(bind-key "End of Line" #k"control-e") +(bind-key "Select to End of Line" #k"control-E") +(bind-key "Forward Character" #k"control-f") +(bind-key "Forward Character" #k"rightarrow") +(bind-key "Select Forward Character" #k"control-F") +(bind-key "Select Forward Character" #k"shift-rightarrow") +(bind-key "Backward Character" #k"control-b") +(bind-key "Backward Character" #k"leftarrow") +(bind-key "Select Backward Character" #k"control-B") +(bind-key "Select Backward Character" #k"shift-leftarrow") +(bind-key "Kill Line" #k"control-k") +(bind-key "Refresh Screen" #k"control-l") +(bind-key "Next Line" #k"control-n") +(bind-key "Next Line" #k"downarrow") +(bind-key "Select Next Line" #k"control-N") +(bind-key "Select Next Line" #k"shift-downarrow") +(bind-key "Previous Line" #k"control-p") +(bind-key "Previous Line" #k"uparrow") +(bind-key "Select Previous Line" #k"control-P") +(bind-key "Select Previous Line" #k"shift-uparrow") +(bind-key "Query Replace" #k"meta-%") +(bind-key "Reverse Incremental Search" #k"control-r") +(bind-key "Incremental Search" #k"control-s") +(bind-key "Forward Search" #k"meta-s") +(bind-key "Reverse Search" #k"meta-r") +(bind-key "Transpose Characters" #k"control-t") +(bind-key "Universal Argument" #k"control-u") +(bind-key "Scroll Window Down" #k"control-v") +(bind-key "Scroll Window Down" #k"pagedown") +(bind-key "Scroll Window Up" #k"meta-v") +(bind-key "Scroll Window Up" #k"pageup") +(bind-key "Scroll Next Window Down" #k"control-meta-v") +(bind-key "Scroll Next Window Up" #k"control-meta-V") + +(bind-key "Do Nothing" #k"leftdown") + + +(bind-key "Process File Options" #k"control-x m" :global) +(bind-key "Ensure File Options Line" #k"control-meta-M" :global) +(bind-key "Beginning of Buffer" #k"home") +(bind-key "End of Buffer" #k"end") +(bind-key "Undo" #k"control-_") +(bind-key "Describe Key" #k"meta-?") +(bind-key "What Cursor Position" #k"control-x =") + + +#|| +(bind-key "Here to Top of Window" #k"leftdown") +(bind-key "Do Nothing" #k"leftup") +(bind-key "Top Line to Here" #k"rightdown") +(bind-key "Do Nothing" #k"rightup") +(bind-key "Point to Here" #k"middledown") +(bind-key "Point to Here" #k"super-leftdown") +(bind-key "Generic Pointer Up" #k"middleup") +(bind-key "Generic Pointer Up" #k"super-leftup") +(bind-key "Do Nothing" #k"super-rightup") +(bind-key "Insert Kill Buffer" #k"super-rightdown") +||# + +(bind-key "Insert File" #k"control-x control-r") +(bind-key "Save File" #k"control-x control-s") +(bind-key "Visit File" #k"control-x control-v") +(bind-key "Write File" #k"control-x control-w") +(bind-key "Find File" #k"control-x control-f") +(bind-key "Backup File" #k"control-x meta-b") +;(bind-key "Save All Files" #k"control-x control-m") +;(bind-key "Save All Files" #k"control-x return") +;(bind-key "Save All Files and Exit" #k"control-x meta-z") + +;(bind-key "List Buffers" #k"control-x control-b") +(bind-key "Buffer Not Modified" #k"meta-~") +;(bind-key "Check Buffer Modified" #k"control-x ~") +(bind-key "Select Buffer" #k"control-x b") +;(bind-key "Select Previous Buffer" #k"control-meta-l") +;(bind-key "Circulate Buffers" #k"control-meta-L") +;(bind-key "Create Buffer" #k"control-x meta-b") +;(bind-key "Kill Buffer" #k"control-x k") +;(bind-key "Select Random Typeout Buffer" #k"hyper-t") + +;(bind-key "Next Window" #k"control-x n") +;(bind-key "Next Window" #k"control-x o") +;(bind-key "Previous Window" #k"control-x p") +(bind-key "Split Window" #k"control-x 2") +;(bind-key "New Window" #k"control-x control-n") +;(bind-key "Delete Window" #k"control-x d") +;(bind-key "Delete Next Window" #k"control-x 1") +;(bind-key "Line to Top of Window" #k"meta-!") +;(bind-key "Line to Center of Window" #k"meta-#") +;(bind-key "Top of Window" #k"meta-,") +;(bind-key "Bottom of Window" #k"meta-.") + +(bind-key "Exit Recursive Edit" #k"control-meta-z") +(bind-key "Abort Recursive Edit" #k"control-]") + +(bind-key "Delete Previous Character" #k"delete") +(bind-key "Delete Previous Character" #k"backspace") +(bind-key "Kill Next Word" #k"meta-d") +(bind-key "Kill Previous Word" #k"meta-delete") +(bind-key "Kill Previous Word" #k"meta-backspace") +(bind-key "Exchange Point and Mark" #k"control-x control-x") +(bind-key "Mark Whole Buffer" #k"control-x h") +(bind-key "Set/Pop Mark" #k"control-@") +(bind-key "Set/Pop Mark" #k"control-space") +(bind-key "Pop and Goto Mark" #k"meta-@") +(bind-key "Pop Mark" #k"control-meta-space") ;#k"control-meta-@" = "Mark Form". +(bind-key "Kill Region" #k"control-w") +(bind-key "Save Region" #k"meta-w") +(bind-key "Un-Kill" #k"control-y") +(bind-key "Rotate Kill Ring" #k"meta-y") + +(bind-key "Forward Word" #k"meta-f") +(bind-key "Select Forward Word" #k"meta-F") +(bind-key "Backward Word" #k"meta-b") +(bind-key "Select Backward Word" #k"meta-B") + +(bind-key "Forward Paragraph" #k"meta-]") +(bind-key "Forward Sentence" #k"meta-e") +(bind-key "Backward Paragraph" #k"meta-[") +(bind-key "Backward Sentence" #k"meta-a") + +(bind-key "Mark Paragraph" #k"meta-h") + +(bind-key "Forward Kill Sentence" #k"meta-k") +(bind-key "Backward Kill Sentence" #k"control-x delete") +(bind-key "Backward Kill Sentence" #k"control-x backspace") + +(bind-key "Beginning of Buffer" #k"meta-\<") +(bind-key "End of Buffer" #k"meta-\>") +(bind-key "Mark to Beginning of Buffer" #k"control-\<") +(bind-key "Mark to End of Buffer" #k"control-\>") + +(bind-key "Extended Command" #k"meta-x") + +(bind-key "Uppercase Word" #k"meta-u") +(bind-key "Lowercase Word" #k"meta-l") +(bind-key "Capitalize Word" #k"meta-c") + +;(bind-key "Previous Page" #k"control-x [") +;(bind-key "Next Page" #k"control-x ]") +;(bind-key "Mark Page" #k"control-x control-p") +;(bind-key "Count Lines Page" #k"control-x l") + +(bind-key "Expand Dynamic Abbreviation" #k"meta-/") ;; Aquamacs and LW binding +(bind-key "Expand Dynamic Abbreviation" #k"meta-`") ;; MCL binding + + + +;;;; Argument Digit and Negative Argument. + +(bind-key "Negative Argument" #k"meta-\-") +(bind-key "Argument Digit" #k"meta-0") +(bind-key "Argument Digit" #k"meta-1") +(bind-key "Argument Digit" #k"meta-2") +(bind-key "Argument Digit" #k"meta-3") +(bind-key "Argument Digit" #k"meta-4") +(bind-key "Argument Digit" #k"meta-5") +(bind-key "Argument Digit" #k"meta-6") +(bind-key "Argument Digit" #k"meta-7") +(bind-key "Argument Digit" #k"meta-8") +(bind-key "Argument Digit" #k"meta-9") +(bind-key "Negative Argument" #k"control-\-") +(bind-key "Argument Digit" #k"control-0") +(bind-key "Argument Digit" #k"control-1") +(bind-key "Argument Digit" #k"control-2") +(bind-key "Argument Digit" #k"control-3") +(bind-key "Argument Digit" #k"control-4") +(bind-key "Argument Digit" #k"control-5") +(bind-key "Argument Digit" #k"control-6") +(bind-key "Argument Digit" #k"control-7") +(bind-key "Argument Digit" #k"control-8") +(bind-key "Argument Digit" #k"control-9") +(bind-key "Negative Argument" #k"control-meta-\-") +(bind-key "Argument Digit" #k"control-meta-0") +(bind-key "Argument Digit" #k"control-meta-1") +(bind-key "Argument Digit" #k"control-meta-2") +(bind-key "Argument Digit" #k"control-meta-3") +(bind-key "Argument Digit" #k"control-meta-4") +(bind-key "Argument Digit" #k"control-meta-5") +(bind-key "Argument Digit" #k"control-meta-6") +(bind-key "Argument Digit" #k"control-meta-7") +(bind-key "Argument Digit" #k"control-meta-8") +(bind-key "Argument Digit" #k"control-meta-9") + + + +;;;; Self Insert and Quoted Insert. + +(bind-key "Quoted Insert" #k"control-q") + +(bind-key "Self Insert" #k"space") +(bind-key "Self Insert" #k"!") +(bind-key "Self Insert" #k"@") +(bind-key "Self Insert" #k"#") +(bind-key "Self Insert" #k"$") +(bind-key "Self Insert" #k"%") +(bind-key "Self Insert" #k"^") +(bind-key "Self Insert" #k"&") +(bind-key "Self Insert" #k"*") +(bind-key "Self Insert" #k"(") +(bind-key "Self Insert" #k")") +(bind-key "Self Insert" #k"_") +(bind-key "Self Insert" #k"+") +(bind-key "Self Insert" #k"~") +(bind-key "Self Insert" #k"1") +(bind-key "Self Insert" #k"2") +(bind-key "Self Insert" #k"3") +(bind-key "Self Insert" #k"4") +(bind-key "Self Insert" #k"5") +(bind-key "Self Insert" #k"6") +(bind-key "Self Insert" #k"7") +(bind-key "Self Insert" #k"8") +(bind-key "Self Insert" #k"9") +(bind-key "Self Insert" #k"0") +(bind-key "Self Insert" #k"[") +(bind-key "Self Insert" #k"]") +(bind-key "Self Insert" #k"\\") +(bind-key "Self Insert" #k"|") +(bind-key "Self Insert" #k":") +(bind-key "Self Insert" #k";") +(bind-key "Self Insert" #k"\"") +(bind-key "Self Insert" #k"'") +(bind-key "Self Insert" #k"\-") +(bind-key "Self Insert" #k"=") +(bind-key "Self Insert" #k"`") +(bind-key "Self Insert" #k"\<") +(bind-key "Self Insert" #k"\>") +(bind-key "Self Insert" #k",") +(bind-key "Self Insert" #k".") +(bind-key "Self Insert" #k"?") +(bind-key "Self Insert" #k"/") +(bind-key "Self Insert" #k"{") +(bind-key "Self Insert" #k"}") + + + + +;;;; Echo Area. + +;;; Basic echo-area commands. +;;; +(bind-key "Help on Parse" #k"home" :mode "Echo Area") +(bind-key "Help on Parse" #k"control-_" :mode "Echo Area") + +(bind-key "Complete Keyword" #k"escape" :mode "Echo Area") +(bind-key "Complete Field" #k"space" :mode "Echo Area") +(bind-key "Confirm Parse" #k"return" :mode "Echo Area") + +;;; Rebind some standard commands to behave better. +;;; +;;(bind-key "Kill Parse" #k"control-u" :mode "Echo Area") +(bind-key "Insert Parse Default" #k"control-i" :mode "Echo Area") +(bind-key "Insert Parse Default" #k"tab" :mode "Echo Area") +(bind-key "Echo Area Delete Previous Character" #k"delete" :mode "Echo Area") +(bind-key "Echo Area Delete Previous Character" #k"backspace" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"meta-h" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"meta-delete" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"meta-backspace" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"control-w" :mode "Echo Area") +(bind-key "Beginning of Parse" #k"control-a" :mode "Echo Area") +(bind-key "Beginning of Parse" #k"meta-\<" :mode "Echo Area") +(bind-key "Echo Area Backward Character" #k"control-b" :mode "Echo Area") +(bind-key "Echo Area Backward Word" #k"meta-b" :mode "Echo Area") +(bind-key "Next Parse" #k"control-n" :mode "Echo Area") +(bind-key "Previous Parse" #k"control-p" :mode "Echo Area") + +;;; Remove some dangerous standard bindings. +;;; +(bind-key "Illegal" #k"control-x" :mode "Echo Area") +(bind-key "Illegal" #k"control-meta-c" :mode "Echo Area") +(bind-key "Illegal" #k"control-meta-s" :mode "Echo Area") +(bind-key "Illegal" #k"control-meta-l" :mode "Echo Area") +(bind-key "Illegal" #k"meta-x" :mode "Echo Area") +(bind-key "Illegal" #k"control-s" :mode "Echo Area") +(bind-key "Illegal" #k"control-r" :mode "Echo Area") +(bind-key "Illegal" #k"hyper-t" :mode "Echo Area") + + + + +;;;; Listener and Editor Modes. +(bind-key "Confirm Listener Input" #k"return" :mode "Listener") +(bind-key "Previous Interactive Input" #k"meta-p" :mode "Listener") + +(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Listener") +(bind-key "Next Interactive Input" #k"meta-n" :mode "Listener") +(bind-key "Kill Interactive Input" #k"meta-i" :mode "Listener") +;(bind-key "Abort Eval Input" #k"control-meta-i" :mode "Listener") +(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Listener") +(bind-key "POP Or Delete Forward" #k"control-d" :mode "Listener") +(bind-key "Reenter Interactive Input" #k"control-return" :mode "Listener") + +;;; Make the user use C-x C-w to save the file, and take care +;;; not to associate the Listener document with any particular +;;; file or type. +(bind-key "Illegal" #k"control-x control-s" :mode "Listener") +(bind-key "Save To File" #k"control-x control-w" :mode "Listener") + +(bind-key "Editor Evaluate Expression" #k"control-meta-escape") +(bind-key "Editor Evaluate Expression" #k"meta-escape" :mode "Editor") +(bind-key "Editor Evaluate Defun" #k"control-x control-e" :mode "Editor") +(bind-key "Editor Evaluate Region" #k"enter" :mode "Editor") +(bind-key "Editor Evaluate Defun" #k"control-meta-x" :mode "Editor") +(bind-key "Editor Compile Defun" #k"control-x control-c" :mode "Editor") +(bind-key "Editor Compile Defun" #k"control-x control-C" :mode "Editor") + +(bind-key "Editor Macroexpand-1 Expression" #k"control-m" :mode "Editor") +(bind-key "Editor Macroexpand Expression" #k"control-x control-m" :mode "Editor") +(bind-key "Editor Describe Function Call" #k"control-meta-A" :mode "Editor") +(bind-key "Editor Describe Symbol" #k"control-meta-S" :mode "Editor") + + + +;;;; Typescript. +#+typescript +(progn +(bind-key "Confirm Typescript Input" #k"return" :mode "Typescript") +(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript") +(bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript") +(bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript") +(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript") +(bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript") +(bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript") +(bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript") +(bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript") +(bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript") +(bind-key "Select Slave" #k"control-meta-\c") +(bind-key "Select Background" #k"control-meta-C") + +(bind-key "Abort Operations" #k"hyper-a") +(bind-key "List Operations" #k"hyper-l") + +(bind-key "Next Compiler Error" #k"hyper-n") +(bind-key "Previous Compiler Error" #k"hyper-p") +) + + +;;;; Lisp (some). + +(bind-key "Indent Form" #k"control-meta-q") +(bind-key "Fill Lisp Comment Paragraph" #k"meta-q" :mode "Lisp") +(bind-key "Current Function Arglist" #k"control-x control-a" :mode "Lisp") +(bind-key "Arglist On Space" #k"Space" :mode "Lisp") +(bind-key "Defindent" #k"control-meta-#") +(bind-key "Beginning of Defun" #k"control-meta-a") +(bind-key "Select to Beginning of Defun" #k"control-meta-A") +(bind-key "End of Defun" #k"control-meta-e") +(bind-key "Select to End of Defun" #k"control-meta-E") +(bind-key "Forward Form" #k"control-meta-f") +(bind-key "Select Forward Form" #k"control-meta-F") +(bind-key "Backward Form" #k"control-meta-b") +(bind-key "Select Backward Form" #k"control-meta-B") +(bind-key "Forward List" #k"control-meta-n") +(bind-key "Select Forward List" #k"control-meta-N") +(bind-key "Backward List" #k"control-meta-p") +(bind-key "Select Backward List" #k"control-meta-P") +(bind-key "Transpose Forms" #k"control-meta-t") +(bind-key "Forward Kill Form" #k"control-meta-k") +(bind-key "Backward Kill Form" #k"control-meta-backspace") +(bind-key "Backward Kill Form" #k"control-meta-delete") +(bind-key "Mark Form" #k"control-meta-@") +(bind-key "Mark Defun" #k"control-meta-h") +(bind-key "Insert ()" #k"meta-(") +(bind-key "Move over )" #k"meta-)") +(bind-key "Backward Up List" #k"control-meta-(") +(bind-key "Backward Up List" #k"control-meta-u") +(bind-key "Forward Up List" #k"control-meta-)") +(bind-key "Down List" #k"control-meta-d") +(bind-key "Extract List" #k"control-meta-l") +;;(bind-key "Lisp Insert )" #k")" :mode "Lisp") +(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" :mode "Lisp") +(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Lisp") +(bind-key "Goto Absolute Line" #k"meta-g") +;;;(bind-key "Set Package Name" #k"control-x p" :mode "Lisp") + +#+listener-bindings +(progn +(bind-key "Evaluate Expression" #k"meta-escape") +(bind-key "Evaluate Defun" #k"control-x control-e") +(bind-key "Compile Defun" #k"control-x control-c") +(bind-key "Compile Buffer File" #k"control-x c") + +(bind-key "Describe Function Call" #k"control-meta-A") +(bind-key "Describe Symbol" #k"control-meta-S") +) + +(bind-key "Goto Definition" #k"meta-.") + +#+debugger-bindings +(progn +(bind-key "Debug Up" #k"control-meta-hyper-u") +(bind-key "Debug Down" #k"control-meta-hyper-d") +(bind-key "Debug Top" #k"control-meta-hyper-t") +(bind-key "Debug Bottom" #k"control-meta-hyper-b") +(bind-key "Debug Frame" #k"control-meta-hyper-f") +(bind-key "Debug Quit" #k"control-meta-hyper-q") +(bind-key "Debug Go" #k"control-meta-hyper-g") +(bind-key "Debug Abort" #k"control-meta-hyper-a") +(bind-key "Debug Restart" #k"control-meta-hyper-r") +(bind-key "Debug Help" #k"control-meta-hyper-h") +(bind-key "Debug Error" #k"control-meta-hyper-e") +(bind-key "Debug Backtrace" #k"control-meta-hyper-B") +(bind-key "Debug Print" #k"control-meta-hyper-p") +(bind-key "Debug Verbose Print" #k"control-meta-hyper-P") +(bind-key "Debug List Locals" #k"control-meta-hyper-l") +(bind-key "Debug Source" #k"control-meta-hyper-s") +(bind-key "Debug Edit Source" #k"control-meta-hyper-S") +(bind-key "Debug Flush Errors" #k"control-meta-hyper-F") +) + + + +;;;; More Miscellaneous bindings. + +(bind-key "Open Line" #k"Control-o") +(bind-key "New Line" #k"return") + +(bind-key "Transpose Words" #k"meta-t") +(bind-key "Transpose Lines" #k"control-x control-t") +(bind-key "Transpose Regions" #k"control-x t") + +(bind-key "Uppercase Region" #k"control-x control-u") +(bind-key "Lowercase Region" #k"control-x control-l") + +(bind-key "Delete Indentation" #k"meta-^") +(bind-key "Delete Indentation" #k"control-meta-^") +(bind-key "Delete Horizontal Space" #k"meta-\\") +(bind-key "Delete Blank Lines" #k"control-x control-o" :global) +(bind-key "Just One Space" #k"meta-space") +(bind-key "Back to Indentation" #k"meta-m") +(bind-key "Back to Indentation" #k"control-meta-m") +(bind-key "Indent Rigidly" #k"control-x tab") +(bind-key "Indent Rigidly" #k"control-x control-i") + +(bind-key "Indent New Line" #k"linefeed") +(bind-key "Indent" #k"tab") +(bind-key "Indent" #k"control-i") +(bind-key "Indent Region" #k"control-meta-\\") +(bind-key "Quote Tab" #k"meta-tab") + +#|| +(bind-key "Directory" #k"control-x control-\d") +(bind-key "Verbose Directory" #k"control-x control-D") +||# + +(bind-key "Activate Region" #k"control-x control-@") +(bind-key "Activate Region" #k"control-x control-space") + +(bind-key "Save Position" #k"control-x s") +(bind-key "Jump to Saved Position" #k"control-x j") +(bind-key "Put Register" #k"control-x x") +(bind-key "Get Register" #k"control-x g") + +#+pascal-mode +(progn +(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" + :mode "Pascal") +(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Pascal") +(bind-key "Scribe Insert Bracket" #k")" :mode "Pascal") +(bind-key "Scribe Insert Bracket" #k"]" :mode "Pascal") +(bind-key "Scribe Insert Bracket" #k"}" :mode "Pascal") +) + + + +;;;; Auto Fill Mode. + +(bind-key "Fill Paragraph" #k"meta-q") +(bind-key "Fill Region" #k"meta-g") +(bind-key "Set Fill Prefix" #k"control-x .") +(bind-key "Set Fill Column" #k"control-x f") +(bind-key "Auto Fill Return" #k"return" :mode "Fill") +(bind-key "Auto Fill Space" #k"space" :mode "Fill") +(bind-key "Auto Fill Linefeed" #k"linefeed" :mode "Fill") + + + + +;;;; Keyboard macro bindings. + +(bind-key "Define Keyboard Macro" #k"control-x (") +(bind-key "Define Keyboard Macro Key" #k"control-x meta-(") +(bind-key "End Keyboard Macro" #k"control-x )") +(bind-key "End Keyboard Macro" #k"control-x hyper-)") +(bind-key "Last Keyboard Macro" #k"control-x e") +(bind-key "Keyboard Macro Query" #k"control-x q") + + + +;;;; Spell bindings. +#|| +(progn + (bind-key "Check Word Spelling" #k"meta-$") + (bind-key "Add Word to Spelling Dictionary" #k"control-x $") + + (dolist (info (command-bindings (getstring "Self Insert" *command-names*))) + (let* ((key (car info)) + (key-event (svref key 0)) + (character (key-event-char key-event))) + (unless (or (alpha-char-p character) (eq key-event #k"'")) + (bind-key "Auto Check Word Spelling" key :mode "Spell")))) + (bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") + (bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") + (bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") + (bind-key "Correct Last Misspelled Word" #k"meta-:") + (bind-key "Undo Last Spelling Correction" #k"control-x a") + ) + + +;;;; Overwrite Mode. +||# + +#|| +(bind-key "Overwrite Delete Previous Character" #k"delete" :mode "Overwrite") +(bind-key "Overwrite Delete Previous Character" #k"backspace" :mode "Overwrite") + +;;; Do up the printing characters ... +(do ((i 33 (1+ i))) + ((= i 126)) + (let ((key-event (hemlock-ext:char-key-event (code-char i)))) + (bind-key "Self Overwrite" key-event :mode "Overwrite"))) + +(bind-key "Self Overwrite" #k"space" :mode "Overwrite") +||# + + + +;;;; Comment bindings. + +(bind-key "Indent for Comment" #k"meta-;") +(bind-key "Set Comment Column" #k"control-x ;") +(bind-key "Kill Comment" #k"control-meta-;") +(bind-key "Down Comment Line" #k"meta-n") +(bind-key "Up Comment Line" #k"meta-p") +(bind-key "Indent New Comment Line" #k"meta-j") +(bind-key "Indent New Comment Line" #k"meta-linefeed") + + + +#|| +;;;; Word Abbrev Mode. + +(bind-key "Add Mode Word Abbrev" #k"control-x control-a") +(bind-key "Add Global Word Abbrev" #k"control-x +") +(bind-key "Inverse Add Mode Word Abbrev" #k"control-x control-h") +(bind-key "Inverse Add Global Word Abbrev" #k"control-x \-") +;; Removed in lieu of "Pop and Goto Mark". +;;(bind-key "Abbrev Expand Only" #k"meta-space") +(bind-key "Word Abbrev Prefix Mark" #k"meta-\"") +(bind-key "Unexpand Last Word" #k"control-x u") + +(dolist (key (list #k"!" #k"~" #k"@" #k"#" #k";" #k"$" #k"%" #k"^" #k"&" #k"*" + #k"\-" #k"_" #k"=" #k"+" #k"[" #k"]" #k"(" #k")" #k"/" #k"|" + #k":" #k"'" #k"\"" #k"{" #k"}" #k"," #k"\<" #k"." #k"\>" + #k"`" #k"\\" #k"?" #k"return" #k"newline" #k"tab" #k"space")) + (bind-key "Abbrev Expand Only" key :mode "Abbrev")) + +||# + + + +;;;; Scribe Mode. + +#+scribe-mode +(progn +(dolist (key (list #k"]" #k")" #k"}" #k"\>")) + (bind-key "Scribe Insert Bracket" key :mode "Scribe")) + +;;GB (bind-key "Scribe Buffer File" #k"control-x c" :mode "Scribe") +(bind-key "Select Scribe Warnings" #k"control-meta-C" :mode "Scribe") + +(bind-key "Insert Scribe Directive" #k"hyper-i" :mode "Scribe") +) + + + +;;;; Mailer commands. +#+mail-mode +(progn +;;; Clear everything user might hit to avoid getting the internal error +;;; message about modifying read-only buffers. +;;; +(hemlock-ext:do-alpha-key-events (key-event :both) + (bind-key "Illegal" key-event :mode "Headers") + (bind-key "Illegal" key-event :mode "Message")) + +;;; Global. +;;; +(bind-key "Incorporate and Read New Mail" #k"control-x i") +(bind-key "Send Message" #k"control-x m") +(bind-key "Message Headers" #k"control-x r") + +;;; Both Headers and Message modes. +;;; +;;; The bindings in these two blocks should be the same, one for "Message" mode +;;; and one for "Headers" mode. +;;; +(bind-key "Next Message" #k"meta-n" :mode "Message") +(bind-key "Previous Message" #k"meta-p" :mode "Message") +(bind-key "Next Undeleted Message" #k"n" :mode "Message") +(bind-key "Previous Undeleted Message" #k"p" :mode "Message") +(bind-key "Send Message" #k"s" :mode "Message") +(bind-key "Send Message" #k"m" :mode "Message") +(bind-key "Forward Message" #k"f" :mode "Message") +(bind-key "Headers Delete Message" #k"k" :mode "Message") +(bind-key "Headers Undelete Message" #k"u" :mode "Message") +(bind-key "Headers Refile Message" #k"o" :mode "Message") +(bind-key "List Mail Buffers" #k"l" :mode "Message") +(bind-key "Quit Headers" #k"q" :mode "Message") +(bind-key "Incorporate and Read New Mail" #k"i" :mode "Message") +(bind-key "Beginning of Buffer" #k"\<" :mode "Message") +(bind-key "End of Buffer" #k"\>" :mode "Message") +;;; +(bind-key "Next Message" #k"meta-n" :mode "Headers") +(bind-key "Previous Message" #k"meta-p" :mode "Headers") +(bind-key "Next Undeleted Message" #k"n" :mode "Headers") +(bind-key "Previous Undeleted Message" #k"p" :mode "Headers") +(bind-key "Send Message" #k"s" :mode "Headers") +(bind-key "Send Message" #k"m" :mode "Headers") +(bind-key "Forward Message" #k"f" :mode "Headers") +(bind-key "Headers Delete Message" #k"k" :mode "Headers") +(bind-key "Headers Undelete Message" #k"u" :mode "Headers") +(bind-key "Headers Refile Message" #k"o" :mode "Headers") +(bind-key "List Mail Buffers" #k"l" :mode "Headers") +(bind-key "Quit Headers" #k"q" :mode "Headers") +(bind-key "Incorporate and Read New Mail" #k"i" :mode "Headers") +(bind-key "Beginning of Buffer" #k"\<" :mode "Headers") +(bind-key "End of Buffer" #k"\>" :mode "Headers") + + +;;; Headers mode. +;;; +(bind-key "Delete Message and Down Line" #k"d" :mode "Headers") +(bind-key "Pick Headers" #k"h" :mode "Headers") +(bind-key "Show Message" #k"space" :mode "Headers") +(bind-key "Show Message" #k"." :mode "Headers") +(bind-key "Reply to Message" #k"r" :mode "Headers") +(bind-key "Expunge Messages" #k"!" :mode "Headers") +(bind-key "Headers Help" #k"?" :mode "Headers") + + +;;; Message mode. +;;; +(bind-key "Delete Message and Show Next" #k"d" :mode "Message") +(bind-key "Goto Headers Buffer" #k"^" :mode "Message") +(bind-key "Scroll Message" #k"space" :mode "Message") +(bind-key "Scroll Message" #k"control-v" :mode "Message") +(bind-key "Scroll Window Up" #k"backspace" :mode "Message") +(bind-key "Scroll Window Up" #k"delete" :mode "Message") +(bind-key "Reply to Message in Other Window" #k"r" :mode "Message") +(bind-key "Edit Message Buffer" #k"e" :mode "Message") +(bind-key "Insert Message Region" #k"hyper-y" :mode "Message") +(bind-key "Message Help" #k"?" :mode "Message") + + +;;; Draft mode. +;;; +(bind-key "Goto Headers Buffer" #k"hyper-^" :mode "Draft") +(bind-key "Goto Message Buffer" #k"hyper-m" :mode "Draft") +(bind-key "Deliver Message" #k"hyper-s" :mode "Draft") +(bind-key "Deliver Message" #k"hyper-c" :mode "Draft") +(bind-key "Insert Message Buffer" #k"hyper-y" :mode "Draft") +(bind-key "Delete Draft and Buffer" #k"hyper-q" :mode "Draft") +(bind-key "List Mail Buffers" #k"hyper-l" :mode "Draft") +(bind-key "Draft Help" #k"hyper-?" :mode "Draft") +);#+mail-mode + + + +;;;; Netnews. + +#+netnews-mode +(progn +;;; Clear everything user might hit to avoid getting the internal error +;;; message about modifying read-only buffers. +;;; +(hemlock-ext:do-alpha-key-events (key-event :both) + (bind-key "Illegal" key-event :mode "News-Headers") + (bind-key "Illegal" key-event :mode "News-Message")) + + +;;; Global Netnews bindings +;;; +(bind-key "Netnews Post Message" #k"C-x P") + + +;;; Both News-Headers and News-Message modes. +;;; +;;; The bindings in these two blocks should be the same, one for "News-Message" +;;; mode and one for "News-Headers" mode. +;;; +(bind-key "List All Groups" #k"l" :mode "News-Headers") +(bind-key "Netnews Append to File" #k"a" :mode "News-Headers") +(bind-key "Netnews Forward Message" #k"f" :mode "News-Headers") +(bind-key "Netnews Go to Next Group" #k"g" :mode "News-Headers") +(bind-key "Netnews Next Article" #k"n" :mode "News-Headers") +(bind-key "Netnews Previous Article" #k"p" :mode "News-Headers") +(bind-key "Netnews Quit Starting Here" #k"." :mode "News-Headers") +(bind-key "Netnews Group Punt Messages" #k"G" :mode "News-Headers") +(bind-key "Netnews Show Whole Header" #k"w" :mode "News-Headers") +(bind-key "Netnews Reply to Sender in Other Window" #k"r" :mode "News-Headers") +(bind-key "Netnews Reply to Group in Other Window" #k"R" :mode "News-Headers") +;;; +(bind-key "List All Groups" #k"l" :mode "News-Message") +(bind-key "Netnews Append to File" #k"a" :mode "News-Message") +(bind-key "Netnews Forward Message" #k"f" :mode "News-Message") +(bind-key "Netnews Go to Next Group" #k"g" :mode "News-Message") +(bind-key "Netnews Next Article" #k"n" :mode "News-Message") +(bind-key "Netnews Previous Article" #k"p" :mode "News-Message") +(bind-key "Netnews Quit Starting Here" #k"." :mode "News-Message") +(bind-key "Netnews Group Punt Messages" #k"G" :mode "News-Message") +(bind-key "Netnews Show Whole Header" #k"w" :mode "News-Message") +(bind-key "Netnews Reply to Sender in Other Window" #k"r" :mode "News-Message") +(bind-key "Netnews Reply to Group in Other Window" #k"R" :mode "News-Message") + + +;;; News-Headers. +;;; +(bind-key "Netnews Exit" #k"q" :mode "News-Headers") +(bind-key "Netnews Headers File Message" #k"o" :mode "News-Headers") +(bind-key "Netnews Headers Scroll Window Down" #k"c-v" :mode "News-Headers") +(bind-key "Netnews Headers Scroll Window Up" #k"m-v" :mode "News-Headers") +(bind-key "Netnews Next Line" #k"C-n" :mode "News-Headers") +(bind-key "Netnews Next Line" #k"Downarrow" :mode "News-Headers") +(bind-key "Netnews Previous Line" #k"C-p" :mode "News-Headers") +(bind-key "Netnews Previous Line" #k"Uparrow" :mode "News-Headers") +(bind-key "Netnews Select Message Buffer" #k"hyper-m" :mode "News-Headers") +(bind-key "Netnews Show Article" #k"space" :mode "News-Headers") + + +;;; News-Message. +;;; +(bind-key "Insert Message Region" #k"Hyper-y" :mode "News-Message") +(bind-key "Netnews Message File Message" #k"o" :mode "News-Message") +(bind-key "Netnews Message Keep Buffer" #k"k" :mode "News-Message") +(bind-key "Netnews Message Quit" #k"q" :mode "News-Message") +(bind-key "Netnews Message Scroll Down" #k"space" :mode "News-Message") +(bind-key "Netnews Goto Draft Buffer" #k"hyper-d" :mode "News-Message") +(bind-key "Netnews Goto Headers Buffer" #k"^" :mode "News-Message") +(bind-key "Netnews Goto Headers Buffer" #k"hyper-h" :mode "News-Message") +(bind-key "Netnews Goto Post Buffer" #k"hyper-p" :mode "News-Message") +(bind-key "Scroll Window Up" #k"backspace" :mode "News-Message") + + +;;; Post. +;;; +(bind-key "Netnews Select Message Buffer" #k"hyper-m" :mode "Post") +(bind-key "Netnews Deliver Post" #k"hyper-s" :mode "Post") +(bind-key "Netnews Abort Post" #k"hyper-q" :mode "Post") +(bind-key "Insert Message Buffer" #k"Hyper-y" :mode "Post") + + +;;; News-Browse. + +(bind-key "Netnews Quit Browse" #k"q" :mode "News-Browse") +(bind-key "Netnews Browse Add Group To File" #k"a" :mode "News-Browse") +(bind-key "Netnews Browse Read Group" #k"space" :mode "News-Browse") +(bind-key "Next Line" #k"n" :mode "News-Browse") +(bind-key "Previous Line" #k"p" :mode "News-Browse") +) + + +;;;; Process (Shell). + +#+shell-mode +(progn +(bind-key "Shell" #k"control-meta-s") +(bind-key "Confirm Process Input" #k"return" :mode "Process") +(bind-key "Shell Complete Filename" #k"M-escape" :mode "Process") +(bind-key "Interrupt Buffer Subprocess" #k"hyper-c" :mode "Process") +(bind-key "Stop Buffer Subprocess" #k"hyper-z" :mode "Process") +(bind-key "Quit Buffer Subprocess" #k"hyper-\\") +(bind-key "Send EOF to Process" #k"hyper-d") + +(bind-key "Previous Interactive Input" #k"meta-p" :mode "Process") +(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Process") +(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Process") +(bind-key "Kill Interactive Input" #k"meta-i" :mode "Process") +(bind-key "Next Interactive Input" #k"meta-n" :mode "Process") +(bind-key "Reenter Interactive Input" #k"control-return" :mode "Process") +) + + +;;;; Bufed. + +#|| +(bind-key "Bufed" #k"control-x control-meta-b") +(bind-key "Bufed Delete" #k"d" :mode "Bufed") +(bind-key "Bufed Delete" #k"control-d" :mode "Bufed") +(bind-key "Bufed Undelete" #k"u" :mode "Bufed") +(bind-key "Bufed Expunge" #k"!" :mode "Bufed") +(bind-key "Bufed Quit" #k"q" :mode "Bufed") +(bind-key "Bufed Goto" #k"space" :mode "Bufed") +(bind-key "Bufed Goto and Quit" #k"super-leftdown" :mode "Bufed") +(bind-key "Bufed Save File" #k"s" :mode "Bufed") +(bind-key "Next Line" #k"n" :mode "Bufed") +(bind-key "Previous Line" #k"p" :mode "Bufed") + + +(bind-key "Bufed Help" #k"?" :mode "Bufed") +|# + + + +;;;; Dired. +#|| +(progn +(bind-key "Dired" #k"control-x control-meta-d") + +(bind-key "Dired Delete File and Down Line" #k"d" :mode "Dired") +(bind-key "Dired Delete File with Pattern" #k"D" :mode "Dired") +(bind-key "Dired Delete File" #k"control-d" :mode "Dired") +(bind-key "Dired Delete File" #k"k" :mode "Dired") + +(bind-key "Dired Undelete File and Down Line" #k"u" :mode "Dired") +(bind-key "Dired Undelete File with Pattern" #k"U" :mode "Dired") +(bind-key "Dired Undelete File" #k"control-u" :mode "Dired") + +(bind-key "Dired Expunge Files" #k"!" :mode "Dired") +(bind-key "Dired Update Buffer" #k"hyper-u" :mode "Dired") +(bind-key "Dired View File" #k"space" :mode "Dired") +(bind-key "Dired Edit File" #k"e" :mode "Dired") +(bind-key "Dired Up Directory" #k"^" :mode "Dired") +(bind-key "Dired Quit" #k"q" :mode "Dired") +(bind-key "Dired Help" #k"?" :mode "Dired") + +(bind-key "Dired Copy File" #k"c" :mode "Dired") +(bind-key "Dired Copy with Wildcard" #k"C" :mode "Dired") +(bind-key "Dired Rename File" #k"r" :mode "Dired") +(bind-key "Dired Rename with Wildcard" #k"R" :mode "Dired") + +(bind-key "Next Line" #k"n" :mode "Dired") +(bind-key "Previous Line" #k"p" :mode "Dired") +) +||# + + +;;;; View Mode. +#|| +(progn +(bind-key "View Scroll Down" #k"space" :mode "View") +(bind-key "Scroll Window Up" #k"b" :mode "View") +(bind-key "Scroll Window Up" #k"backspace" :mode "View") +(bind-key "Scroll Window Up" #k"delete" :mode "View") +(bind-key "View Return" #k"^" :mode "View") +(bind-key "View Quit" #k"q" :mode "View") +(bind-key "View Edit File" #k"e" :mode "View") +(bind-key "View Help" #k"?" :mode "View") +(bind-key "Beginning of Buffer" #k"\<" :mode "View") +(bind-key "End of Buffer" #k"\>" :mode "View") +) +||# + + +;;;; Lisp Library. + +#|| +(bind-key "Describe Pointer Library Entry" #k"leftdown" :mode "Lisp-Lib") +(bind-key "Load Pointer Library Entry" #k"rightdown" :mode "Lisp-Lib") +(bind-key "Describe Library Entry" #k"space" :mode "Lisp-Lib") +(bind-key "Load Library Entry" #k"l" :mode "Lisp-Lib") +(bind-key "Exit Lisp Library" #k"q" :mode "Lisp-Lib") +(bind-key "Lisp Library Help" #k"?" :mode "Lisp-Lib") +||# + + + +;;;; Completion mode. + +(dolist (c (command-bindings (getstring "Self Insert" *command-names*))) + (bind-key "Completion Self Insert" (car c) :mode "Completion")) + +(bind-key "Completion Self Insert" #k"space" :mode "Completion") +(bind-key "Completion Self Insert" #k"tab" :mode "Completion") +(bind-key "Completion Self Insert" #k"return" :mode "Completion") +(bind-key "Completion Self Insert" #k"linefeed" :mode "Completion") + +(bind-key "Completion Complete Word" #k"end") +(bind-key "Completion Rotate Completions" #k"meta-end") + + + + +;;;; Caps-Lock mode. + +(hemlock-ext:do-alpha-key-events (key-event :lower) + (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK")) + + + +;;;; Logical characters. + +(setf (logical-key-event-p #k"control-s" :forward-search) t) +(setf (logical-key-event-p #k"control-r" :backward-search) t) +(setf (logical-key-event-p #k"control-r" :recursive-edit) t) +(setf (logical-key-event-p #k"delete" :cancel) t) +(setf (logical-key-event-p #k"backspace" :cancel) t) +(setf (logical-key-event-p #k"control-g" :abort) t) +(setf (logical-key-event-p #k"escape" :exit) t) +(setf (logical-key-event-p #k"leftdown" :mouse-exit) t) +(setf (logical-key-event-p #k"y" :yes) t) +(setf (logical-key-event-p #k"space" :yes) t) +(setf (logical-key-event-p #k"n" :no) t) +(setf (logical-key-event-p #k"backspace" :no) t) +(setf (logical-key-event-p #k"delete" :no) t) +(setf (logical-key-event-p #k"!" :do-all) t) +(setf (logical-key-event-p #k"." :do-once) t) +(setf (logical-key-event-p #k"home" :help) t) +(setf (logical-key-event-p #k"h" :help) t) +(setf (logical-key-event-p #k"?" :help) t) +(setf (logical-key-event-p #k"control-_" :help) t) +(setf (logical-key-event-p #k"return" :confirm) t) +(setf (logical-key-event-p #k"control-q" :quote) t) +(setf (logical-key-event-p #k"k" :keep) t) +(setf (logical-key-event-p #k"control-w" :extend-search-word) t) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/buffer.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/buffer.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/buffer.lisp (revision 8058) @@ -0,0 +1,703 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file contains functions for changing modes and buffers. +;;; + +(in-package :hemlock-internals) + + + +;;;; Some buffer structure support. + +(defun buffer-writable (buffer) + "Returns whether buffer may be modified." + (buffer-%writable buffer)) + +(defun %set-buffer-writable (buffer value) + (invoke-hook hemlock::buffer-writable-hook buffer value) + (setf (buffer-%writable buffer) value)) + +;;; BUFFER-MODIFIED uses the buffer modification tick which is for redisplay. +;;; We can never set this down to "unmodify" a buffer, so we keep an +;;; unmodification tick. The buffer is modified only if this is less than the +;;; modification tick. +;;; +(defun buffer-modified (buffer) + "Return T if Buffer has been modified, NIL otherwise. Can be set with Setf." + (unless (bufferp buffer) (error "~S is not a buffer." buffer)) + (> (buffer-modified-tick buffer) (buffer-unmodified-tick buffer))) + +(defun %set-buffer-modified (buffer sense) + "If true make the buffer modified, if NIL unmodified." + (unless (bufferp buffer) (error "~S is not a buffer." buffer)) + (let* ((was-modified (buffer-modified buffer))) + (invoke-hook hemlock::buffer-modified-hook buffer sense) + (if sense + (setf (buffer-modified-tick buffer) (tick)) + (setf (buffer-unmodified-tick buffer) (tick))) + (unless (eq was-modified (buffer-modified buffer)) + (queue-buffer-change buffer))) + (let* ((document (buffer-document buffer))) + (if document (set-document-modified document sense))) + sense) + + +(declaim (inline buffer-name buffer-pathname buffer-region)) + +(defun buffer-region (buffer) + "Return the region which contains Buffer's text." + (buffer-%region buffer)) + +(defun %set-buffer-region (buffer new-region) + (let ((old (buffer-region buffer))) + (delete-region old) + (ninsert-region (region-start old) new-region) + old)) + +(defun buffer-name (buffer) + "Return Buffer's string name." + (buffer-%name buffer)) + +(declaim (special *buffer-names*)) + +(defun %set-buffer-name (buffer name) + (multiple-value-bind (entry foundp) (getstring name *buffer-names*) + (cond ((or (not foundp) (eq entry buffer)) + (invoke-hook hemlock::buffer-name-hook buffer name) + (delete-string (buffer-%name buffer) *buffer-names*) + (setf (getstring name *buffer-names*) buffer) + (setf (buffer-%name buffer) name)) + (t (error "Cannot rename buffer ~S to ~S. Name already in use." + buffer name))))) + +(defun buffer-pathname (buffer) + "Return a pathname for the file in Buffer. This is the truename + of the file as of the last time it was read or written." + (buffer-%pathname buffer)) + + +(defun %set-buffer-pathname (buffer pathname) + (invoke-hook hemlock::buffer-pathname-hook buffer pathname) + (setf (buffer-%pathname buffer) pathname)) + +(defun buffer-modeline-fields (window) + "Return a copy of the buffer's modeline fields list." + (do ((finfos (buffer-%modeline-fields window) (cdr finfos)) + (result () (cons (ml-field-info-field (car finfos)) result))) + ((null finfos) (nreverse result)))) + +(defun %set-buffer-modeline-fields (buffer fields) + (check-type fields list) + (check-type buffer buffer "a Hemlock buffer") + (sub-set-buffer-modeline-fields buffer fields) + (dolist (w (buffer-windows buffer)) + (update-modeline-fields buffer w))) + +(defun sub-set-buffer-modeline-fields (buffer modeline-fields) + (unless (every #'modeline-field-p modeline-fields) + (error "Fields must be a list of modeline-field objects.")) + (setf (buffer-%modeline-fields buffer) + (do ((fields modeline-fields (cdr fields)) + (res nil (cons (make-ml-field-info (car fields)) + res))) + ((null fields) (nreverse res))))) + +(defun buffer-modeline-field-p (buffer field) + "If field, a modeline-field or the name of one, is in buffer's list of + modeline-fields, it is returned; otherwise, nil." + (let ((finfo (internal-buffer-modeline-field-p buffer field))) + (if finfo (ml-field-info-field finfo)))) + +(defun internal-buffer-modeline-field-p (buffer field) + (let ((fields (buffer-%modeline-fields buffer))) + (if (modeline-field-p field) + (find field fields :test #'eq :key #'ml-field-info-field) + (find field fields + :key #'(lambda (f) + (modeline-field-name (ml-field-info-field f))))))) + + + + +;;;; Variable binding -- winding and unwinding. + +(eval-when (:compile-toplevel :execute) + +(defmacro unbind-variable-bindings (bindings) + `(do ((binding ,bindings (binding-across binding))) + ((null binding)) + (setf (car (binding-cons binding)) + (variable-object-down (binding-object binding))))) + +(defmacro bind-variable-bindings (bindings) + `(do ((binding ,bindings (binding-across binding))) + ((null binding)) + (let ((cons (binding-cons binding)) + (object (binding-object binding))) + (setf (variable-object-down object) (car cons) + (car cons) object)))) + +) ;eval-when + +;;; UNWIND-BINDINGS -- Internal +;;; +;;; Unwind buffer variable bindings and all mode bindings up to and +;;; including mode. Return a list of the modes unwound in reverse order. +;;; (buffer-mode-objects *current-buffer*) is clobbered. If "mode" is NIL +;;; unwind all bindings. +;;; +(defun unwind-bindings (mode) + (unbind-variable-bindings (buffer-var-values *current-buffer*)) + (do ((curmode (buffer-mode-objects *current-buffer*)) + (unwound ()) cw) + (()) + (setf cw curmode curmode (cdr curmode) (cdr cw) unwound unwound cw) + (unbind-variable-bindings (mode-object-var-values (car unwound))) + (when (or (null curmode) (eq (car unwound) mode)) + (setf (buffer-mode-objects *current-buffer*) curmode) + (return unwound)))) + +;;; WIND-BINDINGS -- Internal +;;; +;;; Add "modes" to the mode bindings currently in effect. +;;; +(defun wind-bindings (modes) + (do ((curmode (buffer-mode-objects *current-buffer*)) cw) + ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode)) + (bind-variable-bindings (mode-object-var-values (car modes))) + (setf cw modes modes (cdr modes) (cdr cw) curmode curmode cw)) + (bind-variable-bindings (buffer-var-values *current-buffer*))) + + + + +;;;; BUFFER-MAJOR-MODE. + +(eval-when (:compile-toplevel :execute) +(defmacro with-mode-and-buffer ((name major-p buffer) &body forms) + `(let ((mode (get-mode-object name))) + (setq ,name (mode-object-name mode)) + (,(if major-p 'unless 'when) (mode-object-major-p mode) + (error "~S is not a ~:[Minor~;Major~] Mode." ,name ,major-p)) + (check-type ,buffer buffer) + ,@forms)) +) ;eval-when + +;;; BUFFER-MAJOR-MODE -- Public +;;; +;;; The major mode is the first on the list, so just return that. +;;; +(defun buffer-major-mode (buffer) + "Return the name of Buffer's major mode. To change tha major mode + use Setf." + (check-type buffer buffer) + (car (buffer-modes buffer))) + +;;; %SET-BUFFER-MAJOR-MODE -- Public +;;; +;;; Unwind all modes in effect and add the major mode specified. +;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers +;;;other than the current buffer, and in the reverse order in the +;;;current buffer. +;;; +(defun %set-buffer-major-mode (buffer name) + "Set the major mode of some buffer to the Name'd mode." + (with-mode-and-buffer (name t buffer) + (invoke-hook hemlock::buffer-major-mode-hook buffer name) + (cond + ((eq buffer *current-buffer*) + (let ((old-mode (car (last (buffer-mode-objects buffer))))) + (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) + (funcall (mode-object-cleanup-function old-mode) buffer) + (swap-char-attributes old-mode) + (wind-bindings (cons mode (cdr (unwind-bindings old-mode)))) + (swap-char-attributes mode))) + (t + (let ((old-mode (car (buffer-mode-objects buffer)))) + (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) + (funcall (mode-object-cleanup-function old-mode) buffer)) + (setf (car (buffer-mode-objects buffer)) mode))) + (setf (car (buffer-modes buffer)) name) + (funcall (mode-object-setup-function mode) buffer) + (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) + nil) + + + + +;;;; BUFFER-MINOR-MODE. + +;;; BUFFER-MINOR-MODE -- Public +;;; +;;; Check if the mode-object is in the buffer's mode-list. +;;; +(defun buffer-minor-mode (buffer name) + "Return true if the minor mode named Name is active in Buffer. + A minor mode can be turned on or off with Setf." + (with-mode-and-buffer (name nil buffer) + (not (null (member mode (buffer-mode-objects buffer)))))) + +(declaim (special *mode-names*)) + +;;; %SET-BUFFER-MINOR-MODE -- Public +;;; +;;; Activate or deactivate a minor mode, with due respect for +;;; bindings. +;;; +(defun %set-buffer-minor-mode (buffer name new-value) + (let ((objects (buffer-mode-objects buffer))) + (with-mode-and-buffer (name nil buffer) + (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value) + (cond + ;; Already there or not there, nothing to do. + ((if (member mode (buffer-mode-objects buffer)) new-value (not new-value))) + ;; Adding a new mode. + (new-value + (cond + ((eq buffer *current-buffer*) + ;; + ;; Unwind bindings having higher precedence, cons on the new + ;; mode and then wind them back on again. + (do ((m objects (cdr m)) + (prev nil (car m))) + ((or (null (cdr m)) + (< (mode-object-precedence (car m)) + (mode-object-precedence mode))) + (wind-bindings + (cons mode (if prev + (unwind-bindings prev) + (unbind-variable-bindings + (buffer-var-values *current-buffer*)))))))) + (t + (do ((m (cdr objects) (cdr m)) + (prev objects m)) + ((or (null m) + (>= (mode-object-precedence (car m)) + (mode-object-precedence mode))) + (setf (cdr prev) (cons mode m)))))) + ;; + ;; Add the mode name. + (let ((bm (buffer-modes buffer))) + (setf (cdr bm) + (merge 'list (cdr bm) (list name) #'< :key + #'(lambda (x) + (mode-object-precedence (getstring x *mode-names*)))))) + + (funcall (mode-object-setup-function mode) buffer) + (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) + (t + ;; Removing an active mode. + (invoke-hook (%value (mode-object-hook-name mode)) buffer nil) + (funcall (mode-object-cleanup-function mode) buffer) + ;; In the current buffer, unwind buffer and any mode bindings on top + ;; pop off the mode and wind the rest back on. + (cond ((eq buffer *current-buffer*) + (wind-bindings (cdr (unwind-bindings mode)))) + (t + (setf (buffer-mode-objects buffer) + (delq mode (buffer-mode-objects buffer))))) + ;; We always use the same string, so we can delq it (How Tense!) + (setf (buffer-modes buffer) (delq name (buffer-modes buffer)))))) + new-value)) + + + + +;;;; CURRENT-BUFFER, CURRENT-POINT, and buffer using setup and cleanup. + +(declaim (inline current-buffer)) + +(defun current-buffer () "Return the current buffer object." *current-buffer*) + +(defun current-point () + "Return the Buffer-Point of the current buffer." + (buffer-point *current-buffer*)) + + + +(defun current-point-collapsing-selection () + "Return the Buffer-Point of the current buffer, deactivating the + region." + (let* ((b *current-buffer*) + (point (buffer-point b))) + ;; Deactivate the region + (setf (buffer-region-active b) nil) + point)) + +(defun current-point-extending-selection () + "Return the Buffer-Point of the current buffer, deactivating the + region." + (let* ((b *current-buffer*) + (point (buffer-point b))) + ;; If the region is active, keep it active. Otherwise, + ;; establish a new (empty) region at point. + (unless (%buffer-current-region-p b) + (push-buffer-mark (copy-mark point) t)) + point)) + +(defun current-point-for-insertion () + "Check to see if the current buffer can be modified at its + current point; error if not. If there's a selection in the + current buffer, delete it. Return the current point." + (let* ((buffer *current-buffer*) + (point (buffer-point buffer))) + (check-buffer-modification buffer point) + (let* ((region (%buffer-current-region buffer))) + (when region + (delete-region region)) + point))) + +(defun current-point-for-deletion () + "Check to see if the current buffer can be modified at its + current point; error if not. If there's a selection in the + current buffer, delete it and return NIL, else return the + current point." + (let* ((buffer *current-buffer*) + (point (buffer-point buffer))) + (check-buffer-modification buffer point) + (let* ((region (%buffer-current-region buffer))) + (if region + (progn + (delete-region region) + nil) + point)))) + +(defun current-point-unless-selection () + "Check to see if the current buffer can be modified at its + current point; error if not. If there's a selection in the + current buffer, return NIL, else return the current point." + (let* ((buffer *current-buffer*) + (point (buffer-point buffer))) + (check-buffer-modification buffer point) + (let* ((region (%buffer-current-region buffer))) + (unless region + point)))) + +;;; %SET-CURRENT-BUFFER -- Internal +;;; +;;; Undo previous buffer and mode specific variables and character +;;;attributes and set up the new ones. Set *current-buffer*. +;;; +(defun %set-current-buffer (buffer) + (let ((old-buffer *current-buffer*)) + (check-type buffer buffer) + (invoke-hook hemlock::set-buffer-hook buffer) + ;; Undo old bindings. + (setf (buffer-mode-objects *current-buffer*) + (unwind-bindings nil)) + (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) + (setq *current-buffer* buffer) + (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) + ;; Make new bindings. + (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil)) + (invoke-hook hemlock::after-set-buffer-hook old-buffer)) + buffer) + +;;; USE-BUFFER-SET-UP -- Internal +;;; +;;; This function is called by the use-buffer macro to wind on the +;;; new buffer's variable and key bindings and character attributes. +;;; +(defun use-buffer-set-up (old-buffer) + (unless (eq old-buffer *current-buffer*) + ;; Let new char attributes overlay old ones. + (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) + ;; Wind on bindings of new current buffer. + (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil)))) + +;;; USE-BUFFER-CLEAN-UP -- Internal +;;; +;;; This function is called by use-buffer to clean up after it is done. +;;; +(defun use-buffer-clean-up (old-buffer) + (unless (eq old-buffer *current-buffer*) + ;; When we leave, unwind the bindings, + (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil)) + ;; Restore the character attributes, + (swap-char-attributes (car (buffer-mode-objects *current-buffer*))))) + + + + +;;;; Recursive editing. + +(defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.") + +(declaim (inline in-recursive-edit)) + +(defun in-recursive-edit () + "Returns whether the calling point is dynamically within a recursive edit + context." + *in-a-recursive-edit*) + +;;; RECURSIVE-EDIT -- Public +;;; +;;; Call the command interpreter recursively, winding on new state as +;;; necessary. +;;; +(defun recursive-edit (&optional (handle-abort t)) + "Call the command interpreter recursively. If Handle-Abort is true + then an abort caused by a control-g or a lisp error does not cause + the recursive edit to be aborted." + (invoke-hook hemlock::enter-recursive-edit-hook) + (multiple-value-bind (flag args) + (let ((*in-a-recursive-edit* t) + #+nil (doc (buffer-document *current-buffer*)) + ) + (catch 'leave-recursive-edit + (unwind-protect + (progn + #+nil (when doc (document-end-editing doc)) + (if handle-abort + (loop (catch 'editor-top-level-catcher + (%command-loop))) + (%command-loop))) + #+nil + (when doc (document-begin-editing doc))))) + + (case flag + (:abort (apply #'editor-error args)) + (:exit (values-list args)) + (t (error "Bad thing ~S thrown out of recursive edit." flag))))) + +;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context +;;; of RECURSIVE-EDIT, causing return from that function with values returned +;;; as multiple values. When not in a recursive edit, signal an error. +;;; +(defun exit-recursive-edit (&optional values) + "Exit from a recursive edit. Values is a list of things which are + to be the return values from Recursive-Edit." + (unless *in-a-recursive-edit* + (error "Not in a recursive edit!")) + (invoke-hook hemlock::exit-recursive-edit-hook values) + (throw 'leave-recursive-edit (values :exit values))) + +;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context +;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args. When not +;;; in a recursive edit, signal an error. +;;; +(defun abort-recursive-edit (&rest args) + "Abort a recursive edit, causing an Editor-Error with the args given in + the calling context." + (unless *in-a-recursive-edit* + (error "Not in a recursive edit!")) + (invoke-hook hemlock::abort-recursive-edit-hook args) + (throw 'leave-recursive-edit (values :abort args))) + + + +;;;; WITH-WRITABLE-BUFFER + +;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same +;;; buffer. +;;; +(defvar *writable-buffers* ()) + +(defmacro with-writable-buffer ((buffer) &body body) + "Executes body in a scope where buffer is writable. After body executes, + this sets the buffer's modified and writable status to nil." + (let ((buf (gensym)) + (no-unwind (gensym))) + `(let* ((,buf ,buffer) + (,no-unwind (member ,buf *writable-buffers* :test #'eq)) + (*writable-buffers* (if ,no-unwind + *writable-buffers* + (cons ,buf *writable-buffers*)))) + (unwind-protect + (progn + (setf (buffer-writable ,buf) t) + ,@body) + (unless ,no-unwind + (setf (buffer-modified ,buf) nil) + (setf (buffer-writable ,buf) nil)))))) + + + + +;;;; DEFMODE. + +(defun defmode (name &key (setup-function #'identity) + (cleanup-function #'identity) major-p transparent-p + precedence documentation hidden) + "Define a new mode, specifying whether it is a major mode, and what the + setup and cleanup functions are. Precedence, which defaults to 0.0, and is + any integer or float, determines the order of the minor modes in a buffer. + A minor mode having a greater precedence is always considered before a mode + with lesser precedence when searching for key-bindings and variable values. + If Transparent-p is true, then all key-bindings local to the defined mode + are transparent, meaning that they do not shadow other bindings, but rather + are executed in addition to them. Documentation is used as introductory + text for mode describing commands." + (let ((hook-str (concatenate 'string name " Mode Hook")) + (mode (getstring name *mode-names*))) + (cond + (mode + (when (if major-p + (not (mode-object-major-p mode)) + (mode-object-major-p mode)) + (cerror "Let bad things happen" + "Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~ + where it was ~%~ + previously a ~:*~:[Major~;Minor~] mode." name major-p)) + (warn "Mode ~S is being redefined, variables and bindings will ~ + be preserved." name) + (setq name (mode-object-name mode))) + (t + (defhvar hook-str + (concatenate 'string "This is the mode hook variable for " + name " Mode.")) + (setq mode (make-mode-object + :variables (make-string-table) + :bindings (make-hash-table) + :hook-name (getstring hook-str *global-variable-names*) + :hidden hidden)) + (setf (getstring name *mode-names*) mode))) + + (if precedence + (if major-p + (error "Precedence ~S is meaningless for a major mode." precedence) + (check-type precedence number)) + (setq precedence 0)) + + (setf (mode-object-major-p mode) major-p + (mode-object-documentation mode) documentation + (mode-object-transparent-p mode) transparent-p + (mode-object-precedence mode) precedence + (mode-object-setup-function mode) setup-function + (mode-object-cleanup-function mode) cleanup-function + (mode-object-name mode) name)) + nil) + +(defun mode-major-p (name) + "Returns T if Name is the name of a major mode, or NIL if is the name of + a minor mode." + (mode-object-major-p (get-mode-object name))) + +(defun mode-variables (name) + "Return the string-table that contains the names of the modes variables." + (mode-object-variables (get-mode-object name))) + +(defun mode-documentation (name) + "Returns the documentation for mode with name." + (mode-object-documentation (get-mode-object name))) + + + + +;;;; Making and Deleting buffers. + +(defvar *buffer-list* () "A list of all the buffer objects.") + +(defvar *current-buffer* () + "Internal variable which might contain the current buffer." ) + +(defun make-buffer (name &key (modes (value hemlock::default-modes)) + (modeline-fields + (value hemlock::default-modeline-fields)) + delete-hook) + "Creates and returns a buffer with the given Name if a buffer with Name does + not already exist, otherwise returns nil. Modes is a list of mode names, + and Modeline-fields is a list of modeline field objects. Delete-hook is a + list of functions that take a buffer as the argument." + (cond ((getstring name *buffer-names*) nil) + (t + (unless (listp delete-hook) + (error ":delete-hook is a list of functions -- ~S." delete-hook)) + (let* ((region (make-empty-region)) + (object (getstring "Fundamental" *mode-names*)) + (buffer (internal-make-buffer + :%name name + :%region region + :modes (list (mode-object-name object)) + :mode-objects (list object) + :bindings (make-hash-table) + :point (copy-mark (region-end region)) + :display-start (copy-mark (region-start region)) + :delete-hook delete-hook + :variables (make-string-table)))) + (sub-set-buffer-modeline-fields buffer modeline-fields) + (setf (line-%buffer (mark-line (region-start region))) buffer) + (push buffer *buffer-list*) + (setf (getstring name *buffer-names*) buffer) + (unless (equalp modes '("Fundamental")) + (setf (buffer-major-mode buffer) (car modes)) + (dolist (m (cdr modes)) + (setf (buffer-minor-mode buffer m) t))) + (invoke-hook hemlock::make-buffer-hook buffer) + buffer)))) + +(defun delete-buffer (buffer) + "Deletes a buffer. If buffer is current, or if it is displayed in any + windows, an error is signaled." + (when (eq buffer *current-buffer*) + (error "Cannot delete current buffer ~S." buffer)) + (when (buffer-windows buffer) + (error "Cannot delete buffer ~S, which is displayed in ~R window~:P." + buffer (length (buffer-windows buffer)))) + (invoke-hook (buffer-delete-hook buffer) buffer) + (invoke-hook hemlock::delete-buffer-hook buffer) + (setq *buffer-list* (delq buffer *buffer-list*)) + (delete-string (buffer-name buffer) *buffer-names*) + nil) + + + + +;;;; Buffer start and end marks. + +(defun buffer-start-mark (buffer) + "Returns the buffer-region's start mark." + (region-start (buffer-region buffer))) + +(defun buffer-end-mark (buffer) + "Returns the buffer-region's end mark." + (region-end (buffer-region buffer))) + + + + +;;;; Setting up initial buffer. + +;;; SETUP-INITIAL-BUFFER -- Internal +;;; +;;; Create the buffer "Main" and the mode "Fundamental". We make a +;;; dummy fundamental mode before we make the buffer Main, because +;;; "make-buffer" wants fundamental to be defined when it is called, and we +;;; can't make the real fundamental mode until there is a current buffer +;;; because "defmode" wants to invoke it's mode definition hook. Also, +;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet +;;; defined, so we supply this argument to MAKE-BUFFER as nil. This is +;;; fine since firing up the editor in a core must set the "Main" buffer's +;;; modeline according to this variable in case the user changed it in his +;;; init file. After the main buffer is created we then define the real +;;; fundamental mode and bash it into the buffer. +;;; +(defun setup-initial-buffer () + ;; Make it look like the mode is there so make-buffer doesn't die. + (setf (getstring "Fundamental" *mode-names*) + (make-mode-object :major-p t)) + ;; Make it look like there is a make-buffer-hook... + (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value) + (make-variable-object "foo" "bar")) + (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental") + :modeline-fields nil)) + ;; Make the bogus variable go away... + (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value) + ;; Make it go away so defmode doesn't die. + (setf (getstring "Fundamental" *mode-names*) nil) + (defmode "Fundamental" :major-p t) + ;; Bash the real mode object into the buffer. + (let ((obj (getstring "Fundamental" *mode-names*))) + (setf (car (buffer-mode-objects *current-buffer*)) obj + (car (buffer-modes *current-buffer*)) (mode-object-name obj)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/charmacs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/charmacs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/charmacs.lisp (revision 8058) @@ -0,0 +1,99 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Implementation specific character-hacking macros and constants. +;;; +(in-package :hemlock-internals) + +;;; This file contains various constants and macros which are implementation or +;;; ASCII dependant. It contains some versions of CHAR-CODE which do not check +;;; types and ignore the top bit so that various structures can be allocated +;;; 128 long instead of 256, and we don't get errors if a loser visits a binary +;;; file. +;;; +;;; There are so many different constants and macros implemented the same. +;;; This is to separate various mechanisms; for example, in principle the +;;; char-code-limit for the syntax functions is independant of that for the +;;; searching functions +;;; + + + + +;;;; Stuff for the Syntax table functions (syntax) + +(defconstant syntax-char-code-limit char-code-limit + "The highest char-code which a character argument to the syntax + table functions may have.") + + +;;; This has the effect of treating all characters with code > 255 +;;; as if they were #\u+00ff. Not quite right, but better than +;;; flying off the end. +(defmacro syntax-char-code (char) + `(min (char-code ,char) 255)) + + +;;;; Stuff used by the searching primitives (search) +;;; +(defconstant search-char-code-limit 128 + "The exclusive upper bound on significant char-codes for searching.") +(defmacro search-char-code (ch) + `(logand (char-code ,ch) #x+7F)) +;;; +;;; search-hash-code must be a function with the following properties: +;;; given any character it returns a number between 0 and +;;; search-char-code-limit, and the same hash code must be returned +;;; for the upper and lower case forms of each character. +;;; In ASCII this is can be done by ANDing out the 5'th bit. +;;; +(defmacro search-hash-code (ch) + `(logand (char-code ,ch) #x+5F)) + +;;; Doesn't do anything special, but it should fast and not waste any time +;;; checking type and whatnot. +(defmacro search-char-upcase (ch) + `(char-upcase (the base-char ,ch))) + + + + +;;;; DO-ALPHA-CHARS. + +;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var +;;; to the alphabetic characters and executing body. Note that the manual +;;; guarantees lower and upper case char codes to be separately in order, +;;; but other characters may be interspersed within that ordering. +(defmacro alpha-chars-loop (var start-char end-char result body) + (let ((n (gensym)) + (end-char-code (gensym))) + `(do ((,n (char-code ,start-char) (1+ ,n)) + (,end-char-code (char-code ,end-char))) + ((> ,n ,end-char-code) ,result) + (let ((,var (code-char ,n))) + (when (alpha-char-p ,var) + ,@body))))) + +(defmacro do-alpha-chars ((var kind &optional result) &rest forms) + "(do-alpha-chars (var kind [result]) . body). Kind is one of + :lower, :upper, or :both, and var is bound to each character in + order as specified under character relations in the manual. When + :both is specified, lowercase letters are processed first." + (case kind + (:both + `(progn (alpha-chars-loop ,var #\a #\z nil ,forms) + (alpha-chars-loop ,var #\A #\Z ,result ,forms))) + (:lower + `(alpha-chars-loop ,var #\a #\z ,result ,forms)) + (:upper + `(alpha-chars-loop ,var #\A #\Z ,result ,forms)) + (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." + kind)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/cocoa-hemlock.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/cocoa-hemlock.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/cocoa-hemlock.lisp (revision 8058) @@ -0,0 +1,214 @@ +;;; -*- Mode: Lisp; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; Hemlock was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. + +(in-package :hemlock-internals) + +(defstruct (frame-event-queue (:include ccl::locked-dll-header)) + (signal (ccl::make-semaphore)) + (quoted-insert nil)) + +(defstruct (buffer-operation (:include ccl::dll-node)) + (thunk nil)) + +(defstruct (event-queue-node (:include ccl::dll-node) + (:constructor make-event-queue-node (event))) + event) + +(defun event-queue-insert (q node) + (ccl::locked-dll-header-enqueue node q) + (ccl::signal-semaphore (frame-event-queue-signal q))) + +(defun enqueue-key-event (q event) + (event-queue-insert q (make-event-queue-node event))) + +(defun dequeue-key-event (q) + (unless (listen-editor-input q) + (let* ((document (buffer-document (current-buffer)))) + (when document + (document-set-point-position document)))) + (ccl::wait-on-semaphore (frame-event-queue-signal q)) + (ccl::locked-dll-header-dequeue q)) + + +(defun unget-key-event (event q) + (ccl::with-locked-dll-header (q) + (ccl::insert-dll-node-after (make-event-queue-node event) q)) + (ccl::signal-semaphore (frame-event-queue-signal q))) + +(defun timed-wait-for-key-event (q seconds) + (let* ((signal (frame-event-queue-signal q))) + (when (ccl:timed-wait-on-semaphore signal seconds) + (ccl:signal-semaphore signal) + t))) + +(defvar *command-key-event-buffer* nil) + + + +(defun buffer-windows (buffer) + (let* ((doc (buffer-document buffer))) + (when doc + (document-panes doc)))) + +(defvar *current-window* ()) + +(defvar *window-list* ()) +(defun current-window () + "Return the current window. The current window is specially treated by + redisplay in several ways, the most important of which is that is does + recentering, ensuring that the Buffer-Point of the current window's + Window-Buffer is always displayed. This may be set with Setf." + *current-window*) + +(defun %set-current-window (new-window) + #+not-yet + (invoke-hook hemlock::set-window-hook new-window) + (activate-hemlock-view new-window) + (setq *current-window* new-window)) + +;;; This is a public variable. +;;; +(defvar *last-key-event-typed* () + "This variable contains the last key-event typed by the user and read as + input.") + +(defvar *input-transcript* ()) + +(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G")) + +(defmacro abort-key-event-p (key-event) + `(member (event-queue-node-event ,key-event) editor-abort-key-events)) + +(defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift")) + +(defun get-key-event (q &optional ignore-pending-aborts) + (do* ((e (dequeue-key-event q) (dequeue-key-event q))) + ((typep e 'event-queue-node) + (unless ignore-pending-aborts + (when (abort-key-event-p e) + (beep) + (clear-echo-area) + (throw 'editor-top-level-catcher nil))) + (values (setq *last-key-event-typed* (event-queue-node-event e)) + (prog1 (frame-event-queue-quoted-insert q) + (setf (frame-event-queue-quoted-insert q) nil)))) + (if (typep e 'buffer-operation) + (catch 'command-loop-catcher + (funcall (buffer-operation-thunk e)))))) + +(defun recursive-get-key-event (q &optional ignore-pending-aborts) + (let* ((buffer *command-key-event-buffer*) + (doc (when buffer (buffer-document buffer)))) + (if (null doc) + (get-key-event q ignore-pending-aborts) + (unwind-protect + (progn + (document-end-editing doc) + (get-key-event q ignore-pending-aborts)) + (document-begin-editing doc))))) + + +(defun listen-editor-input (q) + (ccl::with-locked-dll-header (q) + (not (eq (ccl::dll-header-first q) q)))) + +(defun add-buffer-font-region (buffer region) + (when (typep buffer 'buffer) + (let* ((header (buffer-font-regions buffer)) + (node (make-font-region-node region))) + (ccl::append-dll-node node header) + (setf (font-region-node region) node) + region))) + +(defun enable-self-insert (q) + (setf (frame-event-queue-quoted-insert q) t)) + +(defmethod disable-self-insert ((q frame-event-queue)) + (setf (frame-event-queue-quoted-insert q) nil)) + +(defun remove-font-region (region) + (ccl::remove-dll-node (font-region-node region))) + +(defun previous-font-region (region) + (let* ((prev-node (ccl::dll-node-pred (font-region-node region)))) + (if (typep prev-node 'font-region-node) + (font-region-node-region prev-node)))) + +(defun next-font-region (region) + (let* ((next-node (ccl::dll-node-succ (font-region-node region)))) + (if (typep next-node 'font-region-node) + (font-region-node-region next-node)))) + +;;; Make the specified font region "active", if it's non-nil and not +;;; already active. A font region is "active" if it and all of its +;;; successors have "end" marks that're left-inserting, and all of its +;;; predecessors have "end" marks that're right-inserting. +;;; It's assumed that when this is called, no other font region is +;;; active in the buffer. + +(defun activate-buffer-font-region (buffer region) + (let* ((current (buffer-active-font-region buffer))) + (unless (eq current region) + (deactivate-buffer-font-region buffer current) + (when region + (setf (mark-%kind (region-end region)) :left-inserting + (mark-%kind (region-start region)) :right-inserting) + (do* ((r (next-font-region region) (next-font-region r))) + ((null r) + current) + (setf (mark-%kind (region-end r)) :left-inserting + (mark-%kind (region-start r)) :left-inserting))) + (setf (buffer-active-font-region buffer) region) + current))) + +(defun deactivate-buffer-font-region (buffer region) + (when (and region (eq (buffer-active-font-region buffer) region)) + (do* ((r region (next-font-region r))) + ((null r) (setf (buffer-active-font-region buffer) nil)) + (setf (mark-%kind (region-end r)) :right-inserting + (mark-%kind (region-start r)) :right-inserting)))) + + +(defmacro with-active-font-region ((buffer region) &body body) + (let* ((b (gensym)) + (old (gensym))) + `(let* ((,b ,buffer) + (,old (activate-buffer-font-region ,b ,region))) + (unwind-protect + (progn ,@body) + (activate-buffer-font-region ,b ,old))))) + + +(defun show-buffer-font-regions (buffer) + (ccl::do-dll-nodes (node (buffer-font-regions buffer)) + (let* ((r (font-region-node-region node)) + (start (region-start r)) + (end (region-end r))) + (format t "~& style ~d ~d [~s]/ ~d [~s] ~a" + (font-mark-font start) + (ccl::mark-absolute-position start) + (mark-%kind start) + (ccl::mark-absolute-position end) + (mark-%kind end) + (eq r (buffer-active-font-region buffer)))))) + +;;; Clipboard +(defun region-to-clipboard (region) + (string-to-clipboard (region-to-string region))) + +;;; Meta-. +(defun hemlock::get-def-info-and-go-to-it (string package) + (multiple-value-bind (fun-name error) + (let* ((*package* package)) + (ignore-errors (values (read-from-string string)))) + (if error + (editor-error) + (hi::edit-definition fun-name)))) + +;;; Search highlighting +(defun note-selection-set-by-search (&optional (buffer (current-buffer))) + (let* ((doc (buffer-document buffer))) + (when doc (hi::document-note-selection-set-by-search doc)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/command.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/command.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/command.lisp (revision 8058) @@ -0,0 +1,535 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the definitions for the basic Hemlock commands. +;;; + +(in-package :hemlock) + + +;;; Make a mark for buffers as they're consed: + +(defun hcmd-new-buffer-hook-fun (buff) + (let ((ring (make-ring 10 #'delete-mark))) + (defhvar "Buffer Mark Ring" + "This variable holds this buffer's mark ring." + :buffer buff + :value ring) + (setf (hi::buffer-%mark buff) (copy-mark (buffer-point buff) :right-inserting)))) + +(add-hook make-buffer-hook #'hcmd-new-buffer-hook-fun) +(dolist (buff *buffer-list*) (hcmd-new-buffer-hook-fun buff)) + + + + + + + + +;;;; Simple character manipulation: + +(defcommand "Self Insert" (p) + "Insert the last character typed. + With prefix argument insert the character that many times." + "Implements ``Self Insert'', calling this function is not meaningful." + (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))) + (unless char (editor-error "Can't insert that character.")) + (if (and p (> p 1)) + (insert-string + (current-point-for-insertion) + (make-string p :initial-element char)) + (insert-character (current-point-for-insertion) char)))) + +(defcommand "Quoted Insert" (p) + "Causes the next character typed to be inserted in the current + buffer, even if would normally be interpreted as an editor command." + "Reads a key-event from *editor-input* and inserts it at the point." + (declare (ignore p)) + (hi::enable-self-insert hi::*editor-input*)) + +(defcommand "Forward Character" (p) + "Move the point forward one character, collapsing the selection. + With prefix argument move that many characters, with negative argument + go backwards." + "Move the point of the current buffer forward p characters, collapsing the selection." + (let* ((p (or p 1)) + (point (current-point-collapsing-selection))) + (cond ((character-offset point p)) + ((= p 1) + (editor-error "No next character.")) + ((= p -1) + (editor-error "No previous character.")) + (t + (if (plusp p) + (buffer-end point) + (buffer-start point)) + (editor-error "Not enough characters."))))) + +(defcommand "Select Forward Character" (p) + "Move the point forward one character, extending the selection. + With prefix argument move that many characters, with negative argument + go backwards." + "Move the point of the current buffer forward p characters, extending the selection." + (let* ((p (or p 1)) + (point (current-point-extending-selection))) + (cond ((character-offset point p)) + ((= p 1) + (editor-error "No next character.")) + ((= p -1) + (editor-error "No previous character.")) + (t + (if (plusp p) + (buffer-end point) + (buffer-start point)) + (editor-error "Not enough characters."))))) + +(defcommand "Backward Character" (p) + "Move the point backward one character, collapsing the selection. + With prefix argument move that many characters backward." + "Move the point p characters backward, collapsing the selection." + (forward-character-command (if p (- p) -1))) + +(defcommand "Select Backward Character" (p) + "Move the point backward one character, extending the selection. + With prefix argument move that many characters backward." + "Move the point p characters backward, extending the selection." + (select-forward-character-command (if p (- p) -1))) + +#| +(defcommand "Delete Next Character" (p) + "Deletes the character to the right of the point. + With prefix argument, delete that many characters to the right + (or left if prefix is negative)." + "Deletes p characters to the right of the point." + (unless (delete-characters (current-point) (or p 1)) + (buffer-end (current-point)) + (editor-error "No next character."))) + +(defcommand "Delete Previous Character" (p) + "Deletes the character to the left of the point. + With prefix argument, delete that many characters to the left + (or right if prefix is negative)." + "Deletes p characters to the left of the point." + (unless (delete-characters (current-point) (if p (- p) -1)) + (editor-error "No previous character."))) +|# + +(defcommand "Delete Next Character" (p) + "Deletes the character to the right of the point. + With prefix argument, delete that many characters to the right + (or left if prefix is negative)." + "Deletes p characters to the right of the point." + (let* ((point (current-point-for-deletion))) + (when point + (cond ((kill-characters point (or p 1))) + ((and p (minusp p)) + (editor-error "Not enough previous characters.")) + (t + (editor-error "Not enough next characters.")))))) + +(defcommand "Delete Previous Character" (p) + "Deletes the character to the left of the point. + Will push characters from successive deletes on to the kill ring." + "Deletes the character to the left of the point. + Will push characters from successive deletes on to the kill ring." + (delete-next-character-command (- (or p 1)))) + +(defcommand "Transpose Characters" (p) + "Exchanges the characters on either side of the point and moves forward + With prefix argument, does this that many times. A negative prefix + argument causes the point to be moved backwards instead of forwards." + "Exchanges the characters on either side of the point and moves forward." + (let ((arg (or p 1)) + (point (current-point-unless-selection))) + (when point + (dotimes (i (abs arg)) + (when (minusp arg) (mark-before point)) + (let ((prev (previous-character point)) + (next (next-character point))) + + (cond ((not prev) (editor-error "No previous character.")) + ((not next) (editor-error "No next character.")) + (t + (setf (previous-character point) next) + (setf (next-character point) prev)))) + (when (plusp arg) (mark-after point)))))) + + +;;;; Word hacking commands: + +;;; WORD-OFFSET +;;; +;;; Move a mark forward/backward some words. +;;; +(defun word-offset (mark offset) + "Move Mark by Offset words." + (if (minusp offset) + (do ((cnt offset (1+ cnt))) + ((zerop cnt) mark) + (cond + ((null (reverse-find-attribute mark :word-delimiter #'zerop)) + (return nil)) + ((reverse-find-attribute mark :word-delimiter)) + (t + (move-mark + mark (buffer-start-mark (line-buffer (mark-line mark))))))) + (do ((cnt offset (1- cnt))) + ((zerop cnt) mark) + (cond + ((null (find-attribute mark :word-delimiter #'zerop)) + (return nil)) + ((null (find-attribute mark :word-delimiter)) + (return nil)))))) + +(defcommand "Forward Word" (p) + "Moves forward one word, collapsing the selection. + With prefix argument, moves the point forward over that many words." + "Moves the point forward p words, collapsing the selection." + (let* ((point (current-point-collapsing-selection))) + (cond ((word-offset point (or p 1))) + ((and p (minusp p)) + (buffer-start point) + (editor-error "No previous word.")) + (t + (buffer-end point) + (editor-error "No next word."))))) + +(defcommand "Select Forward Word" (p) + "Moves forward one word, extending the selection. + With prefix argument, moves the point forward over that many words." + "Moves the point forward p words, extending the selection." + (let* ((point (current-point-extending-selection))) + (cond ((word-offset point (or p 1))) + ((and p (minusp p)) + (buffer-start point) + (editor-error "No previous word.")) + (t + (buffer-end point) + (editor-error "No next word."))))) + +(defcommand "Backward Word" (p) + "Moves forward backward word. + With prefix argument, moves the point back over that many words." + "Moves the point backward p words." + (forward-word-command (- (or p 1)))) + +(defcommand "Select Backward Word" (p) + "Moves forward backward word, extending the selection. + With prefix argument, moves the point back over that many words." + "Moves the point backward p words, extending the selection." + (select-forward-word-command (- (or p 1)))) + + + + +;;;; Moving around: + +(defvar *target-column* 0) + +(defun set-target-column (mark) + (if (eq (last-command-type) :line-motion) + *target-column* + (setq *target-column* (mark-column mark)))) + +(defhvar "Next Line Inserts Newlines" + "If true, causes the \"Next Line\" command to insert newlines when + moving past the end of the buffer." + :value nil) + + +(defcommand "Next Line" (p) + "Moves the point to the next line, collapsing the selection. + With prefix argument, moves the point that many lines down (or up if + the prefix is negative)." + "Moves the down p lines, collapsing the selection." + (let* ((point (current-point-collapsing-selection)) + (target (set-target-column point))) + (unless (line-offset point (or p 1)) + (when (value next-line-inserts-newlines) + (cond ((not p) + (when (same-line-p point (buffer-end-mark (current-buffer))) + (line-end point)) + (insert-character point #\newline)) + ((minusp p) + (buffer-start point) + (editor-error "No previous line.")) + (t + (buffer-end point) + (when p (editor-error "No next line.")))))) + (unless (move-to-column point target) (line-end point)) + (setf (last-command-type) :line-motion))) + +(defcommand "Select Next Line" (p) + "Moves the point to the next line, extending the selection. + With prefix argument, moves the point that many lines down (or up if + the prefix is negative)." + "Moves the down p lines, extendin the selection." + (let* ((point (current-point-extending-selection)) + (target (set-target-column point))) + (unless (line-offset point (or p 1)) + (when (value next-line-inserts-newlines) + (cond ((not p) + (when (same-line-p point (buffer-end-mark (current-buffer))) + (line-end point)) + (insert-character point #\newline)) + ((minusp p) + (buffer-start point) + (editor-error "No previous line.")) + (t + (buffer-end point) + (when p (editor-error "No next line.")))))) + (unless (move-to-column point target) (line-end point)) + (setf (last-command-type) :line-motion))) + + +(defcommand "Previous Line" (p) + "Moves the point to the previous line, collapsing the selection. + With prefix argument, moves the point that many lines up (or down if + the prefix is negative)." + "Moves the point up p lines, collapsing the selection." + (next-line-command (- (or p 1)))) + +(defcommand "Select Previous Line" (p) + "Moves the point to the previous line, collapsing the selection. + With prefix argument, moves the point that many lines up (or down if + the prefix is negative)." + "Moves the point up p lines, collapsing the selection." + (select-next-line-command (- (or p 1)))) + +(defcommand "Mark to End of Buffer" (p) + "Sets the current region from point to the end of the buffer." + "Sets the current region from point to the end of the buffer." + (declare (ignore p)) + (push-buffer-mark (buffer-end (copy-mark (current-point))) t)) + +(defcommand "Mark to Beginning of Buffer" (p) + "Sets the current region from the beginning of the buffer to point." + "Sets the current region from the beginning of the buffer to point." + (declare (ignore p)) + (push-buffer-mark (buffer-start (copy-mark (current-point))) t)) + +(defcommand "Beginning of Buffer" (p) + "Moves the point to the beginning of the current buffer, collapsing the selection." + "Moves the point to the beginning of the current buffer, collapsing the selection." + (declare (ignore p)) + (let ((point (current-point-collapsing-selection))) + (push-buffer-mark (copy-mark point)) + (buffer-start point))) + +(defcommand "End of Buffer" (p) + "Moves the point to the end of the current buffer." + "Moves the point to the end of the current buffer." + (declare (ignore p)) + (let ((point (current-point-collapsing-selection))) + (push-buffer-mark (copy-mark point)) + (buffer-end point))) + +(defcommand "Beginning of Line" (p) + "Moves the point to the beginning of the current line, collapsing the selection. + With prefix argument, moves the point to the beginning of the prefix'th + next line." + "Moves the point down p lines and then to the beginning of the line, collapsing the selection." + (let ((point (current-point-collapsing-selection))) + (unless (line-offset point (if p p 0)) (editor-error "No such line.")) + (line-start point))) + +(defcommand "Select to Beginning of Line" (p) + "Moves the point to the beginning of the current line, extending the selection. + With prefix argument, moves the point to the beginning of the prefix'th + next line." + "Moves the point down p lines and then to the beginning of the line, extending the selection." + (let ((point (current-point-extending-selection))) + (unless (line-offset point (if p p 0)) (editor-error "No such line.")) + (line-start point))) + +(defcommand "End of Line" (p) + "Moves the point to the end of the current line, collapsing the selection. + With prefix argument, moves the point to the end of the prefix'th next line." + "Moves the point down p lines and then to the end of the line, collapsing the selection." + (let ((point (current-point-collapsing-selection))) + (unless (line-offset point (if p p 0)) (editor-error "No such line.")) + (line-end point))) + +(defcommand "Select to End of Line" (p) + "Moves the point to the end of the current line, extending the selection. + With prefix argument, moves the point to the end of the prefix'th next line." + "Moves the point down p lines and then to the end of the line, extending the selection." + (let ((point (current-point-extending-selection))) + (unless (line-offset point (if p p 0)) (editor-error "No such line.")) + (line-end point))) + +(defhvar "Scroll Overlap" + "The \"Scroll Window\" commands leave this much overlap between screens." + :value 2) + +(defhvar "Scroll Redraw Ratio" + "This is a ratio of \"inserted\" lines to the size of a window. When this + ratio is exceeded, insert/delete line terminal optimization is aborted, and + every altered line is simply redrawn as efficiently as possible. For example, + setting this to 1/4 will cause scrolling commands to redraw the entire window + instead of moving the bottom two lines of the window to the top (typically + 3/4 of the window is being deleted upward and inserted downward, hence a + redraw); however, commands line \"New Line\" and \"Open Line\" will still + efficiently, insert a line moving the rest of the window's text downward." + :value nil) + +(defcommand "Scroll Window Down" (p &optional (window (current-window))) + "Move down one screenfull. + With prefix argument scroll down that many lines." + "If P is NIL then scroll Window, which defaults to the current + window, down one screenfull. If P is supplied then scroll that + many lines." + (scroll-window window (or p :page-down))) + +(defcommand "Scroll Window Up" (p &optional (window (current-window))) + "Move up one screenfull. + With prefix argument scroll up that many lines." + "If P is NIL then scroll Window, which defaults to the current + window, up one screenfull. If P is supplied then scroll that + many lines." + (scroll-window window (if p (- p) :page-up))) + +(defcommand "Scroll Next Window Down" (p) + "Do a \"Scroll Window Down\" on the next window." + "Do a \"Scroll Window Down\" on the next window." + (let ((win (next-window (current-window)))) + (when (eq win (current-window)) (editor-error "Only one window.")) + (scroll-window-down-command p win))) + +(defcommand "Scroll Next Window Up" (p) + "Do a \"Scroll Window Up\" on the next window." + "Do a \"Scroll Window Up\" on the next window." + (let ((win (next-window (current-window)))) + (when (eq win (current-window)) (editor-error "Only one window.")) + (scroll-window-up-command p win))) + + + + +;;;; Kind of miscellaneous commands: + +;;; "Refresh Screen" may not be right with respect to wrapping lines in +;;; the case where an argument is supplied due the use of +;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter +;;; messed with point and did other hard to predict stuff. +;;; +(defcommand "Refresh Screen" (p) + "Refreshes everything in the window, centering current line." + "Refreshes everything in the window, centering current line." + (declare (ignore p)) + (center-text-pane (current-window))) + + + +;;; +(defun reset-window-display-recentering (window &optional buffer) + (declare (ignore buffer)) + (setf (window-display-recentering window) nil)) +;;; +(add-hook window-buffer-hook #'reset-window-display-recentering) + + +(defcommand "Extended Command" (p) + "Prompts for and executes an extended command." + "Prompts for and executes an extended command. The prefix argument is + passed to the command." + (let* ((name (prompt-for-keyword (list *command-names*) + :prompt "Extended Command: " + :help "Name of a Hemlock command")) + (function (command-function (getstring name *command-names*)))) + (funcall function p))) + +(defhvar "Universal Argument Default" + "Default value for \"Universal Argument\" command." + :value 4) + +(defcommand "Universal Argument" (p) + "Sets prefix argument for next command. + Typing digits, regardless of any modifier keys, specifies the argument. + Optionally, you may first type a sign (- or +). While typing digits, if you + type C-U or C-u, the digits following the C-U form a number this command + multiplies by the digits preceding the C-U. The default value for this + command and any number following a C-U is the value of \"Universal Argument + Default\"." + "You probably don't want to use this as a function." + (declare (ignore p)) + (clear-echo-area) + (write-string "C-U " *echo-area-stream*) + (let* ((key-event (get-key-event hi::*editor-input*)) + (char (hemlock-ext:key-event-char key-event))) + (if char + (case char + (#\- + (write-char #\- *echo-area-stream*) + (universal-argument-loop (get-key-event hi::*editor-input*) -1)) + (#\+ + (write-char #\+ *echo-area-stream*) + (universal-argument-loop (get-key-event hi::*editor-input*) -1)) + (t + (universal-argument-loop key-event 1))) + (universal-argument-loop key-event 1)))) + +(defcommand "Negative Argument" (p) + "This command is equivalent to invoking \"Universal Argument\" and typing + a minus sign (-). It waits for more digits and a command to which to give + the prefix argument." + "Don't call this as a function." + (when p (editor-error "Must type minus sign first.")) + (clear-echo-area) + (write-string "C-U -" *echo-area-stream*) + (universal-argument-loop (get-key-event hi::*editor-input*) -1)) + +(defcommand "Argument Digit" (p) + "This command is equivalent to invoking \"Universal Argument\" and typing + the digit used to invoke this command. It waits for more digits and a + command to which to give the prefix argument." + "Don't call this as a function." + (declare (ignore p)) + (clear-echo-area) + (write-string "C-U " *echo-area-stream*) + (universal-argument-loop *last-key-event-typed* 1)) + +(defun universal-argument-loop (key-event sign &optional (multiplier 1)) + (flet ((prefix (sign multiplier read-some-digit-p result) + ;; read-some-digit-p and (zerop result) are not + ;; equivalent if the user invokes this and types 0. + (* sign multiplier + (if read-some-digit-p + result + (value universal-argument-default))))) + (let* ((stripped-key-event (if key-event (hemlock-ext:make-key-event key-event))) + (char (hemlock-ext:key-event-char stripped-key-event)) + (digit (if char (digit-char-p char))) + (result 0) + (read-some-digit-p nil)) + (loop + (cond (digit + (setf read-some-digit-p t) + (write-char char *echo-area-stream*) + (setf result (+ digit (* 10 result))) + (setf key-event (get-key-event hi::*editor-input*)) + (setf stripped-key-event (if key-event + (hemlock-ext:make-key-event key-event))) + (setf char (hemlock-ext:key-event-char stripped-key-event)) + (setf digit (if char (digit-char-p char)))) + ((or (eq key-event #k"C-u") (eq key-event #k"C-U")) + (write-string " C-U " *echo-area-stream*) + (universal-argument-loop + (get-key-event hi::*editor-input*) 1 + (prefix sign multiplier read-some-digit-p result)) + (return)) + (t + (unget-key-event key-event hi::*editor-input*) + (setf (prefix-argument) + (prefix sign multiplier read-some-digit-p result)) + (return)))))) + (setf (last-command-type) (last-command-type))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/comments.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/comments.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/comments.lisp (revision 8058) @@ -0,0 +1,407 @@ +;;; -*- Log: Hemlock.Log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains the implementation of comment commands. + +(in-package hemlock) + + + +;;;; -- Variables -- + +(defhvar "Comment Column" + "Colmun to start comments in." + :value 0) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :value nil) + +(defhvar "Comment End" + "String that ends comments. Nil indicates #\newline termination." + :value nil) + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :value nil) + + +;;;; -- Internal Specials -- + +;;; For the search pattern state specials, we just use " " as the comment +;;; start and end if none exist, so we are able to make search patterns. +;;; This is reasonable since any use of these will cause the patterns to be +;;; made consistent with the actual start and end strings. + +(defvar *comment-start-pattern* + (new-search-pattern :string-insensitive :forward (or (value comment-start) " ")) + "Search pattern to keep around for looking for comment starts.") + +(defvar *last-comment-start* + (or (value comment-start) " ") + "Previous comment start used to make *comment-start-pattern*.") + +(defvar *comment-end-pattern* + (new-search-pattern :string-insensitive :forward (or (value comment-end) " ")) + "Search pattern to keep around for looking for comment ends.") + +(defvar *last-comment-end* + (or (value comment-end) " ") + "Previous comment end used to make *comment-end-pattern*.") + + +(eval-when (:compile-toplevel :execute) +(defmacro get-comment-pattern (string kind) ;kind is either :start or :end + (let (pattern-var last-var) + (cond ((eq kind :start) + (setf pattern-var '*comment-start-pattern*) + (setf last-var '*last-comment-start*)) + (t (setf pattern-var '*comment-end-pattern*) + (setf last-var '*last-comment-end*))) + `(cond ((string= (the simple-string ,string) (the simple-string ,last-var)) + ,pattern-var) + (t (setf ,last-var ,string) + (new-search-pattern :string-insensitive :forward + ,string ,pattern-var))))) +) ;eval-when + + + +;;;; -- Commands -- + +(defcommand "Set Comment Column" (p) + "Set Comment Column to current column or argument. + If argument is provided use its absolute value." + "Set Comment Column to current column or argument. + If argument is provided use its absolute value." + (let ((new-column (or (and p (abs p)) + (mark-column (current-point))))) + (defhvar "Comment Column" "This buffer's column to start comments." + :value new-column :buffer (current-buffer)) + (message "Comment Column = ~D" new-column))) + + +(defcommand "Indent for Comment" (p) + "Move to or create a comment. Moves to the start of an existing comment + and indents it to start in Comment Column. An existing double semicolon + comment is aligned like a line of code. An existing triple semicolon + comment or any that start in column 0 is not moved. With argument, + aligns any comments on the next argument lines but does not create any. + If characters extend past comment column, a space is added before + starting comment." + "Create comment or move to beginning of existing one aligning it." + (let* ((column (value comment-column)) + (start (value comment-start)) + (begin (value comment-begin)) + (end (value comment-end))) + (unless (stringp start) (editor-error "No comment start string -- ~S." start)) + (indent-for-comment (current-point) column start begin end (or p 1)))) + + +(defcommand "Up Comment Line" (p) + "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)." + "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)." + (let ((column (value comment-column)) + (start (value comment-start)) + (begin (value comment-begin)) + (end (value comment-end))) + (unless (stringp start) (editor-error "No comment start string -- ~S." start)) + (change-comment-line (current-point) column start + begin end (or (and p (- p)) -1)))) + +(defcommand "Down Comment Line" (p) + "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)." + "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)." + (let ((column (value comment-column)) + (start (value comment-start)) + (begin (value comment-begin)) + (end (value comment-end))) + (unless (stringp start) (editor-error "No comment start string -- ~S." start)) + (change-comment-line (current-point) column start begin end (or p 1)))) + + +(defcommand "Kill Comment" (p) + "Kills the comment (if any) on the current line. + With argument, applies to specified number of lines, and moves past them." + "Kills the comment (if any) on the current line. + With argument, applies to specified number of lines, and moves past them." + (let ((start (value comment-start))) + (when start + (if (not (stringp start)) + (editor-error "Comment start not string or nil -- ~S." start)) + (kill-comment (current-point) start (or p 1))))) + + +(defcommand "Indent New Comment Line" (p) + "Inserts comment end and then starts a comment on a new line. + The indentation and number of additional comment-start characters are + copied from the previous line's comment. Acts like Linefeed, when done + while not inside a comment, assuming a comment is the last thing on a line." + "complete a current comment and start another a new line, copying indentation + and start characters. If no comment, call Linefeed command." + (let ((start (value comment-start)) + (begin (value comment-begin)) + (end (value comment-end)) + (point (current-point))) + (with-mark ((tmark point :left-inserting)) + (if start + (cond ((not (stringp start)) + (editor-error "Comment start not string or nil -- ~S." start)) + ((and (to-line-comment tmark start) (mark> point tmark)) + (with-mark ((emark tmark)) + (let ((endp (if end (to-comment-end emark end)))) + (cond ((and endp (mark= emark point)) + (insert-string point end) + (indent-new-comment-line point tmark start begin end)) + ((and endp + (character-offset emark endp) + (mark>= point emark)) + (indent-new-line-command p)) + (t (delete-horizontal-space point) + (if end (insert-string point end)) + (indent-new-comment-line point tmark + start begin end)))))) + (t (indent-new-line-command p))) + (indent-new-line-command p))))) + + + +;;;; -- Support Routines -- + +(eval-when (:compile-toplevel :execute) +(defmacro %do-comment-lines ((var number) mark1 &rest forms) + (let ((next-line-p (gensym))) + `(do ((,var (if (plusp ,number) ,number 0) (1- ,var)) + (,next-line-p t)) + ((or (zerop ,var) (not ,next-line-p)) + (zerop ,var)) + ,@forms + (setf ,next-line-p (line-offset ,mark1 1))))) +) ;eval-when + + +;;; CHANGE-COMMENT-LINE closes any comment on the current line, deleting +;;; an empty comment. After offsetting by lines, a comment is either +;;; aligned or created. +(defun change-comment-line (mark column start begin end lines) + (with-mark ((tmark1 mark :left-inserting) + (tmark2 mark)) + (let ((start-len (to-line-comment mark start)) + end-len) + (when start-len + (if end + (setf end-len (to-comment-end (move-mark tmark1 mark) end)) + (line-end tmark1)) + (character-offset (move-mark tmark2 mark) start-len) + (find-attribute tmark2 :whitespace #'zerop) + (cond ((mark>= tmark2 tmark1) + (if end-len (character-offset tmark1 end-len)) + ;; even though comment is blank, the line might not be blank + ;; after it in languages that have comment terminators. + (when (blank-after-p tmark1) + (reverse-find-attribute mark :whitespace #'zerop) + (if (not (same-line-p mark tmark1)) + (line-start mark (mark-line tmark1))) + (delete-region (region mark tmark1)))) + ((and end (not end-len)) (insert-string tmark1 end)))) + (if (line-offset mark lines) + (indent-for-comment mark column start begin end 1) + (editor-error))))) + + +(defun indent-for-comment (mark column start begin end times) + (with-mark ((tmark mark :left-inserting)) + (if (= times 1) + (let ((start-len (to-line-comment tmark start))) + (cond (start-len + (align-comment tmark start start-len column) + (character-offset (move-mark mark tmark) start-len)) + (t (comment-line mark column start begin end)))) + (unless (%do-comment-lines (n times) mark + (let ((start-len (to-line-comment mark start))) + (if start-len (align-comment mark start start-len column)))) + (buffer-end mark) + (editor-error))))) + + +;;; KILL-COMMENT assumes a comment is the last thing on a line, so it does +;;; not deal with comment-end. The Tao of EMACS. +(defun kill-comment (mark start times) + (with-mark ((tmark mark :left-inserting)) + (if (= times 1) + (when (to-line-comment mark start) + (with-mark ((u-start mark) + (u-end (line-end (move-mark tmark mark)))) + (rev-scan-char u-start :whitespace nil) + (let ((undo-region (copy-region (region u-start u-end)))) + (kill-ring-push (delete-and-save-region (region mark tmark))) + (delete-horizontal-space mark) + (make-region-undo :insert "Kill Comment" undo-region + (copy-mark mark :left-inserting))))) + (let* ((kill-region (delete-and-save-region (region mark tmark))) + (insert-mark (region-end kill-region)) + ;; don't delete u-start and u-end since undo stuff handles that. + (u-start (line-start (copy-mark mark :left-inserting))) + (u-end (copy-mark mark :left-inserting)) + (undo-region (copy-region (region u-start + (if (line-offset u-end times) + (line-start u-end) + (buffer-end u-end))))) + (n-times-p + (%do-comment-lines (n times) mark + (when (to-line-comment mark start) + (line-end (move-mark tmark mark)) + (ninsert-region insert-mark + (delete-and-save-region (region mark tmark))) + (insert-character insert-mark #\newline) + (delete-horizontal-space mark))))) + (kill-ring-push kill-region) + (make-region-undo :twiddle "Kill Comment" + (region u-start u-end) undo-region) + (unless n-times-p + (buffer-end mark) + (editor-error)))))) + +(defun comment-line (point column start begin end) + (let* ((open (or begin start)) + (open-len (length (the simple-string open))) + (end-len (if end (length (the simple-string end)) 0)) + (insert-len (+ open-len end-len))) + (line-end point) + (insert-string point open) + (if end (insert-string point end)) + (character-offset point (- insert-len)) + (adjust-comment point column) + (character-offset point open-len))) + + +(eval-when (:compile-toplevel :execute) +(defmacro count-extra-last-chars (mark start-len start-char) + (let ((count (gensym)) + (tmark (gensym))) + `(with-mark ((,tmark ,mark)) + (character-offset ,tmark ,start-len) + (do ((,count 0 (1+ ,count))) + ((char/= (next-character ,tmark) ,start-char) ,count) + (mark-after ,tmark))))) +) + + +;;; ALIGN-COMMENT sets a comment starting at mark to start in column +;;; column. If the comment starts at the beginning of the line, it is not +;;; moved. If the comment start is a single character and duplicated, then +;;; it is indented as if it were code, and if it is triplicated, it is not +;;; moved. If the comment is to be moved to column, then we check to see +;;; if it is already there and preceded by whitespace. + +(defun align-comment (mark start start-len column) + (unless (start-line-p mark) + (case (count-extra-last-chars mark start-len (schar start (1- start-len))) + (1 (funcall (value indent-function) mark)) + (2 ) + (t (if (or (/= (mark-column mark) column) + (zerop (character-attribute + :whitespace (previous-character mark)))) + (adjust-comment mark column)))))) + + +;;; ADJUST-COMMENT moves the comment starting at mark to start in column +;;; column, inserting a space if the line extends past column. +(defun adjust-comment (mark column) + (delete-horizontal-space mark) + (let ((current-column (mark-column mark)) + (spaces-per-tab (value spaces-per-tab)) + tabs spaces next-tab-pos) + (cond ((= current-column column) + (if (/= column 0) (insert-character mark #\space))) + ((> current-column column) (insert-character mark #\space)) + (t (multiple-value-setq (tabs spaces) + (floor current-column spaces-per-tab)) + (setf next-tab-pos + (if (zerop spaces) + current-column + (+ current-column (- spaces-per-tab spaces)))) + (cond ((= next-tab-pos column) + (insert-character mark #\tab)) + ((> next-tab-pos column) + (dotimes (i (- column current-column)) + (insert-character mark #\space))) + (t (multiple-value-setq (tabs spaces) + (floor (- column next-tab-pos) spaces-per-tab)) + (dotimes (i (if (= current-column next-tab-pos) + tabs + (1+ tabs))) + (insert-character mark #\tab)) + (dotimes (i spaces) + (insert-character mark #\space)))))))) + + +;;; INDENT-NEW-COMMENT-LINE makes a new line at point starting a comment +;;; in the same way as the one at start-mark. +(defun indent-new-comment-line (point start-mark start begin end) + (new-line-command nil) + (insert-string point (gen-comment-prefix start-mark start begin)) + (if end + (when (not (to-comment-end (move-mark start-mark point) end)) + (insert-string start-mark end) + (if (mark= start-mark point) + ;; This occurs when nothing follows point on the line and + ;; both marks are left-inserting. + (character-offset + point (- (length (the simple-string end)))))))) + + +;;; GEN-COMMENT-PREFIX returns a string suitable for beginning a line +;;; with a comment lined up with mark and starting the same as the comment +;;; immediately following mark. This is used in the auto filling stuff too. +(defun gen-comment-prefix (mark start begin) + (let* ((start-len (length (the simple-string start))) + (last-char (schar start (1- start-len))) + (extra-start-chars (count-extra-last-chars mark start-len last-char)) + (spaces-per-tab (value spaces-per-tab)) + (begin-end (if begin + (subseq begin start-len (length (the simple-string begin))) + ""))) + (multiple-value-bind (tabs spaces) (floor (mark-column mark) spaces-per-tab) + (concatenate 'simple-string + (make-string tabs :initial-element #\tab) + (make-string spaces :initial-element #\space) + start + (make-string extra-start-chars :initial-element last-char) + begin-end)))) + + +;;; TO-LINE-COMMENT moves mark to the first comment start character on its +;;; line if there is a comment and returns the length of start, otherwise +;;; nil is returned. Start must be a string. This is used by the auto +;;; filling stuff too. +(defun to-line-comment (mark start) + (with-mark ((tmark mark)) + (line-start tmark) + (let ((start-len (find-pattern tmark (get-comment-pattern start :start)))) + (when (and start-len (same-line-p mark tmark)) + (move-mark mark tmark) + start-len)))) + + +;;; TO-COMMENT-END moves mark to the first comment end character on its +;;; line if end is there and returns the length of comment end, otherwise +;;; mark is moved to the end of the line returning nil. This is used by +;;; the auto filling stuff too. +(defun to-comment-end (mark end) + (with-mark ((tmark mark)) + (let ((end-len (find-pattern tmark (get-comment-pattern end :end)))) + (cond ((and end-len (same-line-p mark tmark)) + (move-mark mark tmark) + end-len) + (t (line-end mark) nil))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/completion.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/completion.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/completion.lisp (revision 8058) @@ -0,0 +1,521 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Skef Wholey and Blaine Burks. +;;; General idea stolen from Jim Salem's TMC LISPM completion code. +;;; + +(in-package :hemlock) + + + + +;;;; The Completion Database. + +;;; The top level structure here is an array that gets indexed with the +;;; first three characters of the word to be completed. That will get us to +;;; a list of the strings with that prefix sorted in most-recently-used order. +;;; The number of strings in any given bucket will never exceed +;;; Completion-Bucket-Size-Limit. Strings are stored in the database in +;;; lowercase form always. + +(defconstant completion-table-size 991) + +(defvar *completions* (make-array completion-table-size :initial-element nil)) + +(defhvar "Completion Bucket Size" + "This limits the number of completions saved for a particular combination of + the first three letters of any word." + :value 20) + + +;;; Mapping strings into buckets. + +;;; The characters that are considered parts of "words" change from mode +;;; to mode. +;;; +(defattribute "Completion Wordchar" + "1 for characters we consider to be constituents of words.") + +(defvar default-other-wordchars + '(#\- #\* #\' #\_)) + +(do-alpha-chars (char :both) + (setf (character-attribute :completion-wordchar char) 1)) + +(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (setf (character-attribute :completion-wordchar char) 1)) + +(dolist (char default-other-wordchars) + (setf (character-attribute :completion-wordchar char) 1)) + + +;;; The difference between Lisp mode and the other modes is pretty radical in +;;; this respect. These are interesting too, but they're on by default: #\*, +;;; #\-, and #\_. #\' is on by default too, but it's uninteresting in "Lisp" +;;; mode. +;;; +(defvar default-lisp-wordchars + '(#\~ #\! #\@ #\$ #\% #\^ #\& #\+ #\= #\< #\> #\. #\/ #\?)) + +(dolist (char default-lisp-wordchars) + (shadow-attribute :completion-wordchar char 1 "Lisp")) + +(shadow-attribute :completion-wordchar #\' 0 "Lisp") + +(defmacro completion-char-p (char) + `(= (the fixnum (character-attribute :completion-wordchar ,char)) 1)) + +;;; COMPLETION-BUCKET-FOR returns the Completion-Bucket that might hold a +;;; completion for the given String. With optional Value, sets the bucket. +;;; +(defun completion-bucket-for (string length &optional (value nil value-p)) + (declare (simple-string string) + (fixnum length)) + (when (and (>= length 3) + (completion-char-p (char string 0)) + (completion-char-p (char string 1)) + (completion-char-p (char string 2))) + (let ((index (mod (logxor (ash + (logxor + (ash (hi::search-hash-code (schar string 0)) + 5) + (hi::search-hash-code (schar string 1))) + 3) + (hi::search-hash-code (schar string 2))) + completion-table-size))) + (declare (fixnum index)) + (if value-p + (setf (svref *completions* index) value) + (svref *completions* index))))) + +(defsetf completion-bucket-for completion-bucket-for) + + +;;; FIND-COMPLETION returns the most recent string matching the given +;;; Prefix, or Nil if nothing appropriate is in the database. We assume +;;; the Prefix is passed to us in lowercase form so we can use String=. If +;;; we find something appropriate, we bring it to the front of the list. +;;; Prefix-Length, if supplied restricts us to look at just the start of +;;; the string... +;;; +(defun find-completion (prefix &optional (prefix-length (length prefix))) + (declare (simple-string prefix) + (fixnum prefix-length)) + (let ((bucket (completion-bucket-for prefix prefix-length))) + (do ((list bucket (cdr list))) + ((null list)) + (let ((completion (car list))) + (declare (simple-string completion)) + (when (and (>= (length completion) prefix-length) + (string= prefix completion + :end1 prefix-length + :end2 prefix-length)) + (unless (eq list bucket) + (rotatef (car list) (car bucket))) + (return completion)))))) + +;;; RECORD-COMPLETION saves string in the completion database as the first item +;;; in the bucket, that's the most recently used completion. If the bucket is +;;; full, drop the oldest item in the list. If string is already in the +;;; bucket, simply move it to the front. The way we move an element to the +;;; front requires a full bucket to be at least three elements long. +;;; +(defun record-completion (string) + (declare (simple-string string)) + (let ((string-length (length string))) + (declare (fixnum string-length)) + (when (> string-length 3) + (let ((bucket (completion-bucket-for string string-length)) + (limit (value completion-bucket-size))) + (do ((list bucket (cdr list)) + (last nil list) + (length 1 (1+ length))) + ((null list) + (setf (completion-bucket-for string string-length) + (cons string bucket))) + (cond ((= length limit) + (setf (car list) string) + (setf (completion-bucket-for string string-length) list) + (setf (cdr list) bucket) + (setf (cdr last) nil) + (return)) + ((string= string (the simple-string (car list))) + (unless (eq list bucket) + (rotatef (car list) (car bucket))) + (return)))))))) + +;;; ROTATE-COMPLETIONS rotates the completion bucket for the given Prefix. +;;; We just search for the first thing in the bucket with the Prefix, then +;;; move that to the end of the list. If there ain't no such thing there, +;;; or if it's already at the end, we do nothing. +;;; +(defun rotate-completions (prefix &optional (prefix-length (length prefix))) + (declare (simple-string prefix)) + (let ((bucket (completion-bucket-for prefix prefix-length))) + (do ((list bucket (cdr list)) + (prev nil list)) + ((null list)) + (let ((completion (car list))) + (declare (simple-string completion)) + (when (and (>= (length completion) prefix-length) + (string= prefix completion + :end1 prefix-length :end2 prefix-length)) + (when (cdr list) + (if prev + (setf (cdr prev) (cdr list)) + (setf (completion-bucket-for prefix prefix-length) (cdr list))) + (setf (cdr (last list)) list) + (setf (cdr list) nil)) + (return nil)))))) + + + + +;;;; Hemlock interface. + +(defmode "Completion" :transparent-p t :precedence 10.0 + :documentation + "This is a minor mode that saves words greater than three characters in length, + allowing later completion of those words. This is very useful for often + long identifiers used in Lisp code. All words with the same first three + letters are in one list sorted by most recently used. \"Completion Bucket + Size\" limits the number of completions saved in each list.") + +(defcommand "Completion Mode" (p) + "Toggles Completion Mode in the current buffer." + "Toggles Completion Mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Completion") + (not (buffer-minor-mode (current-buffer) "Completion")))) + + +;;; Consecutive alphanumeric keystrokes that start a word cause a possible +;;; completion to be displayed in the echo area's modeline, the status line. +;;; Since most insertion is building up a word that was already started, we +;;; keep track of the word in *completion-prefix* that the user is typing. The +;;; length of the thing is kept in *completion-prefix-length*. +;;; +(defconstant completion-prefix-max-size 100) + +(defvar *completion-prefix* (make-string completion-prefix-max-size)) + +(defvar *completion-prefix-length* 0) + + +;;; "Completion Self Insert" does different stuff depending on whether or +;;; not the thing to be inserted is Completion-Char-P. If it is, then we +;;; try to come up with a possible completion, using Last-Command-Type to +;;; tense things up a bit. Otherwise, if Last-Command-Type says we were +;;; just doing a word, then we record that word in the database. +;;; +(defcommand "Completion Self Insert" (p) + "Insert the last character typed, showing possible completions. With prefix + argument insert the character that many times." + "Implements \"Completion Self Insert\". Calling this function is not + meaningful." + (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))) + (unless char (editor-error "Can't insert that character.")) + (cond ((completion-char-p char) + ;; If start of word not already in *completion-prefix*, put it + ;; there. + (unless (eq (last-command-type) :completion-self-insert) + (set-completion-prefix)) + ;; Then add new stuff. + (cond ((and p (> p 1)) + (fill *completion-prefix* (char-downcase char) + :start *completion-prefix-length* + :end (+ *completion-prefix-length* p)) + (incf *completion-prefix-length* p)) + (t + (setf (schar *completion-prefix* *completion-prefix-length*) + (char-downcase char)) + (incf *completion-prefix-length*))) + ;; Display possible completion, if any. + (display-possible-completion *completion-prefix* + *completion-prefix-length*) + (setf (last-command-type) :completion-self-insert)) + (t + (when (eq (last-command-type) :completion-self-insert) + (record-completion (subseq *completion-prefix* + 0 *completion-prefix-length*))))))) + +;;; SET-COMPLETION-PREFIX grabs any completion-wordchars immediately before +;;; point and stores these into *completion-prefix*. +;;; +(defun set-completion-prefix () + (let* ((point (current-point)) + (point-line (mark-line point))) + (cond ((and (previous-character point) + (completion-char-p (previous-character point))) + (with-mark ((mark point)) + (reverse-find-attribute mark :completion-wordchar #'zerop) + (unless (eq (mark-line mark) point-line) + (editor-error "No completion wordchars on this line!")) + (let ((insert-string (nstring-downcase + (region-to-string + (region mark point))))) + (replace *completion-prefix* insert-string) + (setq *completion-prefix-length* (length insert-string))))) + (t + (setq *completion-prefix-length* 0))))) + + +(defcommand "Completion Complete Word" (p) + "Complete the word if we've got a completion, fixing up the case. Invoking + this immediately in succession rotates through possible completions in the + buffer. If there is no currently displayed completion, this tries to choose + a completion from text immediately before the point and displays the + completion if found." + "Complete the word if we've got a completion, fixing up the case." + (declare (ignore p)) + (let ((last-command-type (last-command-type))) + ;; If the user has been cursoring around and then tries to complete, + ;; let him. + ;; + (unless (member last-command-type '(:completion-self-insert :completion)) + (set-completion-prefix) + (setf last-command-type :completion-self-insert)) + (case last-command-type + (:completion-self-insert + (do-completion)) + (:completion + (rotate-completions *completion-prefix* *completion-prefix-length*) + (do-completion)))) + (setf (last-command-type) :completion)) + +(defcommand "List Possible Completions" (p) + "List all possible completions of the prefix the user has typed." + "List all possible completions of the prefix the user has typed." + (declare (ignore p)) + (let ((last-command-type (last-command-type))) + (unless (member last-command-type '(:completion-self-insert :completion)) + (set-completion-prefix)) + (let* ((prefix *completion-prefix*) + (prefix-length *completion-prefix-length*) + (bucket (completion-bucket-for prefix prefix-length))) + (with-pop-up-display (s) + (dolist (completion bucket) + (when (and (> (length completion) prefix-length) + (string= completion prefix + :end1 prefix-length + :end2 prefix-length)) + (write-line completion s)))))) + ;; Keep the redisplay hook from clearing any possibly displayed completion. + (setf (last-command-type) :completion-self-insert)) + +(defvar *last-completion-mark* nil) + +(defun do-completion () + (let ((completion (find-completion *completion-prefix* + *completion-prefix-length*)) + (point (current-point))) + (when completion + (if *last-completion-mark* + (move-mark *last-completion-mark* point) + (setq *last-completion-mark* (copy-mark point :temporary))) + (let ((mark *last-completion-mark*)) + (reverse-find-attribute mark :completion-wordchar #'zerop) + (let* ((region (region mark point)) + (string (region-to-string region))) + (declare (simple-string string)) + (delete-region region) + (let* ((first (position-if #'alpha-char-p string)) + (next (if first (position-if #'alpha-char-p string + :start (1+ first))))) + ;; Often completions start with asterisks when hacking on Lisp + ;; code, so we look for alphabetic characters. + (insert-string point + ;; Leave the cascading IF's alone. + ;; Writing this as a COND, using LOWER-CASE-P as + ;; the test is not equivalent to this code since + ;; numbers (and such) are nil for LOWER-CASE-P and + ;; UPPER-CASE-P. + (if (and first (upper-case-p (schar string first))) + (if (and next + (upper-case-p (schar string next))) + (string-upcase completion) + (word-capitalize completion)) + completion)))))))) + + +;;; WORD-CAPITALIZE is like STRING-CAPITALIZE except that it treats apostrophes +;;; the Right Way. +;;; +(defun word-capitalize (string) + (let* ((length (length string)) + (strung (make-string length))) + (do ((i 0 (1+ i)) + (new-word t)) + ((= i length)) + (let ((char (schar string i))) + (cond ((or (alphanumericp char) + (char= char #\')) + (setf (schar strung i) + (if new-word (char-upcase char) (char-downcase char))) + (setq new-word nil)) + (t + (setf (schar strung i) char) + (setq new-word t))))) + strung)) + +(defcommand "Completion Rotate Completions" (p) + "Show another possible completion in the status line, if there is one. + If there is no currently displayed completion, this tries to choose a + completion from text immediately before the point and displays the + completion if found. With an argument, rotate the completion ring that many + times." + "Show another possible completion in the status line, if there is one. + With an argument, rotate the completion ring that many times." + (unless (eq (last-command-type) :completion-self-insert) + (set-completion-prefix) + (setf (last-command-type) :completion-self-insert)) + (dotimes (i (or p 1)) + (rotate-completions *completion-prefix* *completion-prefix-length*)) + (display-possible-completion *completion-prefix* *completion-prefix-length*) + (setf (last-command-type) :completion-self-insert)) + + + +;;;; Nifty database and parsing machanisms. + +(defhvar "Completion Database Filename" + "The file that \"Save Completions\" and \"Read Completions\" will + respectively write and read the completion database to and from." + :value nil) + +(defvar *completion-default-default-database-filename* + "hemlock-completions.txt" + "The file that will be defaultly written to and read from by \"Save + Completions\" and \"Read Completions\".") + +(defcommand "Save Completions" (p) + "Writes the current completion database to a file, defaultly the value of + \"Completion Database Filename\". With an argument, prompts for a + filename." + "Writes the current completion database to a file, defaultly the value of + \"Completion Database Filename\". With an argument, prompts for a + filename." + (let ((filename (or (and (not p) (value completion-database-filename)) + (prompt-for-file + :must-exist nil + :default *completion-default-default-database-filename* + :prompt "File to write completions to: ")))) + (with-open-file (s filename + :direction :output + :if-exists :rename-and-delete + :if-does-not-exist :create) + (message "Saving completions...") + (dotimes (i (length *completions*)) + (let ((bucket (svref *completions* i))) + (when bucket + (write i :stream s :base 10 :radix 10) + (write-char #\newline s) + (dolist (completion bucket) + (write-line completion s)) + (terpri s)))) + (message "Done.")))) + +(defcommand "Read Completions" (p) + "Reads some completions from a file, defaultly the value of \"Completion + Database File\". With an argument, prompts for a filename." + "Reads some completions from a file, defaultly the value of \"Completion + Database File\". With an argument, prompts for a filename." + (let ((filename (or (and (not p) (value completion-database-filename)) + (prompt-for-file + :must-exist nil + :default *completion-default-default-database-filename* + :prompt "File to read completions from: "))) + (index nil) + (completion nil)) + (with-open-file (s filename :if-does-not-exist :error) + (message "Reading in completions...") + (loop + (let ((new-completions '())) + (unless (setf index (read-preserving-whitespace s nil nil)) + (return)) + ;; Zip past the newline that I know is directly after the number. + ;; All this to avoid consing. I love it. + (read-char s) + (loop + (setf completion (read-line s)) + (when (string= completion "") (return)) + (unless (member completion (svref *completions* index)) + (push completion new-completions))) + (let ((new-bucket (nconc (nreverse new-completions) + (svref *completions* index)))) + (setf (svref *completions* index) new-bucket) + (do ((completion new-bucket (cdr completion)) + (end (1- (value completion-bucket-size))) + (i 0 (1+ i))) + ((endp completion)) + (when (= i end) (setf (cdr completion) nil)))))) + (message "Done.")))) + +(defcommand "Parse Buffer for Completions" (p) + "Zips over a buffer slamming everything that is a valid completion word + into the completion hashtable." + "Zips over a buffer slamming everything that is a valid completion word + into the completion hashtable." + (declare (ignore p)) + (let ((buffer (prompt-for-buffer :prompt "Buffer to parse: " + :must-exist t + :default (current-buffer) + :default-string (buffer-name + (current-buffer))))) + (with-mark ((word-start (buffer-start-mark buffer) :right-inserting) + (word-end (buffer-start-mark buffer) :left-inserting) + (buffer-end-mark (buffer-start-mark buffer))) + (message "Starting parse of ~S..." (buffer-name buffer)) + (loop + (unless (find-attribute word-start :completion-wordchar) (return)) + (record-completion + (region-to-string (region word-start + (or (find-attribute + (move-mark word-end word-start) + :completion-wordchar #'zerop) + buffer-end-mark)))) + (move-mark word-start word-end)) + (message "Done.")))) + + + + +;;;; Modeline hackery: + +(defvar *completion-mode-possibility* "") + +(defvar *completion-modeline-field* (modeline-field :completion)) + +(defun display-possible-completion (prefix + &optional (prefix-length (length prefix))) + (let ((old *completion-mode-possibility*)) + (setq *completion-mode-possibility* + (or (find-completion prefix prefix-length) "")) + (unless (eq old *completion-mode-possibility*) + (update-modeline-field *echo-area-buffer* *echo-area-window* + *completion-modeline-field*)))) + +(defun clear-completion-display () + (unless (= (length (the simple-string *completion-mode-possibility*)) 0) + (setq *completion-mode-possibility* "") + (update-modeline-field *echo-area-buffer* *echo-area-window* + *completion-modeline-field*))) + + +;;; COMPLETION-REDISPLAY-FUN erases any completion displayed in the status line. +;;; +(defun completion-redisplay-fun (window) + (declare (ignore window)) + (unless (eq (last-command-type) :completion-self-insert) + (clear-completion-display))) +;;; +(add-hook redisplay-hook #'completion-redisplay-fun) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/cursor.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/cursor.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/cursor.lisp (revision 8058) @@ -0,0 +1,362 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; Cursor: Routines for cursor positioning and recentering +;;; +(in-package :hemlock-internals) + + + +;;;; Mark-To-Cursorpos +;;; +;;; Since performance analysis showed that HALF of the time in the editor +;;; was being spent in this function, I threw all of the tricks in the +;;; book at it to try and make it tenser. +;;; +;;; The algorithm is roughly as follows: +;;; +;;; 1) Eliminate the annoying boundry condition of the mark being +;;; off the end of the window, if it is return NIL now. +;;; 2) If the charpos is on or immediately after the last character +;;; in the line, then find the last dis-line on which the line is +;;; displayed. We know that the mark is at the end of this dis-line +;;; because it is known to be on the screen. X position is trivially +;;; derived from the dis-line-length. +;;; 3) Call Real-Line-Length or Cached-Real-Line-Length to get the +;;; X position and number of times wrapped. + +(declaim (special *the-sentinel*)) + +(eval-when (:compile-toplevel :execute) +;;; find-line +;;; +;;; Find a dis-line which line is displayed on which starts before +;;; charpos, setting ypos and dis-line to the dis-line and it's index. +;;; Offset is expected to be the mark-charpos of the display-start for +;;; the window initially, and is set to offset within line that +;;; Dis-Line begins. Charpos is the mark-charpos of the mark we want +;;; to find. Check if same as *redisplay-favorite-line* and then scan +;;; if not. +;;; +(defmacro find-line (line offset charpos ypos dis-lines dis-line) + (declare (ignore charpos)) + `(cond + ;; No lines at all, fail. + ((eq ,dis-lines *the-sentinel*) nil) + ;; On the first line, offset is already set, so just set dis-line and + ;; ypos and fall through. + ((eq (dis-line-line (car ,dis-lines)) ,line) + (setq ,dis-line ,dis-lines ,ypos 0)) + ;; Look farther down. + ((do ((l (cdr ,dis-lines) (cdr l))) + ((eq l *the-sentinel*)) + (when (eq (dis-line-line (car l)) ,line) + (setq ,dis-line l ,ypos (dis-line-position (car l)) ,offset 0) + (return t)))) + (t + (error "Horrible flaming lossage, Sorry Man.")))) + + +;;; find-last +;;; +;;; Find the last dis-line on which line is displayed, set ypos and +;;; dis-line. +;;; +(defmacro find-last (line ypos dis-line) + `(do ((trail ,dis-line dl) + (dl (cdr ,dis-line) (cdr dl))) + ((not (eq (dis-line-line (car dl)) ,line)) + (setq ,dis-line (car trail) ,ypos (dis-line-position ,dis-line))))) + +;;; find-charpos +;;; +;;; Special-Case mark at end of line, if not punt out to real-line-length +;;; function. Return the correct values. +;;; +(defmacro find-charpos (line offset charpos length ypos dis-line width + fun chars) + (declare (ignore chars)) + `(cond + ((= ,charpos ,length) + (find-last ,line ,ypos ,dis-line) + (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos)) + ((= ,charpos (1- ,length)) + (multiple-value-bind (x dy) + (,fun ,line (1- ,width) ,offset ,charpos) + (if (and (not (zerop dy)) (zerop x)) + (values (1- ,width) (1- (+ ,ypos dy))) + (values x (+ ,ypos dy))))) + (t + (multiple-value-bind (x dy) + (,fun ,line (1- ,width) ,offset ,charpos) + (values x (+ ,ypos dy)))))) + +); eval-when + + +;;; real-line-length +;;; +;;; Return as values the X position and the number of times wrapped if +;;; one to display the characters from Start to End of Line starting at an +;;; X position of 0 wrapping Width wide. +;;; %SP-Find-Character-With-Attribute is used to find charaters +;;; with funny representation much as in Compute-Line-Image. +;;; +(defun real-line-length (line width start end) + (declare (fixnum width start end)) + (do ((xpos 0) + (ypos 0) + (chars (line-chars line)) + (losing 0) + (dy 0)) + ((= start end) (values xpos ypos)) + (declare (fixnum xpos ypos dy) (simple-string chars) + (type (or fixnum null) losing)) + (setq losing (%fcwa chars start end losing-char)) + (when (null losing) + (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width)) + (return (values xpos (+ ypos dy)))) + (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width)) + (setq ypos (+ ypos dy) start losing) + (do ((last (or (%fcwa chars start end winning-char) end)) str) + ((= start last)) + (declare (fixnum last)) + (setq str (get-rep (schar chars start))) + (incf start) + (unless (simple-string-p str) (setq str (funcall str xpos))) + (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width)) + (setq ypos (+ ypos dy))))) + +;;; cached-real-line-length +;;; +;;; The same as Real-Line-Length, except does it for the cached line. +;;; the line argument is ignored, but present to make the arglists the +;;; same. +;;; +(defun cached-real-line-length (line width start end) + (declare (fixnum width start end) (ignore line)) + (let ((offset (- (current-right-open-pos) (current-left-open-pos))) + (bound 0)) + (declare (fixnum offset bound)) + (cond + ((>= start (current-left-open-pos)) + (setq start (+ start offset) bound (setq end (+ end offset)))) + ((> end (current-left-open-pos)) + (setq bound (current-left-open-pos) end (+ end offset))) + (t + (setq bound end))) + + (do ((xpos 0) + (ypos 0) + (losing 0) + (dy 0)) + (()) + (declare (fixnum xpos ypos dy) + (type (or fixnum null) losing)) + (when (= start bound) + (when (= start end) (return (values xpos ypos))) + (setq start (current-right-open-pos) bound end)) + (setq losing (%fcwa (current-open-chars) start bound losing-char)) + (cond + (losing + (multiple-value-setq (dy xpos) + (truncate (+ xpos (- losing start)) width)) + (setq ypos (+ ypos dy) start losing) + (do ((last (or (%fcwa (current-open-chars) start bound winning-char) bound)) str) + ((= start last)) + (declare (fixnum last)) + (setq str (get-rep (schar (current-open-chars) start))) + (incf start) + (unless (simple-string-p str) (setq str (funcall str xpos))) + (multiple-value-setq (dy xpos) + (truncate (+ xpos (strlen str)) width)) + (setq ypos (+ ypos dy)))) + (t + (multiple-value-setq (dy xpos) + (truncate (+ xpos (- bound start)) width)) + (setq ypos (+ ypos dy) start bound)))))) + + + +;;; Dis-Line-Offset-Guess -- Internal +;;; +;;; Move Mark by Offset display lines. The mark is assumed to be at the +;;; beginning of a display line, and we attempt to leave it at one. We assume +;;; all characters print one wide. Width is the width of the window we are +;;; displaying in. +;;; +(defun dis-line-offset-guess (mark offset width) + (let ((w (1- width))) + (if (minusp offset) + (dotimes (i (- offset) t) + (let ((pos (mark-charpos mark))) + (if (>= pos w) + (character-offset mark (- w)) + (let ((prev (line-previous (mark-line mark)))) + (unless prev (return nil)) + (multiple-value-bind + (lines chars) + (truncate (line-length prev) w) + (move-to-position mark + (cond ((zerop lines) 0) + ((< chars 2) + (* w (1- lines))) + (t + (* w lines))) + prev)))))) + (dotimes (i offset t) + (let ((left (- (line-length (mark-line mark)) + (mark-charpos mark)))) + (if (> left width) + (character-offset mark w) + (unless (line-offset mark 1 0) + (return nil)))))))) + +;;; maybe-recenter-window -- Internal +;;; +;;; Update the dis-lines for Window and recenter if the point is off +;;; the screen. +;;; +(defun maybe-recenter-window (window) + (unless (%displayed-p (buffer-point (window-buffer window)) window) + (center-window window (buffer-point (window-buffer window))) + t)) + +;;; center-window -- Public +;;; +;;; Try to move the start of window so that Mark is on a line in the +;;; center. +;;; +(defun center-window (window mark) + "Adjust the start of Window so that Mark is displayed on the center line." + (let ((height (window-height window)) + (start (window-display-start window))) + (move-mark start mark) + (unless (dis-line-offset-guess start (- (truncate height 2)) + (window-width window)) + (move-mark start (buffer-start-mark (window-buffer window)))) + (update-window-image window) + ;; If that doesn't work, panic and make the start the point. + (unless (%displayed-p mark window) + (move-mark start mark) + (update-window-image window)))) + + +;;; %Displayed-P -- Internal +;;; +;;; If Mark is within the displayed bounds in Window, then return true, +;;; otherwise false. We assume the window image is up to date. +;;; +(defun %displayed-p (mark window) + (let ((start (window-display-start window)) + (end (window-display-end window))) + (not (or (mark< mark start) (mark> mark end) + (if (mark= mark end) + (let ((ch (next-character end))) + (and ch (char/= ch #\newline))) + nil))))) + + +;;; Displayed-p -- Public +;;; +;;; Update the window image and then check if the mark is displayed. +;;; +(defun displayed-p (mark window) + "Return true if Mark is displayed on Window, false otherwise." + (maybe-update-window-image window) + (%displayed-p mark window)) + + +;;; scroll-window -- Public +;;; +;;; This is not really right, since it uses dis-line-offset-guess. +;;; Probably if there is any screen overlap then we figure it out +;;; exactly. +;;; + + + +;;; Mark-Column -- Public +;;; +;;; Find the X position of a mark supposing that it were displayed +;;; in an infinitely wide screen. +;;; +(defun mark-column (mark) + "Find the X position at which Mark would be displayed if it were on + an infinitely wide screen. This takes into account tabs and control + characters." + (let ((charpos (mark-charpos mark)) + (line (mark-line mark))) + (if (current-open-line-p line) + (values (cached-real-line-length line 10000 0 charpos)) + (values (real-line-length line 10000 0 charpos))))) + + +;;; Find-Position -- Internal +;;; +;;; Return the charpos which corresponds to the specified X position +;;; within Line. If there is no such position between Start and End then +;;; rutne NIL. +;;; +(defun find-position (line position start end width) + (do* ((cached (current-open-line-p line)) + (lo start) + (hi (1- end)) + (probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2))) + ((> lo hi) + (if (= lo end) nil hi)) + (let ((val (if cached + (cached-real-line-length line width start probe) + (real-line-length line width start probe)))) + (cond ((= val position) (return probe)) + ((< val position) (setq lo (1+ probe))) + (t (setq hi (1- probe))))))) + +;;; Cursorpos-To-Mark -- Public +;;; +;;; Find the right dis-line, then zero in on the correct position +;;; using real-line-length. +;;; +(defun cursorpos-to-mark (x y window) + (check-type window window) + (let ((width (window-width window)) + (first (window-first-line window))) + (when (>= x width) + (return-from cursorpos-to-mark nil)) + (do* ((prev first dl) + (dl (cdr first) (cdr dl)) + (ppos (mark-charpos (window-display-start window)) + (if (eq (dis-line-line (car dl)) (dis-line-line (car prev))) + (dis-line-end (car prev)) 0))) + ((eq dl *the-sentinel*) + (copy-mark (window-display-end window) :temporary)) + (when (= (dis-line-position (car dl)) y) + (let* ((line (dis-line-line (car dl))) + (end (dis-line-end (car dl)))) + (return (mark line (or (find-position line x ppos end width) end)))))))) + +;;; Move-To-Column -- Public +;;; +;;; Just look up the charpos using find-position... +;;; +(defun move-to-column (mark column &optional (line (mark-line mark))) + "Move Mark to the specified Column on Line. This function is analogous + to Move-To-Position, but it deals with the physical screen position + as returned by Mark-Column; the mark is moved to before the character + which would be displayed in Column if the line were displayed on + an infinitely wide screen. If the column specified is greater than + the column of the last character, then Nil is returned and the mark + is not modified." + (let ((res (find-position line column 0 (line-length line) 10000))) + (if res + (move-to-position mark res line)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/decls.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/decls.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/decls.lisp (revision 8058) @@ -0,0 +1,67 @@ +(in-package :hemlock-internals) + +;;; Use #.*fast* for optimizations. + +(eval-when (compile eval load) + (defparameter *fast* + '(declare (optimize speed))) + + (defparameter *fast* + '(declare))) + + +;; Since the declaim form for functions looks clumsy and is +;; syntax-wise different from defun, we define us a new declfun, which +;; fixes this. + +(defmacro declfun (name lambda-list) + `(declaim (ftype (function + ,(let ((q lambda-list) + res) + (do () ((or (null q) + (member (car q) '(&optional &rest &key)))) + (push 't res) + (pop q)) + (when (eq (car q) '&optional) + (push '&optional res) + (pop q) + (do () ((or (null q) + (member (car q) '(&rest &key)))) + (push 't res))) + (when (eq (car q) '&rest) + (push '&rest res) + (pop q) + (push 't res) + (pop q)) + (when (eq (car q) '&key) + (push '&key res) + (pop q) + (do () ((or (null q) + (member (car q) '(&allow-other-keys)))) + (push (list (intern (string (if (consp (car q)) + (if (consp (caar q)) + (caaar q) + (caar q)) + (car q))) + :keyword) + 't) + res) + (pop q))) + (when (eq (car q) '&allow-other-keys) + (push '&allow-other-keys res) + (pop q)) + (reverse res)) + t) + ,name))) + +(declfun window-buffer (window)) +(declfun change-to-buffer (buffer)) ;filecoms.lisp + +(declfun hemlock::to-line-comment (mark start)) ;defined in comments.lisp used in lispbuf.lisp + +;;; Some special variables are forward-referenced, and we don't even +;;; need to invent a new language to advise the compiler of that ... +(declaim (special *mode-names* *current-buffer* *echo-area-buffer* + *the-sentinel* + *in-the-editor* *buffer-list* *things-to-do-once* + *gc-notify-before* *gc-notify-after*)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/defsyn.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/defsyn.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/defsyn.lisp (revision 8058) @@ -0,0 +1,162 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains definitions of various character attributes. +;;; +(in-package :hemlock) + +(defattribute "Whitespace" + "A value of 1 for this attribute indicates that the corresponding character + should be considered as whitespace. This is used by the Blank-Line-P + function.") + +(setf (character-attribute :whitespace #\space) 1) +(setf (character-attribute :whitespace #\linefeed) 1) +(setf (character-attribute :whitespace #\tab) 1) +(setf (character-attribute :whitespace #\newline) 1) + +(defattribute "Word Delimiter" + "A value of 1 for this attribute indicates that the corresponding character + separates words. This is used by the word manipulating commands.") + +(setf (character-attribute :word-delimiter nil) 1) +(setf (character-attribute :word-delimiter #\!) 1) +(setf (character-attribute :word-delimiter #\@) 1) +(setf (character-attribute :word-delimiter #\#) 1) +(setf (character-attribute :word-delimiter #\$) 1) +(setf (character-attribute :word-delimiter #\%) 1) +(setf (character-attribute :word-delimiter #\^) 1) +(setf (character-attribute :word-delimiter #\&) 1) +(setf (character-attribute :word-delimiter #\*) 1) +(setf (character-attribute :word-delimiter #\() 1) +(setf (character-attribute :word-delimiter #\)) 1) +(setf (character-attribute :word-delimiter #\-) 1) +(setf (character-attribute :word-delimiter #\_) 1) +(setf (character-attribute :word-delimiter #\=) 1) +(setf (character-attribute :word-delimiter #\+) 1) +(setf (character-attribute :word-delimiter #\[) 1) +(setf (character-attribute :word-delimiter #\]) 1) +(setf (character-attribute :word-delimiter #\\) 1) +(setf (character-attribute :word-delimiter #\|) 1) +(setf (character-attribute :word-delimiter #\;) 1) +(setf (character-attribute :word-delimiter #\:) 1) +(setf (character-attribute :word-delimiter #\') 1) +(setf (character-attribute :word-delimiter #\") 1) +(setf (character-attribute :word-delimiter #\{) 1) +(setf (character-attribute :word-delimiter #\}) 1) +(setf (character-attribute :word-delimiter #\,) 1) +(setf (character-attribute :word-delimiter #\.) 1) +(setf (character-attribute :word-delimiter #\<) 1) +(setf (character-attribute :word-delimiter #\>) 1) +(setf (character-attribute :word-delimiter #\/) 1) +(setf (character-attribute :word-delimiter #\?) 1) +(setf (character-attribute :word-delimiter #\`) 1) +(setf (character-attribute :word-delimiter #\~) 1) +(setf (character-attribute :word-delimiter #\space) 1) +(setf (character-attribute :word-delimiter #\linefeed) 1) +(setf (character-attribute :word-delimiter + #+CMU #\formfeed + #+(or EXCL sbcl CLISP OpenMCL) #\page) 1) +(setf (character-attribute :word-delimiter #\tab) 1) +(setf (character-attribute :word-delimiter #\newline) 1) + +(shadow-attribute :word-delimiter #\. 0 "Fundamental") +(shadow-attribute :word-delimiter #\' 0 "Text") +(shadow-attribute :word-delimiter #\backspace 0 "Text") +(shadow-attribute :word-delimiter #\_ 0 "Text") + + +(defattribute "Page Delimiter" + "This attribute is 1 for characters that separate pages, 0 otherwise.") +(setf (character-attribute :page-delimiter nil) 1) +(setf (character-attribute :page-delimiter #\page) 1) + + + +(defattribute "Lisp Syntax" + "These character attribute is used by the lisp mode commands, and possibly + other people. The value of ths attribute is always a symbol. Currently + defined values are: + NIL - No interesting properties. + :space - Acts like whitespace, should not include newline. + :newline - Newline, man. + :open-paren - An opening bracket. + :close-paren - A closing bracket. + :prefix - A character that is a part of any form it appears before. + :string-quote - The character that quotes a string. + :char-quote - The character that escapes a single character. + :comment - The character that comments out to end of line. + :constituent - Things that make up symbols." + 'symbol nil) + +(setf (character-attribute :lisp-syntax #\space) :space) +(setf (character-attribute :lisp-syntax #\tab) :space) + +(setf (character-attribute :lisp-syntax #\() :open-paren) +(setf (character-attribute :lisp-syntax #\)) :close-paren) +(setf (character-attribute :lisp-syntax #\') :prefix) +(setf (character-attribute :lisp-syntax #\`) :prefix) +(setf (character-attribute :lisp-syntax #\#) :prefix) +(setf (character-attribute :lisp-syntax #\,) :prefix) +(setf (character-attribute :lisp-syntax #\") :string-quote) +(setf (character-attribute :lisp-syntax #\\) :char-quote) +(setf (character-attribute :lisp-syntax #\;) :comment) +(setf (character-attribute :lisp-syntax #\newline) :newline) +(setf (character-attribute :lisp-syntax nil) :newline) + +(do-alpha-chars (ch :both) + (setf (character-attribute :lisp-syntax ch) :constituent)) + +(setf (character-attribute :lisp-syntax #\0) :constituent) +(setf (character-attribute :lisp-syntax #\1) :constituent) +(setf (character-attribute :lisp-syntax #\2) :constituent) +(setf (character-attribute :lisp-syntax #\3) :constituent) +(setf (character-attribute :lisp-syntax #\4) :constituent) +(setf (character-attribute :lisp-syntax #\5) :constituent) +(setf (character-attribute :lisp-syntax #\6) :constituent) +(setf (character-attribute :lisp-syntax #\7) :constituent) +(setf (character-attribute :lisp-syntax #\8) :constituent) +(setf (character-attribute :lisp-syntax #\9) :constituent) + +(setf (character-attribute :lisp-syntax #\!) :constituent) +(setf (character-attribute :lisp-syntax #\{) :constituent) +(setf (character-attribute :lisp-syntax #\}) :constituent) +(setf (character-attribute :lisp-syntax #\[) :constituent) +(setf (character-attribute :lisp-syntax #\]) :constituent) +(setf (character-attribute :lisp-syntax #\/) :constituent) +(setf (character-attribute :lisp-syntax #\@) :constituent) +(setf (character-attribute :lisp-syntax #\-) :constituent) +(setf (character-attribute :lisp-syntax #\_) :constituent) +(setf (character-attribute :lisp-syntax #\+) :constituent) +(setf (character-attribute :lisp-syntax #\%) :constituent) +(setf (character-attribute :lisp-syntax #\*) :constituent) +(setf (character-attribute :lisp-syntax #\$) :constituent) +(setf (character-attribute :lisp-syntax #\^) :constituent) +(setf (character-attribute :lisp-syntax #\&) :constituent) +(setf (character-attribute :lisp-syntax #\~) :constituent) +(setf (character-attribute :lisp-syntax #\=) :constituent) +(setf (character-attribute :lisp-syntax #\<) :constituent) +(setf (character-attribute :lisp-syntax #\>) :constituent) +(setf (character-attribute :lisp-syntax #\?) :constituent) +(setf (character-attribute :lisp-syntax #\.) :constituent) +(setf (character-attribute :lisp-syntax #\:) :constituent) + + +(defattribute "Sentence Terminator" + "Used for terminating sentences -- ., !, ?. + Possibly could make type (mod 3) and use the value of 2 and 1 for spaces + to place after chacter." + '(mod 2) + 0) + +(setf (character-attribute :sentence-terminator #\.) 1) +(setf (character-attribute :sentence-terminator #\!) 1) +(setf (character-attribute :sentence-terminator #\?) 1) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/doccoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/doccoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/doccoms.lisp (revision 8058) @@ -0,0 +1,394 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock Documentation and Help commands. +;;; Written by Rob MacLachlan and Bill Chiles. +;;; + +(in-package :hemlock) + + + + +;;;; Help. + +(defcommand "Help" (p) + "Give helpful information. + This command dispatches to a number of other documentation commands, + on the basis of a character command." + "Prompt for a single character command to dispatch to another helping + function." + (declare (ignore p)) + (command-case (:prompt "Doc (Help for Help): " + :help "Type a Help option to say what kind of help you want:") + (#\a "List all commands, variables and attributes Apropos a keyword." + (apropos-command nil)) + (#\d "Describe a command, given its name." + (describe-command-command nil)) + (#\g "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)." + (generic-describe-command nil)) + (#\v "Describe variable and show its values." + (describe-and-show-variable-command nil)) + (#\c "Describe the command bound to a Character." + (describe-key-command nil)) + (#\l "List the last 60 characters typed." + (what-lossage-command nil)) + (#\m "Describe a mode." + (describe-mode-command nil)) + (#\p "Describe commands with mouse/pointer bindings." + (describe-pointer-command nil)) + (#\w "Find out Where a command is bound." + (where-is-command nil)) + (#\t "Describe a Lisp object." + (editor-describe-command nil)) + ((#\q :no) "Quits, You don't really want help."))) + +(defcommand "Where Is" (p) + "Find what key a command is bound to. + Prompts for the command to look for, and says what environment it is + available in." + "List places where a command is bound." + (declare (ignore p)) + (multiple-value-bind (nam cmd) + (prompt-for-keyword (list *command-names*) + :prompt "Command: " + :help "Name of command to look for.") + (let ((bindings (command-bindings cmd))) + (with-pop-up-display (s :title (format nil "Bindings of ~s" nam)) + (cond + ((null bindings) + (format s "~S may only be invoked as an extended command.~%" nam)) + (t + (format s "~S may be invoked in the following ways:~%" nam) + (print-command-bindings bindings s))))))) + + + + +;;;; Apropos. + +(defcommand "Apropos" (p) + "List things whose names contain a keyword." + "List things whose names contain a keyword." + (declare (ignore p)) + (let* ((str (prompt-for-string + :prompt "Apropos keyword: " + :help + "String to look for in command, variable and attribute names.")) + (coms (find-containing str *command-names*)) + (vars (mapcar #'(lambda (table) + (let ((res (find-containing str table))) + (if res (cons table res)))) + (current-variable-tables))) + (attr (find-containing str *character-attribute-names*))) + (if (or coms vars attr) + (apropos-command-output str coms vars attr) + (message "No command, attribute or variable name contains ~S." str)))) + +(defun apropos-command-output (str coms vars attr) + (declare (list coms vars attr)) + (with-pop-up-display (s :title "Apropos Output") + (when coms + (format s "Commands with ~S in their names:~%" str) + (dolist (com coms) + (let ((obj (getstring com *command-names*))) + (write-string com s) + (write-string " " s) + (print-command-bindings (command-bindings obj) s) + (terpri s) + (print-doc (command-documentation obj) s)))) + (when vars + (when coms (terpri s)) + (format s "Variables with ~S in their names:~%" str) + (dolist (stuff vars) + (let ((table (car stuff))) + (dolist (var (cdr stuff)) + (let ((obj (getstring var table))) + (write-string var s) + (write-string " " s) + (let ((*print-level* 2) (*print-length* 3)) + (prin1 (variable-value obj) s)) + (terpri s) + (print-doc (variable-documentation obj) s)))))) + (when attr + (when (or coms vars) (terpri s)) + (format s "Attributes with ~S in their names:~%" str) + (dolist (att attr) + (let ((obj (getstring att *character-attribute-names*))) + (write-line att s) + (print-doc (character-attribute-documentation obj) s)))))) + +;;; PRINT-DOC takes doc, a function or string, and gets it out on stream. + +(defun print-doc (doc stream) + (let ((str (typecase doc + (function (funcall doc :short)) + (simple-string doc) + (t + (error "Bad documentation: ~S" doc))))) + (write-string " " stream) + (write-line str stream))) + + + + +;;;; Describe command, key, pointer. + +(defcommand "Describe Command" (p) + "Describe a command. + Prompts for a command and then prints out it's full documentation." + "Print out the command documentation for a command which is prompted for." + (declare (ignore p)) + (multiple-value-bind (nam com) + (prompt-for-keyword + (list *command-names*) + :prompt "Describe command: " + :help "Name of a command to document.") + (let ((bindings (command-bindings com))) + (with-pop-up-display (s :title (format nil "~s command documentation" nam)) + (format s "Documentation for ~S:~% ~A~%" + nam (command-documentation com)) + (cond ((not bindings) + (write-line + "This can only be invoked as an extended command." s)) + (t + (write-line + "This can be invoked in the following ways:" s) + (write-string " " s) + (print-command-bindings bindings s) + (terpri s))))))) + +(defcommand "Describe Key" (p) + "Prompt for a sequence of characters. When the first character is typed that + terminates a key binding in the current context, describe the command bound + to it. When the first character is typed that no longer allows a correct + key to be entered, tell the user that this sequence is not bound to + anything." + "Print out the command documentation for a key + which is prompted for." + (declare (ignore p)) + (let ((old-window (current-window))) + (unwind-protect + (progn + (setf (current-window) hi::*echo-area-window*) + (hi::display-prompt-nicely "Describe key: " nil) + (setf (fill-pointer hi::*prompt-key*) 0) + (loop + (let ((key-event (get-key-event hi::*editor-input*))) + (vector-push-extend key-event hi::*prompt-key*) + (let ((res (get-command hi::*prompt-key* :current))) + (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*) + (write-char #\space *echo-area-stream*) + (cond ((commandp res) + (with-pop-up-display (s :title "Key documentation") + (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s) + (format s " is bound to ~S.~%" (command-name res)) + (format s "Documentation for this command:~% ~A" + (command-documentation res))) + (return)) + ((not (eq res :prefix)) + (with-pop-up-display (s :height 1) + (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s) + (write-string " is not bound to anything." s)) + (return))))))) + (setf (current-window) old-window)))) + + + + +;;;; Generic describe variable, command, key, attribute. + +(defvar *generic-describe-kinds* + (list (make-string-table :initial-contents + '(("Variable" . :variable) + ("Command" . :command) + ("Key" . :key) + ("Attribute" . :attribute))))) + +(defcommand "Generic Describe" (p) + "Describe some Hemlock thing. + First prompt for the kind of thing, then prompt for the thing to describe. + Currently supported kinds of things are variables, commands, keys and + character attributes." + "Prompt for some Hemlock thing to describe." + (declare (ignore p)) + (multiple-value-bind (ignore kwd) + (prompt-for-keyword *generic-describe-kinds* + :default "Variable" + :help "Kind of thing to describe." + :prompt "Kind: ") + (declare (ignore ignore)) + (case kwd + (:variable + (describe-and-show-variable-command nil)) + (:command (describe-command-command ())) + (:key (describe-key-command ())) + (:attribute + (multiple-value-bind (name attr) + (prompt-for-keyword + (list *character-attribute-names*) + :help "Name of character attribute to describe." + :prompt "Attribute: ") + (print-full-doc name (character-attribute-documentation attr))))))) + +;;; PRINT-FULL-DOC displays whole documentation string in a pop-up window. +;;; Doc may be a function that takes at least one arg, :short or :full. +;;; +(defun print-full-doc (nam doc) + (typecase doc + (function (funcall doc :full)) + (simple-string + (with-pop-up-display (s :title (format nil "~s documentation" nam)) + (format s "Documentation for ~S:~% ~A" nam doc))) + (t (error "Bad documentation: ~S" doc)))) + + + + +;;;; Describing and show variables. + +(defcommand "Show Variable" (p) + "Display the values of a Hemlock variable." + "Display the values of a Hemlock variable." + (declare (ignore p)) + (multiple-value-bind (name var) + (prompt-for-variable + :help "Name of variable to describe." + :prompt "Variable: ") + (with-pop-up-display (s :title (format nil "~S Variable documentation" name)) + (show-variable s name var)))) + +(defcommand "Describe and Show Variable" (p) + "Describe in full and show all of variable's value. + Variable is prompted for." + "Describe in full and show all of variable's value." + (declare (ignore p)) + (multiple-value-bind (name var) + (prompt-for-variable + :help "Name of variable to describe." + :prompt "Variable: ") + (with-pop-up-display (s :title (format nil "~s" name)) + (format s "Documentation for ~S:~% ~A~&~%" + name (variable-documentation var)) + (show-variable s name var)))) + +(defun show-variable (s name var) + (when (hemlock-bound-p var :global) + (format s "Global value of ~S:~% ~S~%" + name (variable-value var :global))) + (let ((buffer (current-buffer))) + (when (hemlock-bound-p var :buffer (current-buffer)) + (format s "Value of ~S in buffer ~A:~% ~S~%" + name (buffer-name buffer) + (variable-value var :buffer buffer)))) + (do-strings (mode-name val *mode-names*) + (declare (ignore val)) + (when (hemlock-bound-p var :mode mode-name) + (format s "Value of ~S in ~S Mode:~% ~S~%" + name mode-name + (variable-value var :mode mode-name))))) + + + + +;;;; Describing modes. + +(defvar *describe-mode-ignore* (list "Illegal" "Do Nothing")) + +(defcommand "Describe Mode" (p &optional name) + "Describe a mode showing special bindings for that mode." + "Describe a mode showing special bindings for that mode." + (declare (ignore p)) + (let ((name (or name + (prompt-for-keyword (list *mode-names*) + :prompt "Mode: " + :help "Enter mode to describe." + :default + (car (buffer-modes (current-buffer))))))) + (with-pop-up-display (s :title (format nil "~A mode" name)) + (format s "~A mode description:~%" name) + (let ((doc (mode-documentation name))) + (when doc + (write-line doc s) + (terpri s))) + (map-bindings + #'(lambda (key cmd) + (unless (member (command-name cmd) + *describe-mode-ignore* + :test #'string-equal) + (let ((str (key-to-string key))) + (cond ((= (length str) 1) + (write-string str s) + (write-string " - " s)) + (t (write-line str s) + (write-string " - " s))) + (print-doc (command-documentation cmd) s)))) + :mode name)))) + +(defun key-to-string (key) + (with-output-to-string (s) + (hemlock-ext:print-pretty-key key s))) + + + + +;;;; Printing bindings and last N characters typed. + +(defcommand "What Lossage" (p) + "Display the last 60 characters typed." + "Display the last 60 characters typed." + (declare (ignore p)) + (with-pop-up-display (s :title (format nil "The last characters typed") :height 7) + (let ((num (ring-length *key-event-history*))) + (format s "The last ~D characters typed:~%" num) + (do ((i (1- num) (1- i))) + ((minusp i)) + (hemlock-ext:print-pretty-key-event (ring-ref *key-event-history* i) s) + (write-char #\space s))))) + +(defun print-command-bindings (bindings stream) + (let ((buffer ()) + (mode ()) + (global ())) + (dolist (b bindings) + (case (second b) + (:global (push (first b) global)) + (:mode + (let ((m (assoc (third b) mode :test #'string=))) + (if m + (push (first b) (cdr m)) + (push (list (third b) (first b)) mode)))) + (t + (let ((f (assoc (third b) buffer))) + (if f + (push (first b) (cdr f)) + (push (list (third b) (first b)) buffer)))))) + (when global + (print-some-keys global stream) + (write-string "; " stream)) + (dolist (b buffer) + (format stream "Buffer ~S: " (buffer-name (car b))) + (print-some-keys (cdr b) stream) + (write-string "; " stream)) + (dolist (m mode) + (write-string (car m) stream) + (write-string ": " stream) + (print-some-keys (cdr m) stream) + (write-string "; " stream)))) + +;;; PRINT-SOME-KEYS prints the list of keys onto Stream. +;;; +(defun print-some-keys (keys stream) + (do ((key keys (cdr key))) + ((null (cdr key)) + (hemlock-ext:print-pretty-key (car key) stream)) + (hemlock-ext:print-pretty-key (car key) stream) + (write-string ", " stream))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/echo.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/echo.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/echo.lisp (revision 8058) @@ -0,0 +1,767 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock Echo Area stuff. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; Modified by Bill Chiles. +;;; +(in-package :hemlock-internals) + +(defmode "Echo Area" :major-p t) +(defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area")) + "Buffer used to hack text for the echo area.") +(defvar *echo-area-region* (buffer-region *echo-area-buffer*) + "Internal thing that's the *echo-area-buffer*'s region.") +(defvar *echo-area-stream* + (make-hemlock-output-stream (region-end *echo-area-region*) :full) + "Buffered stream that prints into the echo area.") +(defvar *echo-area-window* () + "Window used to display stuff in the echo area.") +(defvar *parse-starting-mark* + (copy-mark (buffer-point *echo-area-buffer*) :right-inserting) + "Mark that points to the beginning of the text that'll be parsed.") +(defvar *parse-input-region* + (region *parse-starting-mark* (region-end *echo-area-region*)) + "Region that contains the text typed in.") + + + + +;;;; Variables that control parsing: + +(defvar *parse-verification-function* '%not-inside-a-parse + "Function that verifies what's being parsed.") + +(defmacro modifying-echo-buffer (&body body) + `(unwind-protect + (progn + (buffer-document-begin-editing *echo-area-buffer*) + (modifying-buffer *echo-area-buffer* ,@body)) + (buffer-document-end-editing *echo-area-buffer*))) +;;; %Not-Inside-A-Parse -- Internal +;;; +;;; This function is called if someone does stuff in the echo area when +;;; we aren't inside a parse. It tries to put them back in a reasonable place. +;;; +(defun %not-inside-a-parse (quaz) + "Thing that's called when somehow we get called to confirm a parse that's + not in progress." + (declare (ignore quaz)) + (let* ((bufs (remove *echo-area-buffer* *buffer-list*)) + (buf (or (find-if #'buffer-windows bufs) + (car bufs) + (make-buffer "Main")))) + (setf (current-buffer) buf) + (dolist (w *window-list*) + (when (and (eq (window-buffer w) *echo-area-buffer*) + (not (eq w *echo-area-window*))) + (setf (window-buffer w) buf))) + (setf (current-window) + (or (car (buffer-windows buf)) + (make-window (buffer-start-mark buf))))) + (editor-error "Wham! We tried to confirm a parse that wasn't in progress?")) + +(defvar *parse-string-tables* () + "String tables being used in the current parse.") + +(defvar *parse-value-must-exist* () + "You know.") + +(defvar *parse-default* () + "When the user attempts to default a parse, we call the verification function + on this string. This is not the :Default argument to the prompting function, + but rather a string representation of it.") + +(defvar *parse-default-string* () + "String that we show the user to inform him of the default. If this + is NIL then we just use *Parse-Default*.") + +(defvar *parse-prompt* () + "Prompt for the current parse.") + +(defvar *parse-help* () + "Help string for the current parse.") + +(defvar *parse-type* :string "A hack. :String, :File or :Keyword.") + + + + +;;;; MESSAGE and CLEAR-ECHO-AREA: + +(defhvar "Message Pause" "The number of seconds to pause after a Message." + :value 0.0s0) + +(defvar *last-message-time* 0 + "Internal-Real-Time the last time we displayed a message.") + +(defun maybe-wait () + (let* ((now (get-internal-real-time)) + (delta (/ (float (- now *last-message-time*)) + (float internal-time-units-per-second))) + (pause (value hemlock::message-pause))) + (when (< delta pause) + (sleep (- pause delta))))) + +(defun clear-echo-area () + "You guessed it." + ;;(maybe-wait) + (let* ((b (current-buffer))) + (unwind-protect + (progn + (setf (current-buffer) *echo-area-buffer*) + (modifying-echo-buffer + (delete-region *echo-area-region*)) + (setf (buffer-modified *echo-area-buffer*) nil)) + (setf (current-buffer) b)))) + +;;; Message -- Public +;;; +;;; Display the stuff on *echo-area-stream* and then wait. Editor-Sleep +;;; will do a redisplay if appropriate. +;;; +(defun message (string &rest args) + "Nicely display a message in the echo-area. + Put the message on a fresh line and wait for \"Message Pause\" seconds + to give the luser a chance to see it. String and Args are a format + control string and format arguments, respectively." + ;(maybe-wait) + (modifying-echo-buffer + (cond ((eq *current-window* *echo-area-window*) + (let ((point (buffer-point *echo-area-buffer*))) + (with-mark ((m point :left-inserting)) + (line-start m) + (with-output-to-mark (s m :full) + (apply #'format s string args) + (fresh-line s))))) + (t + (let ((mark (region-end *echo-area-region*))) + (cond ((buffer-modified *echo-area-buffer*) + (clear-echo-area)) + ((not (zerop (mark-charpos mark))) + (insert-character mark #\newline) + (clear-echo-area))) + (write-string (apply #'format nil string args) + *echo-area-stream*) + ;; keep command loop from clearing the echo area, + ;; by asserting that the echo area buffer's unmodified. + (setf (buffer-modified *echo-area-buffer*) t)))) + (force-output *echo-area-stream*) + (setq *last-message-time* (get-internal-real-time))) + nil) + + +;;; LOUD-MESSAGE -- Public. +;;; +;;; Like message, only more provocative. +;;; +(defun loud-message (&rest args) + "This is the same as MESSAGE, but it beeps and clears the echo area before + doing anything else." + (beep) + (clear-echo-area) + (apply #'message args)) + + + + + + + + +;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING. + +(defun display-prompt-nicely (&optional (prompt *parse-prompt*) + (default (or *parse-default-string* + *parse-default*))) + (clear-echo-area) + (modifying-echo-buffer + (let ((point (buffer-point *echo-area-buffer*))) + (if (listp prompt) + (apply #'format *echo-area-stream* prompt) + (insert-string point prompt)) + (when default + (insert-character point #\[) + (insert-string point default) + (insert-string point "] "))))) + +(defun parse-for-something () + (display-prompt-nicely) + (let ((start-window (current-window))) + (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*)) + (setf (current-window) *echo-area-window*) + (unwind-protect + (use-buffer *echo-area-buffer* + (recursive-edit nil)) + + (setf (current-window) start-window)))) + + + + +;;;; Buffer prompting. + +(defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t) + default + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Buffer: ") + ((:help *parse-help*) "Type a buffer name.")) + "Prompts for a buffer name and returns the corresponding buffer. If + :must-exist is nil, then return the input string. This refuses to accept + the empty string as input when no default is supplied. :default-string + may be used to supply a default buffer name even when :default is nil, but + when :must-exist is non-nil, :default-string must be the name of an existing + buffer." + (let ((*parse-string-tables* (list *buffer-names*)) + (*parse-type* :keyword) + (*parse-default* (cond + (default (buffer-name default)) + (*parse-default-string* + (when (and *parse-value-must-exist* + (not (getstring *parse-default-string* + *buffer-names*))) + (error "Default-string must name an existing ~ + buffer when must-exist is non-nil -- ~S." + *parse-default-string*)) + *parse-default-string*) + (t nil))) + (*parse-verification-function* #'buffer-verification-function)) + (parse-for-something))) + +(defun buffer-verification-function (string) + (declare (simple-string string)) + (modifying-echo-buffer + (cond ((string= string "") nil) + (*parse-value-must-exist* + (multiple-value-bind + (prefix key value field ambig) + (complete-string string *parse-string-tables*) + (declare (ignore field)) + (ecase key + (:none nil) + ((:unique :complete) + (list value)) + (:ambiguous + (delete-region *parse-input-region*) + (insert-string (region-start *parse-input-region*) prefix) + (let ((point (current-point))) + (move-mark point (region-start *parse-input-region*)) + (unless (character-offset point ambig) + (buffer-end point))) + nil)))) + (t + (list (or (getstring string *buffer-names*) string)))))) + + + + +;;;; File Prompting. + +(defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t) + default + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Filename: ") + ((:help *parse-help*) "Type a file name.")) + "Prompts for a filename." + (let ((*parse-verification-function* #'file-verification-function) + (*parse-default* (if default (namestring default))) + (*parse-type* :file)) + (parse-for-something))) + +(defun file-verification-function (string) + (let ((pn (pathname-or-lose string))) + (if pn + (let ((merge + (cond ((not *parse-default*) nil) + ((directoryp pn) + (merge-pathnames pn *parse-default*)) + (t + (merge-pathnames pn + (or (directory-namestring + *parse-default*) + "")))))) + (cond ((probe-file pn) (list pn)) + ((and merge (probe-file merge)) (list merge)) + ((not *parse-value-must-exist*) (list (or merge pn))) + (t nil)))))) + +;;; PATHNAME-OR-LOSE tries to convert string to a pathname using +;;; PARSE-NAMESTRING. If it succeeds, this returns the pathname. Otherwise, +;;; this deletes the offending characters from *parse-input-region* and signals +;;; an editor-error. +;;; +(defun pathname-or-lose (string) + (declare (simple-string string)) + (multiple-value-bind (pn idx) + (parse-namestring string nil *default-pathname-defaults* + :junk-allowed t) + (cond (pn) + (t (modifying-echo-buffer + (delete-characters (region-end *echo-area-region*) + (- idx (length string)))) + nil)))) + + + + +;;;; Keyword and variable prompting. + +(defun prompt-for-keyword (*parse-string-tables* + &key + ((:must-exist *parse-value-must-exist*) t) + ((:default *parse-default*)) + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Keyword: ") + ((:help *parse-help*) "Type a keyword.")) + "Prompts for a keyword using the String Tables." + (let ((*parse-verification-function* #'keyword-verification-function) + (*parse-type* :keyword)) + (parse-for-something))) + +(defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t) + ((:default *parse-default*)) + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Variable: ") + ((:help *parse-help*) + "Type the name of a variable.")) + "Prompts for a variable defined in the current scheme of things." + (let ((*parse-string-tables* (current-variable-tables)) + (*parse-verification-function* #'keyword-verification-function) + (*parse-type* :keyword)) + (parse-for-something))) + +(defun current-variable-tables () + "Returns a list of all the variable tables currently established globally, + by the current buffer, and by any modes for the current buffer." + (do ((tables (list (buffer-variables *current-buffer*) + *global-variable-names*) + (cons (mode-object-variables (car mode)) tables)) + (mode (buffer-mode-objects *current-buffer*) (cdr mode))) + ((null mode) tables))) + +(defun keyword-verification-function (string) + (declare (simple-string string)) + (multiple-value-bind + (prefix key value field ambig) + (complete-string string *parse-string-tables*) + (declare (ignore field)) + (modifying-echo-buffer + (cond (*parse-value-must-exist* + (ecase key + (:none nil) + ((:unique :complete) + (list prefix value)) + (:ambiguous + (delete-region *parse-input-region*) + (insert-string (region-start *parse-input-region*) prefix) + (let ((point (current-point))) + (move-mark point (region-start *parse-input-region*)) + (unless (character-offset point ambig) + (buffer-end point))) + nil))) + (t + ;; HACK: If it doesn't have to exist, and the completion does not + ;; add anything, then return the completion's capitalization, + ;; instead of the user's input. + (list (if (= (length string) (length prefix)) prefix string))))))) + + + + +;;;; Integer, expression, and string prompting. + +(defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t) + default + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Integer: ") + ((:help *parse-help*) "Type an integer.")) + "Prompt for an integer. If :must-exist is Nil, then we return as a string + whatever was input if it is not a valid integer." + (let ((*parse-verification-function* + #'(lambda (string) + (let ((number (parse-integer string :junk-allowed t))) + (if *parse-value-must-exist* + (if number (list number)) + (list (or number string)))))) + (*parse-default* (if default (write-to-string default :base 10)))) + (parse-for-something))) + + +(defvar hemlock-eof '(()) + "An object that won't be EQ to anything read.") + +(defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t) + (default nil defaultp) + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Expression: ") + ((:help *parse-help*) + "Type a Lisp expression.")) + "Prompts for a Lisp expression." + (let ((*parse-verification-function* + #'(lambda (string) + (let ((expr (with-input-from-region (stream *parse-input-region*) + (handler-case (read stream nil hemlock-eof) + (error () hemlock-eof))))) + (if *parse-value-must-exist* + (if (not (eq expr hemlock-eof)) (values (list expr) t)) + (if (eq expr hemlock-eof) + (list string) (values (list expr) t)))))) + (*parse-default* (if defaultp (prin1-to-string default)))) + (parse-for-something))) + + +(defun prompt-for-string (&key ((:default *parse-default*)) + ((:default-string *parse-default-string*)) + (trim ()) + ((:prompt *parse-prompt*) "String: ") + ((:help *parse-help*) "Type a string.")) + "Prompts for a string. If :trim is t, then leading and trailing whitespace + is removed from input, otherwise it is interpreted as a Char-Bag argument + to String-Trim." + (let ((*parse-verification-function* + #'(lambda (string) + (list (string-trim (if (eq trim t) '(#\space #\tab) trim) + string))))) + (parse-for-something))) + + + + +;;;; Package names. +(defun make-package-string-table () + (let ((names ())) + (dolist (p (list-all-packages)) + (let* ((name (package-name p))) + (push (cons name name) names) + (dolist (nick (package-nicknames p)) + (push (cons nick name) names)))) + (make-string-table :initial-contents names))) + +#|| +(defun prompt-for-package (&key ((:must-exist *parse-value-must-exist*) t) + (default nil defaultp) + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Package Name:") + ((:help *parse-help*) "Type a package name.")) +||# + + + +;;;; Yes-or-no and y-or-n prompting. + +(defvar *yes-or-no-string-table* + (make-string-table :initial-contents '(("Yes" . t) ("No" . nil)))) + +(defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t) + (default nil defaultp) + ((:default-string *parse-default-string*)) + ((:prompt *parse-prompt*) "Yes or No? ") + ((:help *parse-help*) "Type Yes or No.")) + "Prompts for Yes or No." + (let* ((*parse-string-tables* (list *yes-or-no-string-table*)) + (*parse-default* (if defaultp (if default "Yes" "No"))) + (*parse-verification-function* + #'(lambda (string) + (multiple-value-bind + (prefix key value field ambig) + (complete-string string *parse-string-tables*) + (declare (ignore prefix field ambig)) + (let ((won (or (eq key :complete) (eq key :unique)))) + (if *parse-value-must-exist* + (if won (values (list value) t)) + (list (if won (values value t) string))))))) + (*parse-type* :keyword)) + (parse-for-something))) + +(defun prompt-for-y-or-n (&key ((:must-exist must-exist) t) + (default nil defaultp) + default-string + ((:prompt prompt) "Y or N? ") + ((:help *parse-help*) "Type Y or N.")) + "Prompts for Y or N." + (let ((old-window (current-window))) + (unwind-protect + (progn + (setf (current-window) *echo-area-window*) + (display-prompt-nicely prompt (or default-string + (if defaultp (if default "Y" "N")))) + (loop + (let ((key-event (recursive-get-key-event *editor-input*))) + (cond ((or (eq key-event #k"y") + (eq key-event #k"Y")) + (return t)) + ((or (eq key-event #k"n") + (eq key-event #k"N")) + (return nil)) + ((logical-key-event-p key-event :confirm) + (if defaultp + (return default) + (beep))) + ((logical-key-event-p key-event :help) + (hemlock::help-on-parse-command ())) + (t + (unless must-exist (return key-event)) + (beep)))))) + (setf (current-window) old-window)))) + + + + +;;;; Key-event and key prompting. + +(defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t)) + "Prompts for a key-event." + (prompt-for-key-event* prompt change-window)) + +(defun prompt-for-key-event* (prompt change-window) + (let ((old-window (current-window))) + (unwind-protect + (progn + (when change-window + (setf (current-window) *echo-area-window*)) + (display-prompt-nicely prompt) + (recursive-get-key-event *editor-input* t)) + (when change-window (setf (current-window) old-window))))) + +(defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0)) +(defun prompt-for-key (&key ((:must-exist must-exist) t) + default default-string + (prompt "Key: ") + ((:help *parse-help*) "Type a key.")) + (let ((old-window (current-window)) + (string (if default + (or default-string + (let ((l (coerce default 'list))) + (format nil "~:C~{ ~:C~}" (car l) (cdr l))))))) + + (unwind-protect + (progn + (setf (current-window) *echo-area-window*) + (display-prompt-nicely prompt string) + (setf (fill-pointer *prompt-key*) 0) + (prog ((key *prompt-key*) key-event) + (declare (vector key)) + TOP + (setf key-event (recursive-get-key-event *editor-input*)) + (cond ((logical-key-event-p key-event :quote) + (setf key-event (recursive-get-key-event *editor-input* t))) + ((logical-key-event-p key-event :confirm) + (cond ((and default (zerop (length key))) + (let ((res (get-command default :current))) + (unless (commandp res) (go FLAME)) + (return (values default res)))) + ((and (not must-exist) (plusp (length key))) + (return (copy-seq key))) + (t + (go FLAME)))) + ((logical-key-event-p key-event :help) + (hemlock::help-on-parse-command ()) + (go TOP))) + (vector-push-extend key-event key) + (when must-exist + (let ((res (get-command key :current))) + (cond ((commandp res) + (hemlock-ext:print-pretty-key-event key-event + *echo-area-stream* + t) + (write-char #\space *echo-area-stream*) + (return (values (copy-seq key) res))) + ((not (eq res :prefix)) + (vector-pop key) + (go FLAME))))) + (hemlock-ext:print-pretty-key key-event *echo-area-stream* t) + (write-char #\space *echo-area-stream*) + (go TOP) + FLAME + (beep) + (go TOP))) + (force-output *echo-area-stream*) + (setf (current-window) old-window)))) + + + + +;;;; Logical key-event stuff. + +(defvar *logical-key-event-names* (make-string-table) + "This variable holds a string-table from logical-key-event names to the + corresponding keywords.") + +(defvar *real-to-logical-key-events* (make-hash-table :test #'eql) + "A hashtable from real key-events to their corresponding logical + key-event keywords.") + +(defvar *logical-key-event-descriptors* (make-hash-table :test #'eq) + "A hashtable from logical-key-events to logical-key-event-descriptors.") + +(defstruct (logical-key-event-descriptor + (:constructor make-logical-key-event-descriptor ())) + name + key-events + documentation) + +;;; LOGICAL-KEY-EVENT-P -- Public +;;; +(defun logical-key-event-p (key-event keyword) + "Return true if key-event has been defined to have Keyword as its + logical key-event. The relation between logical and real key-events + is defined by using SETF on LOGICAL-KEY-EVENT-P. If it is set to + true then calling LOGICAL-KEY-EVENT-P with the same key-event and + Keyword, will result in truth. Setting to false produces the opposite + result. See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE." + (not (null (member keyword (gethash key-event *real-to-logical-key-events*))))) + +;;; GET-LOGICAL-KEY-EVENT-DESC -- Internal +;;; +;;; Return the descriptor for the logical key-event keyword, or signal +;;; an error if it isn't defined. +;;; +(defun get-logical-key-event-desc (keyword) + (let ((res (gethash keyword *logical-key-event-descriptors*))) + (unless res + (error "~S is not a defined logical-key-event keyword." keyword)) + res)) + +;;; %SET-LOGICAL-KEY-EVENT-P -- Internal +;;; +;;; Add or remove a logical key-event link by adding to or deleting from +;;; the list in the from-char hashtable and the descriptor. +;;; +(defun %set-logical-key-event-p (key-event keyword new-value) + (let ((entry (get-logical-key-event-desc keyword))) + (cond + (new-value + (pushnew keyword (gethash key-event *real-to-logical-key-events*)) + (pushnew key-event (logical-key-event-descriptor-key-events entry))) + (t + (setf (gethash key-event *real-to-logical-key-events*) + (delete keyword (gethash key-event *real-to-logical-key-events*))) + (setf (logical-key-event-descriptor-key-events entry) + (delete keyword (logical-key-event-descriptor-key-events entry)))))) + new-value) + +;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS -- Public +;;; +;;; Grab the right field out of the descriptor and return it. +;;; +(defun logical-key-event-documentation (keyword) + "Return the documentation for the logical key-event Keyword." + (logical-key-event-descriptor-documentation + (get-logical-key-event-desc keyword))) +;;; +(defun logical-key-event-name (keyword) + "Return the string name for the logical key-event Keyword." + (logical-key-event-descriptor-name (get-logical-key-event-desc keyword))) +;;; +(defun logical-key-event-key-events (keyword) + "Return the list of key-events for which Keyword is the logical key-event." + (logical-key-event-descriptor-key-events + (get-logical-key-event-desc keyword))) + +;;; DEFINE-LOGICAL-KEY-EVENT -- Public +;;; +;;; Make the entries in the two hashtables and the string-table. +;;; +(defun define-logical-key-event (name documentation) + "Define a logical key-event having the specified Name and Documentation. + See LOGICAL-KEY-EVENT-P and COMMAND-CASE." + (check-type name string) + (check-type documentation (or string function)) + (let* ((keyword (string-to-keyword name)) + (entry (or (gethash keyword *logical-key-event-descriptors*) + (setf (gethash keyword *logical-key-event-descriptors*) + (make-logical-key-event-descriptor))))) + (setf (logical-key-event-descriptor-name entry) name) + (setf (logical-key-event-descriptor-documentation entry) documentation) + (setf (getstring name *logical-key-event-names*) keyword))) + + + + +;;;; Some standard logical-key-events: + +(define-logical-key-event "Forward Search" + "This key-event is used to indicate that a forward search should be made.") +(define-logical-key-event "Backward Search" + "This key-event is used to indicate that a backward search should be made.") +(define-logical-key-event "Recursive Edit" + "This key-event indicates that a recursive edit should be entered.") +(define-logical-key-event "Cancel" + "This key-event is used to cancel a previous key-event of input.") +(define-logical-key-event "Abort" + "This key-event is used to abort the command in progress.") +(define-logical-key-event "Exit" + "This key-event is used to exit normally the command in progress.") +(define-logical-key-event "Yes" + "This key-event is used to indicate a positive response.") +(define-logical-key-event "No" + "This key-event is used to indicate a negative response.") +(define-logical-key-event "Do All" + "This key-event means do it as many times as you can.") +(define-logical-key-event "Do Once" + "This key-event means, do it this time, then exit.") +(define-logical-key-event "Help" + "This key-event is used to ask for help.") +(define-logical-key-event "Confirm" + "This key-event is used to confirm some choice.") +(define-logical-key-event "Quote" + "This key-event is used to quote the next key-event of input.") +(define-logical-key-event "Keep" + "This key-event means exit but keep something around.") +(define-logical-key-event "Mouse Exit" + "This key-event means exit completely.") +(define-logical-key-event "Extend Search Word" + "This key-event means to extend the incremental search string by the word after the point") + + + +;;;; COMMAND-CASE help message printing. + +(defvar *my-string-output-stream* (make-string-output-stream)) + +(defun chars-to-string (chars) + (do ((s *my-string-output-stream*) + (chars chars (cdr chars))) + ((null chars) + (get-output-stream-string s)) + (let ((char (car chars))) + (if (characterp char) + (write-char char s) + (do ((key-events + (logical-key-event-key-events char) + (cdr key-events))) + ((null key-events)) + (hemlock-ext:print-pretty-key (car key-events) s) + (unless (null (cdr key-events)) + (write-string ", " s)))) + (unless (null (cdr chars)) + (write-string ", " s))))) + +;;; COMMAND-CASE-HELP -- Internal +;;; +;;; Print out a help message derived from the options in a +;;; random-typeout window. +;;; +(defun command-case-help (help options) + (let ((help (if (listp help) + (apply #'format nil help) help))) + (with-pop-up-display (s :title "Help") + (write-string help s) + (fresh-line s) + (do ((o options (cdr o))) + ((null o)) + (let ((string (chars-to-string (caar o)))) + (declare (simple-string string)) + (if (= (length string) 1) + (write-char (char string 0) s) + (write-line string s)) + (write-string " - " s) + (write-line (cdar o) s)))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/echocoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/echocoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/echocoms.lisp (revision 8058) @@ -0,0 +1,338 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Echo area commands. +;;; +;;; Written by Rob MacLachlan and Skef Wholey. +;;; +(in-package :hemlock) + +(defhvar "Beep on Ambiguity" + "If non-NIL, beep when completion of a parse is ambiguous." + :value t) + +(defhvar "Ignore File Types" + "File types to ignore when trying to complete a filename." + :value + (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err" + "x86f" "lbytef" "core" "trace" ; Lisp + "BAK" "CKP" ; Backups & Checkpoints + "PS" "ps" "press" "otl" "dvi" "toc" ; Formatting + "bbl" "lof" "idx" "lot" "aux" ; Formatting + "mo" "elc" ; Other editors + "bin" "lbin" ; Obvious binary extensions. + "o" "a" "aout" "out" ; UNIXY stuff + "bm" "onx" "snf" ; X stuff + "UU" "uu" "arc" "Z" "gz" "tar" ; Binary encoded files + )) + + +;;; Field separator characters separate fields for TOPS-20 ^F style +;;; completion. +(defattribute "Parse Field Separator" + "A value of 1 for this attribute indicates that the corresponding character + should be considered to be a field separator by the prompting commands.") +(setf (character-attribute :parse-field-separator #\space) 1) + + +;;; Find-All-Completions -- Internal +;;; +;;; Return as a list of all the possible completions of String in the +;;; list of string-tables Tables. +;;; +(defun find-all-completions (string tables) + (do ((table tables (cdr table)) + (res () + (merge 'list (find-ambiguous string (car table)) + res #'string-lessp))) + ((null table) res))) + +(defcommand "Help on Parse" (p) + "Display help for parse in progress. + If there are a limited number of options then display them." + "Display the *Parse-Help* and any possibly completions of the current + input." + (declare (ignore p)) + (let ((help (typecase *parse-help* + (list (unless *parse-help* (error "There is no parse help.")) + (apply #'format nil *parse-help*)) + (string *parse-help*) + (t (error "Parse help is not a string or list: ~S" *parse-help*)))) + (input (region-to-string *parse-input-region*))) + (cond + ((eq *parse-type* :keyword) + (let ((strings (find-all-completions input *parse-string-tables*))) + (with-pop-up-display (s :title "input help" :height (+ (length strings) 2)) + (write-line help s) + (cond (strings + (write-line "Possible completions of what you have typed:" s) + (dolist (string strings) + (write-line string s))) + (t + (write-line + "There are no possible completions of what you have typed." s)))))) + ((and (eq *parse-type* :file) (not (zerop (length input)))) + (let ((pns (ambiguous-files (region-to-string *parse-input-region*) + *parse-default*))) + (declare (list pns)) + (with-pop-up-display(s :title "Completion help" :height (+ (length pns) 2)) + (write-line help s) + (cond (pns + (write-line "Possible completions of what you have typed:" s) + (let ((width (- (window-width (current-window)) 27))) + (dolist (pn pns) + (let* ((dir (directory-namestring pn)) + (len (length dir))) + (unless (<= len width) + (let ((slash (position #\/ dir + :start (+ (- len width) 3)))) + (setf dir + (if slash + (concatenate 'string "..." + (subseq dir slash)) + "...")))) + (format s " ~A~25T ~A~%" + (file-namestring pn) dir))))) + (t + (write-line + "There are no possible completions of what you have typed." s)))))) + (t + (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting)) + (insert-string m help) + (insert-character m #\newline)))))) + +(defun file-completion-action (typein) + (declare (simple-string typein)) + (when (zerop (length typein)) (editor-error)) + (multiple-value-bind + (result win) + (hemlock-ext:complete-file typein + :defaults (directory-namestring *parse-default*) + :ignore-types (value ignore-file-types)) + (when result + (delete-region *parse-input-region*) + (insert-string (region-start *parse-input-region*) + (namestring result))) + (when (and (not win) (value beep-on-ambiguity)) + (editor-error)))) + +(defcommand "Complete Keyword" (p) + "Trys to complete the text being read in the echo area as a string in + *parse-string-tables*" + "Complete the keyword being parsed as far as possible. + If it is ambiguous and ``Beep On Ambiguity'' true beep." + (declare (ignore p)) + (let ((typein (region-to-string *parse-input-region*))) + (declare (simple-string typein)) + (case *parse-type* + (:keyword + (multiple-value-bind + (prefix key value field ambig) + (complete-string typein *parse-string-tables*) + (declare (ignore value field)) + (when prefix + (delete-region *parse-input-region*) + (insert-string (region-start *parse-input-region*) prefix) + (when (eq key :ambiguous) + (let ((point (current-point))) + (move-mark point (region-start *parse-input-region*)) + (unless (character-offset point ambig) + (buffer-end point))))) + (when (and (or (eq key :ambiguous) (eq key :none)) + (value beep-on-ambiguity)) + (editor-error)))) + (:file + (file-completion-action typein)) + (t + (editor-error "Cannot complete input for this prompt."))))) + +(defun field-separator-p (x) + (plusp (character-attribute :parse-field-separator x))) + +(defcommand "Complete Field" (p) + "Complete a field in a parse. + Fields are defined by the :field separator attribute, + the text being read in the echo area as a string in *parse-string-tables*" + "Complete a field in a keyword. + If it is ambiguous and ``Beep On Ambiguity'' true beep. Fields are + separated by characters having a non-zero :parse-field-separator attribute, + and this command should only be bound to characters having that attribute." + (let ((typein (region-to-string *parse-input-region*))) + (declare (simple-string typein)) + (case *parse-type* + (:string + (self-insert-command p)) + (:file + (file-completion-action typein)) + (:keyword + (let ((point (current-point))) + (unless (blank-after-p point) + (insert-character point + (hemlock-ext:key-event-char *last-key-event-typed*)))) + (multiple-value-bind + (prefix key value field ambig) + (complete-string typein *parse-string-tables*) + (declare (ignore value ambig)) + (when (eq key :none) (editor-error "No possible completion.")) + (delete-region *parse-input-region*) + (let ((new-typein (if (and (eq key :unique) (null field)) + (subseq prefix 0 field) + (concatenate 'string + (subseq prefix 0 field) + (string + (hemlock-ext:key-event-char + *last-key-event-typed*)))))) + (insert-string (region-start *parse-input-region*) new-typein)))) + (t + (editor-error "Cannot complete input for this prompt."))))) + + + +(defvar *echo-area-history* (make-ring 10) + "This ring-buffer contains strings which were previously input in the + echo area.") + +(defvar *echo-history-pointer* 0 + "This is our current position to the ring during a historical exploration.") + +(defcommand "Confirm Parse" (p) + "Terminate echo-area input. + If the input is invalid then an editor-error will signalled." + "If no input has been given, exits the recursive edit with the default, + otherwise calls the verification function." + (declare (ignore p)) + (let* ((string (region-to-string *parse-input-region*)) + (empty (zerop (length string)))) + (declare (simple-string string)) + (if empty + (when *parse-default* (setq string *parse-default*)) + (when (or (zerop (ring-length *echo-area-history*)) + (string/= string (ring-ref *echo-area-history* 0))) + (ring-push string *echo-area-history*))) + (multiple-value-bind (res flag) + (funcall *parse-verification-function* string) + (unless (or res flag) (editor-error)) + (exit-recursive-edit res)))) + +(defcommand "Previous Parse" (p) + "Rotate the echo-area history forward. + If current input is non-empty and different from what is on the top + of the ring then push it on the ring before inserting the new input." + "Pop the *echo-area-history* ring buffer." + (let ((length (ring-length *echo-area-history*)) + (p (or p 1))) + (when (zerop length) (editor-error)) + (cond + ((eq (last-command-type) :echo-history) + (let ((base (mod (+ *echo-history-pointer* p) length))) + (delete-region *parse-input-region*) + (insert-string (region-end *parse-input-region*) + (ring-ref *echo-area-history* base)) + (setq *echo-history-pointer* base))) + (t + (let ((current (region-to-string *parse-input-region*)) + (base (mod (if (minusp p) p (1- p)) length))) + (delete-region *parse-input-region*) + (insert-string (region-end *parse-input-region*) + (ring-ref *echo-area-history* base)) + (when (and (plusp (length current)) + (string/= (ring-ref *echo-area-history* 0) current)) + (ring-push current *echo-area-history*) + (incf base)) + (setq *echo-history-pointer* base)))) + (setf (last-command-type) :echo-history))) + +(defcommand "Next Parse" (p) + "Rotate the echo-area history backward. + If current input is non-empty and different from what is on the top + of the ring then push it on the ring before inserting the new input." + "Push the *echo-area-history* ring buffer." + (previous-parse-command (- (or p 1)))) + + +(defcommand "Illegal" (p) + "This signals an editor-error. + It is useful for making commands locally unbound." + "Just signals an editor-error." + (declare (ignore p)) + (editor-error)) + +(add-hook window-buffer-hook + #'(lambda (window new-buff) + (when (and (eq window *echo-area-window*) + (not (eq new-buff *echo-area-buffer*))) + (editor-error "Can't change echo area window.")))) + +(defcommand "Beginning Of Parse" (p) + "Moves to immediately after the prompt when in the echo area." + "Move the point of the echo area buffer to *parse-starting-mark*." + (declare (ignore p)) + (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*)) + +(defcommand "Echo Area Delete Previous Character" (p) + "Delete the previous character. + Don't let the luser rub out the prompt." + "Signal an editor-error if we would nuke the prompt, + otherwise do a normal delete." + (with-mark ((tem (buffer-point *echo-area-buffer*))) + (unless (character-offset tem (- (or p 1))) (editor-error)) + (when (mark< tem *parse-starting-mark*) (editor-error)) + (delete-previous-character-command p))) + +(defcommand "Echo Area Kill Previous Word" (p) + "Kill the previous word. + Don't let the luser rub out the prompt." + "Signal an editor-error if we would mangle the prompt, otherwise + do a normal kill-previous-word." + (with-mark ((tem (buffer-point *echo-area-buffer*))) + (unless (word-offset tem (- (or p 1))) (editor-error)) + (when (mark< tem *parse-starting-mark*) (editor-error)) + (kill-previous-word-command p))) + +(declaim (special *kill-ring*)) + +(defcommand "Kill Parse" (p) + "Kills any input so far." + "Kills *parse-input-region*." + (declare (ignore p)) + (if (end-line-p (current-point)) + (kill-region *parse-input-region* :kill-backward) + (ring-push (delete-and-save-region *parse-input-region*) + *kill-ring*))) + +(defcommand "Insert Parse Default" (p) + "Inserts the default for the parse in progress. + The text is inserted at the point." + "Inserts *parse-default* at the point of the *echo-area-buffer*. + If there is no default an editor-error is signalled." + (declare (ignore p)) + (unless *parse-default* (editor-error)) + (insert-string (buffer-point *echo-area-buffer*) *parse-default*)) + +(defcommand "Echo Area Backward Character" (p) + "Go back one character. + Don't let the luser move into the prompt." + "Signal an editor-error if we try to go into the prompt, otherwise + do a backward-character command." + (backward-character-command p) + (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) + (beginning-of-parse-command ()) + (editor-error))) + +(defcommand "Echo Area Backward Word" (p) + "Go back one word. + Don't let the luser move into the prompt." + "Signal an editor-error if we try to go into the prompt, otherwise + do a backward-word command." + (backward-word-command p) + (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) + (beginning-of-parse-command ()) + (editor-error))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/edit-defs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/edit-defs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/edit-defs.lisp (revision 8058) @@ -0,0 +1,311 @@ +;;; -*- Log: hemlock.log; Package: hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Editing DEFMACRO and DEFUN definitions. Also, has directory translation +;;; code for moved and/or different sources. +;;; + +(in-package :hemlock) + + +;;; Definition Editing Commands. + + + +;;; For the "Go to Definition" search pattern, we just use " " as the initial +;;; pattern, so we can make a search pattern. Invocation of the command alters +;;; the search pattern. + +(defvar *go-to-def-pattern* + (new-search-pattern :string-insensitive :forward " ")) + +(defvar *last-go-to-def-string* "") +(declaim (simple-string *last-go-to-def-string*)) + +(defun symbol-at-point (buffer point) + "Returns symbol at point, or contents of selection if there is one" + (with-mark ((mark1 point) + (mark2 point)) + (if (hi::%buffer-current-region-p buffer) + (let* ((mark (hi::buffer-%mark buffer))) + (if (mark< mark point) + (move-mark mark1 mark) + (move-mark mark2 mark))) + ;; This doesn't handle embedded #'s or escaped chars in names. + ;; So let them report it as a bug... + (progn + (when (test-char (previous-character point) :lisp-syntax :constituent) + (or (rev-scan-char mark1 :lisp-syntax (not :constituent)) + (buffer-start mark1)) + (scan-char mark1 :lisp-syntax :constituent)) + (when (test-char (next-character point) :lisp-syntax :constituent) + (or (scan-char mark2 :lisp-syntax (not :constituent)) + (buffer-end mark2))) + (when (mark= mark1 mark2) + ;; Try to get whole form + (pre-command-parse-check point) + (when (valid-spot point t) + (move-mark mark1 point) + (form-offset mark1 -1) + (move-mark mark2 mark1) + (form-offset mark2 1))))) + (unless (mark= mark1 mark2) + (region-to-string (region mark1 mark2))))) + +(defcommand "Goto Definition" (p) + "Go to the current function/macro's definition. With a numarg, prompts for name to go to." + "Go to the current function/macro's definition." + (if p + (edit-definition-command nil) + (let* ((point (current-point)) + (buffer (current-buffer)) + (fun-name (symbol-at-point buffer point))) + (if fun-name + (get-def-info-and-go-to-it fun-name (or + (buffer-package (current-buffer)) + *package*)) + (beep))))) + +(defcommand "Edit Definition" (p) + "Prompts for function/macro's definition name and goes to it for editing." + "Prompts for function/macro's definition name and goes to it for editing." + (declare (ignore p)) + (let ((fun-name (prompt-for-string + :prompt "Name: " + :help "Symbol name of function."))) + (get-def-info-and-go-to-it fun-name (or + (find-package + (variable-value 'current-package :buffer (current-buffer))) + *package*)))) + + +;;; "Edit Command Definition" is a hack due to creeping evolution in +;;; GO-TO-DEFINITION. We specify :function type and a name with "-COMMAND" +;;; instead of :command type and the real command name because this causes +;;; the right pattern to be created for searching. We could either specify +;;; that you always edit command definitions with this command (breaking +;;; "Go to Definition" for commands called as functions), fixing the code, +;;; or we can hack this command so everything works. +;;; +(defcommand "Edit Command Definition" (p) + "Prompts for command definition name and goes to it for editing." + "Prompts for command definition name and goes to it for editing." + (multiple-value-bind + (name command) + (if p + (multiple-value-bind (key cmd) + (prompt-for-key :prompt "Edit command bound to: ") + (declare (ignore key)) + (values (command-name cmd) cmd)) + (prompt-for-keyword (list *command-names*) + :prompt "Command to edit: ")) + (go-to-definition (fun-defined-from-pathname (command-function command)) + :function + (concatenate 'simple-string name "-COMMAND")))) + +;;; GO-TO-DEFINITION tries to find name in file with a search pattern based +;;; on type (defun or defmacro). File may be translated to another source +;;; file, and if type is a function that cannot be found, we try to find a +;;; command by an appropriate name. +;;; +(defun go-to-definition (file type name) + (let ((pattern (get-definition-pattern type name))) + (cond + (file + (setf file (go-to-definition-file file)) + (let* ((buffer (find-file-command nil file)) + (point (buffer-point buffer)) + (name-len (length name))) + (declare (fixnum name-len)) + (with-mark ((def-mark point)) + (buffer-start def-mark) + (unless (find-pattern def-mark pattern) + (if (and (or (eq type :function) (eq type :unknown-function)) + (> name-len 7) + (string= name "COMMAND" :start1 (- name-len 7))) + (let ((prev-search-str *last-go-to-def-string*)) + (unless (find-pattern def-mark + (get-definition-pattern :command name)) + (editor-error "~A is not defined with ~S or ~S, ~ + but this is the defined-in file." + (string-upcase name) prev-search-str + *last-go-to-def-string*))) + (editor-error "~A is not defined with ~S, ~ + but this is the defined-in file." + (string-upcase name) *last-go-to-def-string*))) + (if (eq buffer (current-buffer)) + (push-buffer-mark (copy-mark point))) + (move-mark point def-mark)))) + (t + (when (or (eq type :unknown-function) (eq type :unknown-macro)) + (with-mark ((m (buffer-start-mark (current-buffer)))) + (unless (find-pattern m pattern) + (editor-error + "~A is not compiled and not defined in current buffer with ~S" + (string-upcase name) *last-go-to-def-string*)) + (let ((point (current-point))) + (push-buffer-mark (copy-mark point)) + (move-mark point m)))))))) + +(defparameter *source-file-indicator-defining-operators* ()) + +(defun define-source-file-indicator-defining-operators (name &rest operators) + (setf (getf *source-file-indicator-defining-operators* name) operators)) + +(defun get-source-file-indicator-defining-operators (thing) + (if (typep thing 'method) + '(defmethod) + (getf *source-file-indicator-defining-operators* thing))) + +(define-source-file-indicator-defining-operators 'class 'defclass) +(define-source-file-indicator-defining-operators 'type 'deftype) +(define-source-file-indicator-defining-operators 'function 'defun 'defmacro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::defppclapfunction) +(define-source-file-indicator-defining-operators 'ccl::constant 'defconstant) +(define-source-file-indicator-defining-operators 'variable 'defvar 'defparameter 'ccl::defstatic 'ccl::defglobal) +(define-source-file-indicator-defining-operators 'method-combination 'define-method-combination) +(define-source-file-indicator-defining-operators 'ccl::method-combination-evaluator 'ccl::define-method-combination-evaluator) +(define-source-file-indicator-defining-operators 'compiler-macro 'define-compiler-macro) +#+ppc32-target +(define-source-file-indicator-defining-operators 'ccl::ppc32-vinsn 'ccl::define-ppc32-vinsn) +#+ppc64-target +(define-source-file-indicator-defining-operators 'ccl::ppc64-vinsn 'ccl::define-ppc64-vinsn) +#+x8664-target +(define-source-file-indicator-defining-operators 'ccl::x8664-vinsn 'ccl::define-x8664-vinsn) + + +(defun match-definition-context-for-method (end-mark package indicator) + (let* ((specializers (openmcl-mop:method-specializers indicator)) + (qualifiers (openmcl-mop:method-qualifiers indicator))) + (block win + (with-mark ((work end-mark)) + (when qualifiers + (dotimes (i (length qualifiers)) + (unless (and (form-offset end-mark 1) + (progn + (move-mark work end-mark) + (form-offset work -1))) + (return-from win nil)) + (let* ((qualifier (ignore-errors + (let* ((*package* package)) + (values + (read-from-string (region-to-string + (region + work + end-mark)))))))) + (unless (member qualifier qualifiers) + (return-from win nil))))) + ;; end-mark is now either at end of last qualifier or + ;; after method name. Try to read the lambda list and + ;; match specializers. + (unless (and (form-offset end-mark 1) + (progn + (move-mark work end-mark) + (form-offset work -1))) + (return-from win nil)) + (multiple-value-bind (lambda-list error) + (ignore-errors + (let* ((*package* package)) + (values + (read-from-string (region-to-string + (region + work + end-mark)))))) + (unless (and (null error) + (consp lambda-list) + (ccl::proper-list-p lambda-list)) + (return-from win nil)) + (flet ((match-specializer (spec) + (when lambda-list + (let* ((arg (pop lambda-list))) + (typecase spec + (ccl::eql-specializer + (let* ((obj (openmcl-mop:eql-specializer-object spec))) + (and (ccl::proper-list-p arg) + (= 2 (length arg)) + (symbolp (pop arg)) + (ccl::proper-list-p (setq arg (car arg))) + (= (length arg) 2) + (eq (car arg) 'eql) + (eql (cadr arg) obj)))) + (class + (let* ((name (class-name spec))) + (or (if (eq name t) (eq arg t)) + (and (consp arg) + (symbolp (car arg)) + (consp (cdr arg)) + (null (cddr arg)) + (eq name (cadr arg))))))))))) + (dolist (spec specializers t) + (unless (match-specializer spec) + (return nil))))))))) + + + +;;; START and END delimit a function name that matches what we're looking +;;; for, PACKAGE is the buffer's package (or *PACKAGE*), and INDICATOR +;;; is either a symbol (FUNCTION, MACRO, etc) or a METHOD object. +(defun match-context-for-indicator (start end package indicator) + (declare (ignorable end)) + (with-mark ((op-start start) + (op-end start)) + (and (form-offset op-start -1) + (progn + (move-mark op-end op-start) + (form-offset op-end 1)) + (let* ((defining-operator + (ignore-errors + (let* ((*package* package)) + (values (read-from-string (region-to-string (region op-start op-end)))))))) + (memq + defining-operator + (get-source-file-indicator-defining-operators indicator))) + (or (not (typep indicator 'method)) + (match-definition-context-for-method end package indicator))))) + + +(defun match-definition-context (mark name indicator package) + (declare (ignorable name indicator)) + (pre-command-parse-check mark) + (when (valid-spot mark t) + (with-mark ((start mark) + (end mark)) + (and (form-offset end 1) + (progn + (move-mark start end) + (form-offset start -1)) + (eq name (ignore-errors + (let* ((*package* package)) + (values (read-from-string (region-to-string (region start end))))))) + (match-context-for-indicator start end package indicator))))) + +(defun find-definition-in-buffer (buffer name indicator) + (setf (hi::buffer-region-active buffer) nil) + (when (symbolp name) + (let* ((string (string name)) + (len (length string)) + (pattern (get-search-pattern (string name) :forward)) + (mark (copy-mark (buffer-start-mark buffer))) + (package (or + (find-package + (variable-value 'current-package :buffer buffer)) + *package*))) + (or + (loop + (let* ((won (find-pattern mark pattern))) + (unless won + (return)) + (when (match-definition-context mark name indicator package) + (backward-up-list mark) + (move-mark (buffer-point buffer) mark) + (return t)) + (unless (character-offset mark len) + (return)))) + (beep))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/filecoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/filecoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/filecoms.lisp (revision 8058) @@ -0,0 +1,909 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains file/buffer manipulating commands. +;;; + +(in-package :hemlock) + + + + +;;;; PROCESS-FILE-OPTIONS. + +(defvar *mode-option-handlers* () + "Do not modify this; use Define-File-Option instead.") + +(defvar *file-type-hooks* () + "Do not modify this; use Define-File-Type-Hook instead.") + +(defun trim-subseq (string start end) + (declare (simple-string string)) + (string-trim '(#\Space #\Tab) (subseq string start end))) + +;;; PROCESS-FILE-OPTIONS checks the first line of buffer for the file options +;;; indicator "-*-". IF it finds this, then it enters a do-file-options block. +;;; If any parsing errors occur while picking out options, we return from this +;;; block. Staying inside this function at this point, allows us to still set +;;; a major mode if no file option specified one. +;;; +;;; We also cater to old style mode comments: +;;; -*- Lisp -*- +;;; -*- Text -*- +;;; This kicks in if we find no colon on the file options line. +;;; +(defun process-file-options (buffer &optional + (pathname (buffer-pathname buffer))) + "Checks for file options and invokes handlers if there are any. If no + \"Mode\" mode option is specified, then this tries to invoke the appropriate + file type hook." + (let* ((string + (line-string (mark-line (buffer-start-mark buffer)))) + (found (search "-*-" string)) + (no-major-mode t) + (type (if pathname (pathname-type pathname)))) + (declare (simple-string string)) + (when found + (block do-file-options + (let* ((start (+ found 3)) + (end (search "-*-" string :start2 start))) + (unless end + (loud-message "No closing \"-*-\". Aborting file options.") + (return-from do-file-options)) + (cond + ((find #\: string :start start :end end) + (do ((opt-start start (1+ semi)) colon semi) + (nil) + (setq colon (position #\: string :start opt-start :end end)) + (unless colon + (loud-message "Missing \":\". Aborting file options.") + (return-from do-file-options)) + (setq semi (or (position #\; string :start colon :end end) end)) + (let* ((option (nstring-downcase + (trim-subseq string opt-start colon))) + (handler (assoc option *mode-option-handlers* + :test #'string=))) + (declare (simple-string option)) + (cond + (handler + (let ((result (funcall (cdr handler) buffer + (trim-subseq string (1+ colon) semi)))) + (when (string= option "mode") + (setq no-major-mode (not result))))) + (t (message "Unknown file option: ~S" option))) + (when (= semi end) (return nil))))) + (t + ;; Old style mode comment. + (setq no-major-mode nil) + (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=)) + buffer (trim-subseq string start end))))))) + (when (and no-major-mode type) + (let ((hook (assoc (string-downcase type) *file-type-hooks* + :test #'string=))) + (when hook (funcall (cdr hook) buffer type)))))) + + + + +;;;; File options and file type hooks. + +(defmacro define-file-option (name lambda-list &body body) + "Define-File-Option Name (Buffer Value) {Form}* + Defines a new file option to be user in the -*- line at the top of a file. + The body is evaluated with Buffer bound to the buffer the file has been read + into and Value to the string argument to the option." + (let ((name (string-downcase name))) + `(setf (cdr (or (assoc ,name *mode-option-handlers* :test #'string=) + (car (push (cons ,name nil) *mode-option-handlers*)))) + #'(lambda ,lambda-list ,@body)))) + +(define-file-option "Mode" (buffer str) + (let ((seen-major-mode-p nil) + (lastpos 0)) + (loop + (let* ((pos (position #\, str :start lastpos)) + (substr (trim-subseq str lastpos pos))) + (cond ((getstring substr *mode-names*) + (cond ((mode-major-p substr) + (when seen-major-mode-p + (loud-message + "Major mode already processed. Using ~S now." + substr)) + (setf seen-major-mode-p t) + (setf (buffer-major-mode buffer) substr)) + (t + (setf (buffer-minor-mode buffer substr) t)))) + (t + (loud-message "~S is not a defined mode -- ignored." substr))) + (unless pos + (return seen-major-mode-p)) + (setf lastpos (1+ pos)))))) + + +(defmacro define-file-type-hook (type-list (buffer type) &body body) + "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}* + Define some code to be evaluated when a file having one of the specified + Types is read by a file command. Buffer is bound to the buffer the + file is in, and Type is the actual type read." + (let ((fun (gensym)) (str (gensym))) + `(flet ((,fun (,buffer ,type) ,@body)) + (dolist (,str ',(mapcar #'string-downcase type-list)) + (setf (cdr (or (assoc ,str *file-type-hooks* :test #'string=) + (car (push (cons ,str nil) *file-type-hooks*)))) + #',fun))))) + +(define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy") + (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Pascal")) + +(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl" "cl") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Lisp")) + +(define-file-type-hook ("txt" "text" "tx") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Text")) + + + + +;;;; Support for file hacking commands: + +(defhvar "Pathname Defaults" + "This variable contains a pathname which is used to supply defaults + when we don't have anything better." + :value (pathname "gazonk.del")) + +(defhvar "Last Resort Pathname Defaults" + "This variable contains a pathname which is used to supply defaults when + we don't have anything better, but unlike \"Pathname Defaults\", this is + never set to some buffer's pathname." + :value (pathname "gazonk")) + +(defhvar "Last Resort Pathname Defaults Function" + "This variable contains a function that is called when a default pathname is + needed, the buffer has no pathname, and the buffer's name is not entirely + composed of alphanumerics. The default value is a function that simply + returns \"Last Resort Pathname Defaults\". The function must take a buffer + as an argument, and it must return some pathname." + :value #'(lambda (buffer) + (declare (ignore buffer)) + (merge-pathnames (value last-resort-pathname-defaults) + (value pathname-defaults)))) + +(defun buffer-default-pathname (buffer) + "Returns \"Buffer Pathname\" if it is bound. If it is not, and buffer's name + is composed solely of alphnumeric characters, then return a pathname formed + from the buffer's name. If the buffer's name has other characters in it, + then return the value of \"Last Resort Pathname Defaults Function\" called + on buffer." + (or (buffer-pathname buffer) + (if (every #'alphanumericp (the simple-string (buffer-name buffer))) + (merge-pathnames (make-pathname :name (buffer-name buffer)) + (value pathname-defaults)) + (funcall (value last-resort-pathname-defaults-function) buffer)))) + + +(defun pathname-to-buffer-name (pathname) + "Returns a simple-string using components from pathname." + (let ((pathname (pathname pathname))) + (concatenate 'simple-string + (file-namestring pathname) + " " + (directory-namestring pathname)))) + + + + +;;;; File hacking commands. + +(defcommand "Process File Options" (p) + "Reprocess this buffer's file options." + "Reprocess this buffer's file options." + (declare (ignore p)) + (process-file-options (current-buffer))) + +(defcommand "Ensure File Options Line" (p) + "Insert a default file options line at the beginning of the buffer, unless such a line already exists." + "Insert a default file options line at the beginning of the buffer, unless such a line already exists." + (declare (ignore p)) + (let* ((buffer (current-buffer)) + (string + (line-string (mark-line (buffer-start-mark buffer)))) + (found (search "-*-" string)) + (end (if found (search "-*-" string :start2 (+ found 3))))) + (unless end + (let* ((mode (buffer-major-mode buffer))) + (unless mode + ;; Try to derive the buffer's major mode from its pathname's + ;; type. + (let* ((pathname (buffer-pathname buffer)) + (type (if pathname (pathname-type pathname))) + (hook (if type + (assoc (string-downcase type) *file-type-hooks* + :test #'string=)))) + (when hook + (funcall (cdr hook) buffer type) + (setq mode (buffer-major-mode buffer))))) + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (if (string-equal mode "Lisp") + (let* ((package-name + (if (hemlock-bound-p 'current-package :buffer buffer) + (variable-value 'hemlock::current-package + :buffer buffer) + "CL-USER"))) + (insert-string + mark + (format nil ";;; -*- Mode: Lisp; Package: ~a -*-" package-name))) + (insert-string + mark + (format nil ";;; -*- Mode: ~a -*-" (or mode "Fundamental")))) + (insert-character mark #\NewLine)))) + (buffer-start (buffer-point buffer)))) + + + + + + + + + + + + + +(defcommand "Insert File" (p &optional pathname (buffer (current-buffer))) + "Inserts a file which is prompted for into the current buffer at the point. + The prefix argument is ignored." + "Inserts the file named by Pathname into Buffer at the point." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file :default (buffer-default-pathname buffer) + :prompt "Insert File: " + :help "Name of file to insert"))) + (point (buffer-point buffer)) + ;; start and end will be deleted by undo stuff + (start (copy-mark point :right-inserting)) + (end (copy-mark point :left-inserting)) + (region (region start end))) + (setv pathname-defaults pn) + (push-buffer-mark (copy-mark end)) + (read-file pn end) + (make-region-undo :delete "Insert File" region))) + +(defcommand "Write Region" (p &optional pathname) + "Writes the current region to a file. " + "Writes the current region to a file. " + (declare (ignore p)) + (let ((region (current-region)) + (pn (or pathname + (prompt-for-file :prompt "File to Write: " + :help "The name of the file to write the region to. " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil)))) + (write-file region pn) + (message "~A written." (namestring (truename pn))))) + + + + +;;;; Visiting and reverting files. + +(defcommand "Visit File" (p &optional pathname (buffer (current-buffer))) + "Replaces the contents of Buffer with the file Pathname. The prefix + argument is ignored. The buffer is set to be writable, so its region + can be deleted." + "Replaces the contents of the current buffer with the text in the file + which is prompted for. The prefix argument is, of course, ignored p times." + (declare (ignore p)) + (when (and (buffer-modified buffer) + (prompt-for-y-or-n :prompt "Buffer is modified, save it? ")) + (save-file-command () buffer)) + (let ((pn (or pathname + (prompt-for-file :prompt "Visit File: " + :must-exist nil + :help "Name of file to visit." + :default (buffer-default-pathname buffer))))) + (setf (buffer-writable buffer) t) + (read-buffer-file pn buffer) + (let ((n (pathname-to-buffer-name (buffer-pathname buffer)))) + (unless (getstring n *buffer-names*) + (setf (buffer-name buffer) n)) + (warn-about-visit-file-buffers buffer)))) + +(defun warn-about-visit-file-buffers (buffer) + (let ((buffer-pn (buffer-pathname buffer))) + (dolist (b *buffer-list*) + (unless (eq b buffer) + (let ((bpn (buffer-pathname b))) + (when (equal bpn buffer-pn) + (loud-message "Buffer ~A also contains ~A." + (buffer-name b) (namestring buffer-pn)) + (return))))))) + + +(defhvar "Revert File Confirm" + "If this is true, Revert File will prompt before reverting." + :value t) + +(defcommand "Revert File" (p) + "Unless in Save Mode, reads in the last saved version of the file in + the current buffer. When in Save Mode, reads in the last checkpoint or + the last saved version, whichever is more recent. An argument will always + force Revert File to use the last saved version. In either case, if the + buffer has been modified and \"Revert File Confirm\" is true, then Revert + File will ask for confirmation beforehand. An attempt is made to maintain + the point's relative position." + "With an argument reverts to the last saved version of the file in the + current buffer. Without, reverts to the last checkpoint or last saved + version, whichever is more recent." + (declare (ignore p)) + (let* ((doc (hi::buffer-document (current-buffer)))) + (when doc + (hi::revert-document doc))) + (clear-echo-area)) + +;;; REVERT-PATHNAME -- Internal +;;; +;;; If in Save Mode, return either the checkpoint pathname or the buffer +;;; pathname whichever is more recent. Otherwise return the buffer-pathname +;;; if it exists. If neither file exists, return NIL. +;;; +(defun revert-pathname (buffer) + (let* ((buffer-pn (buffer-pathname buffer)) + (buffer-pn-date (file-write-date buffer-pn)) + (checkpoint-pn (get-checkpoint-pathname buffer)) + (checkpoint-pn-date (and checkpoint-pn + (file-write-date checkpoint-pn)))) + (cond (checkpoint-pn-date + (if (> checkpoint-pn-date (or buffer-pn-date 0)) + (values checkpoint-pn t) + (values buffer-pn nil))) + (buffer-pn-date (values buffer-pn nil)) + (t (values nil nil))))) + + + + +;;;; Find file. + + +(defcommand "Old Find File" (p &optional pathname) + "Visit a file in its own buffer. + If the file is already in some buffer, select that buffer, + otherwise make a new buffer with the same name as the file and + read the file into it." + "Make a buffer containing the file Pathname current, creating a buffer + if necessary. The buffer is returned." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file + :prompt "Find File: " + :must-exist nil + :help "Name of file to read into its own buffer." + :default (buffer-default-pathname (current-buffer))))) + (buffer (find-file-buffer pn))) + (change-to-buffer buffer) + buffer)) + +(defcommand "Find File" (p &optional pathname) + "Visit a file in its own buffer. + If the file is already in some buffer, select that buffer, + otherwise make a new buffer with the same name as the file and + read the file into it." + "Make a buffer containing the file Pathname current, creating a buffer + if necessary. The buffer is returned." + (if pathname + (old-find-file-command p pathname) + (hi::open-document))) + + + +(defun find-file-buffer (pathname) + "Return a buffer assoicated with the file Pathname, reading the file into a + new buffer if necessary. The second value is T if we created a buffer, NIL + otherwise. If the file has already been read, we check to see if the file + has been modified on disk since it was read, giving the user various + recovery options." + (let* ((pathname (pathname pathname)) + (trial-pathname (or (probe-file pathname) + (merge-pathnames pathname (hemlock-ext:default-directory)))) + (found (find trial-pathname (the list *buffer-list*) + :key #'buffer-pathname :test #'equal))) + (cond ((not found) + (if (and (null (pathname-name trial-pathname)) + (null (pathname-type trial-pathname)) + (pathname-directory trial-pathname)) + ;; This looks like a directory -- make dired buffer + (dired-guts nil nil trial-pathname) + + (let* ((name (pathname-to-buffer-name trial-pathname)) + (found (getstring name *buffer-names*)) + (use (if found + (prompt-for-buffer + :prompt "Buffer to use: " + :help + "Buffer name in use; give another buffer name, or confirm to reuse." + :default found + :must-exist nil) + (make-buffer name))) + (buffer (if (stringp use) (make-buffer use) use))) + (when (and (buffer-modified buffer) + (prompt-for-y-or-n :prompt + "Buffer is modified, save it? ")) + (save-file-command () buffer)) + (read-buffer-file pathname buffer) + (values buffer (stringp use))))) + ((check-disk-version-consistent pathname found) + (values found nil)) + (t + (read-buffer-file pathname found) + (values found nil))))) + + +;;; Check-Disk-Version-Consistent -- Internal +;;; +;;; Check that Buffer contains a valid version of the file Pathname, +;;; harrassing the user if not. We return true if the buffer is O.K., and +;;; false if the file should be read. +;;; +(defun check-disk-version-consistent (pathname buffer) + (let ((ndate (file-write-date pathname)) + (odate (buffer-write-date buffer))) + (cond ((not (and ndate odate (/= ndate odate))) + t) + ((buffer-modified buffer) + (beep) + (clear-input) + (command-case (:prompt (list + "File has been changed on disk since it was read and you have made changes too!~ + ~%Read in the disk version of ~A? [Y] " (namestring pathname)) + :help + "The file in disk has been changed since Hemlock last saved it, meaning that + someone else has probably overwritten it. Since the version read into Hemlock + has been changed as well, the two versions may have inconsistent changes. If + this is the case, it would be a good idea to save your changes in another file + and compare the two versions. + + Type one of the following commands:") + ((:confirm :yes) + "Prompt for a file to write the buffer out to, then read in the disk version." + (write-buffer-file + buffer + (prompt-for-file + :prompt "File to save changes in: " + :help (list "Save buffer ~S to this file before reading ~A." + (buffer-name buffer) (namestring pathname)) + :must-exist nil + :default (buffer-default-pathname buffer))) + nil) + (:no + "Change to the buffer without reading the new version." + t) + (#\r + "Read in the new version, clobbering the changes in the buffer." + nil))) + (t + (not (prompt-for-yes-or-no :prompt + (list + "File has been changed on disk since it was read.~ + ~%Read in the disk version of ~A? " + (namestring pathname)) + :help + "Type Y to read in the new version or N to just switch to the buffer." + :default t)))))) + + +(defhvar "Read File Hook" + "These functions are called when a file is read into a buffer. Each function + must take two arguments -- the buffer the file was read into and whether the + file existed (non-nil) or not (nil).") + +(defun read-buffer-file (pathname buffer) + "Delete the buffer's region, and uses READ-FILE to read pathname into it. + If the file exists, set the buffer's write date to the file's; otherwise, + MESSAGE that this is a new file and set the buffer's write date to nil. + Move buffer's point to the beginning, set the buffer unmodified. If the + file exists, set the buffer's pathname to the probed pathname; else, set it + to pathname merged with DEFAULT-DIRECTORY. Set \"Pathname Defaults\" to the + same thing. Process the file options, and then invoke \"Read File Hook\"." + (setf (buffer-writable buffer) t) + (delete-region (buffer-region buffer)) + (let* ((pathname (pathname pathname)) + (probed-pathname (probe-file pathname)) + (hi::*current-buffer* buffer)) + (cond (probed-pathname + (read-file probed-pathname (buffer-point buffer)) + (setf (buffer-write-date buffer) (file-write-date probed-pathname))) + (t + (message "(New File)") + (setf (buffer-write-date buffer) nil))) + (buffer-start (buffer-point buffer)) + (setf (buffer-modified buffer) nil) + (let ((stored-pathname (or probed-pathname + (merge-pathnames pathname (hemlock-ext:default-directory))))) + (setf (buffer-pathname buffer) stored-pathname) + (setf (value pathname-defaults) stored-pathname) + (process-file-options buffer stored-pathname) + (invoke-hook read-file-hook buffer probed-pathname)))) + + + + +;;;; File writing. + +(defhvar "Add Newline at EOF on Writing File" + "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the + file when it ends at the end of a non-empty line. When set, this may be + :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and + inform the user. When nil, never add one and don't ask." + :value :ask-user) + +(defhvar "Keep Backup Files" + "When set, .BAK files will be saved upon file writing. This defaults to nil." + :value nil) + +(defhvar "Write File Hook" + "These functions are called when a buffer has been written. Each function + must take the buffer as an argument.") + +(defun write-buffer-file (buffer pathname) + "Write's buffer to pathname. This assumes pathname is somehow related to + the buffer's pathname, and if the buffer's write date is not the same as + pathname's, then this prompts the user for confirmation before overwriting + the file. This consults \"Add Newline at EOF on Writing File\" and + interacts with the user if necessary. This sets \"Pathname Defaults\", and + the buffer is marked unmodified. The buffer's pathname and write date are + updated, and the buffer is renamed according to the new pathname if possible. + This invokes \"Write File Hook\"." + (let ((buffer-pn (buffer-pathname buffer))) + (let ((date (buffer-write-date buffer)) + (file-date (when (probe-file pathname) (file-write-date pathname)))) + (when (and buffer-pn date file-date + (equal (make-pathname :version nil :defaults buffer-pn) + (make-pathname :version nil :defaults pathname)) + (/= date file-date)) + (unless (prompt-for-yes-or-no :prompt (list + "File has been changed on disk since it was read.~%Overwrite ~A anyway? " + (namestring buffer-pn)) + :help + "Type No to abort writing the file or Yes to overwrite the disk version." + :default nil) + (editor-error "Write aborted.")))) + (let ((val (value add-newline-at-eof-on-writing-file))) + (when val + (let ((end (buffer-end-mark buffer))) + (unless (start-line-p end) + (when (if (eq val :ask-user) + (prompt-for-y-or-n + :prompt + (list "~A~%File does not have a newline at EOF, add one? " + (buffer-name buffer)) + :default t) + t) + (insert-character end #\newline) + (message "Added newline at EOF.")))))) + (setv pathname-defaults pathname) + (write-file (buffer-region buffer) pathname) + (let ((tn (truename pathname))) + (message "~A written." (namestring tn)) + (setf (buffer-modified buffer) nil) + (unless (equal tn buffer-pn) + (setf (buffer-pathname buffer) tn)) + (setf (buffer-write-date buffer) (file-write-date tn)) + (let ((name (pathname-to-buffer-name tn))) + (unless (getstring name *buffer-names*) + (setf (buffer-name buffer) name))))) + (invoke-hook write-file-hook buffer)) + +(defcommand "Write File" (p &optional (buffer (current-buffer))) + "Writes the contents of Buffer, which defaults to the current buffer to + the file named by Pathname. The prefix argument is ignored." + "Prompts for a file to write the contents of the current Buffer to. + The prefix argument is ignored." + (declare (ignore p)) + (let* ((document (hi::buffer-document buffer))) + (when document + (hi::save-hemlock-document-as document)))) + +(defcommand "Save To File" (p &optional (buffer (current-buffer))) + "Writes the contents of Buffer, which defaults to the current buffer to + the file named by Pathname. The prefix argument is ignored." + "Prompts for a file to write the contents of the current Buffer to. + The prefix argument is ignored." + (declare (ignore p)) + (let* ((document (hi::buffer-document buffer))) + (when document + (hi::save-hemlock-document-to document)))) + +(defcommand "Save File" (p &optional (buffer (current-buffer))) + "Writes the contents of the current buffer to the associated file. If there + is no associated file, one is prompted for." + "Writes the contents of the current buffer to the associated file." + (declare (ignore p)) + (let* ((document (hi::buffer-document buffer))) + (when document + (when (buffer-modified buffer) + (hi::save-hemlock-document document))))) + +(defhvar "Save All Files Confirm" + "When non-nil, prompts for confirmation before writing each modified buffer." + :value t) + +(defcommand "Save All Files" (p) + "Saves all modified buffers in their associated files. + If a buffer has no associated file it is ignored even if it is modified.." + "Saves each modified buffer that has a file." + (declare (ignore p)) + (let ((saved-count 0)) + (dolist (b *buffer-list*) + (let ((pn (buffer-pathname b)) + (name (buffer-name b))) + (when + (and (buffer-modified b) + pn + (or (not (value save-all-files-confirm)) + (prompt-for-y-or-n + :prompt (list + "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~ + Y or N: " + (string= (pathname-to-buffer-name pn) name) + name (namestring pn)) + :default t))) + (write-buffer-file b pn) + (incf saved-count)))) + (if (zerop saved-count) + (message "No files were saved.") + (message "Saved ~S file~:P." saved-count)))) + +(defcommand "Save All Files and Exit" (p) + "Save all modified buffers in their associated files and exit; + a combination of \"Save All Files\" and \"Exit Hemlock\"." + "Do a save-all-files-command and then an exit-hemlock." + (declare (ignore p)) + (save-all-files-command ()) + (exit-hemlock)) + +(defcommand "Backup File" (p) + "Write the buffer to a file without changing the associated name." + "Write the buffer to a file without changing the associated name." + (declare (ignore p)) + (let ((file (prompt-for-file :prompt "Backup to File: " + :help + "Name of a file to backup the current buffer in." + :default (buffer-default-pathname (current-buffer)) + :must-exist nil))) + (write-file (buffer-region (current-buffer)) file) + (message "~A written." (namestring (truename file))))) + + + + +;;;; Buffer hacking commands: + +(defvar *buffer-history* () + "A list of buffers, in order from most recently to least recently selected.") + +(defun previous-buffer () + "Returns some previously selected buffer that is not the current buffer. + Returns nil if no such buffer exists." + (let ((b (car *buffer-history*))) + (or (if (eq b (current-buffer)) (cadr *buffer-history*) b) + (find-if-not #'(lambda (x) + (or (eq x (current-buffer)) + (eq x *echo-area-buffer*))) + (the list *buffer-list*))))) + +;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by +;;; "Circulate Buffers" even if it has never been before. +;;; +(defun add-buffer-history-hook (buffer) + (let ((ele (last *buffer-history*)) + (new-stuff (list buffer))) + (if ele + (setf (cdr ele) new-stuff) + (setf *buffer-history* new-stuff)))) +;;; +(add-hook make-buffer-hook 'add-buffer-history-hook) + +;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer. +;;; +(defun delete-buffer-history-hook (buffer) + (setq *buffer-history* (delq buffer *buffer-history*))) +;;; +(add-hook delete-buffer-hook 'delete-buffer-history-hook) + +(defun change-to-buffer (buffer) + "Switches to buffer in the current window maintaining *buffer-history*." + (setq *buffer-history* + (cons (current-buffer) (delq (current-buffer) *buffer-history*))) + (setf (current-buffer) buffer) + (setf (window-buffer (current-window)) buffer)) + +(defun delete-buffer-if-possible (buffer) + "Deletes a buffer if at all possible. If buffer is the only buffer, other + than the echo area, signals an error. Otherwise, find some recently current + buffer, and make all of buffer's windows display this recent buffer. If + buffer is current, set the current buffer to be this recently current + buffer." + (let ((new-buf (flet ((frob (b) + (or (eq b buffer) (eq b *echo-area-buffer*)))) + (or (find-if-not #'frob (the list *buffer-history*)) + (find-if-not #'frob (the list *buffer-list*)))))) + (unless new-buf + (error "Cannot delete only buffer ~S." buffer)) + (dolist (w (buffer-windows buffer)) + (setf (window-buffer w) new-buf)) + (when (eq buffer (current-buffer)) + (setf (current-buffer) new-buf))) + (delete-buffer buffer)) + + +(defvar *create-buffer-count* 0) + +(defcommand "Create Buffer" (p &optional buffer-name) + "Create a new buffer. If a buffer with the specified name already exists, + then go to it." + "Create or go to the buffer with the specifed name." + (declare (ignore p)) + (let ((name (or buffer-name + (prompt-for-buffer :prompt "Create Buffer: " + :default-string + (format nil "Buffer ~D" + (incf *create-buffer-count*)) + :must-exist nil)))) + (if (bufferp name) + (change-to-buffer name) + (change-to-buffer (or (getstring name *buffer-names*) + (make-buffer name)))))) + +(defcommand "Select Buffer" (p) + "Select a different buffer. + The buffer to go to is prompted for." + "Select a different buffer. + The buffer to go to is prompted for." + (declare (ignore p)) + (let ((buf (prompt-for-buffer :prompt "Select Buffer: " + :default (previous-buffer)))) + (when (eq buf *echo-area-buffer*) + (editor-error "Cannot select Echo Area buffer.")) + (change-to-buffer buf))) + + +(defvar *buffer-history-ptr* () + "The successively previous buffer to the current buffer.") + +(defcommand "Select Previous Buffer" (p) + "Select the buffer selected before this one. If called repeatedly + with an argument, select the successively previous buffer to the + current one leaving the buffer history as it is." + "Select the buffer selected before this one." + (if p + (circulate-buffers-command nil) + (let ((b (previous-buffer))) + (unless b (editor-error "No previous buffer.")) + (change-to-buffer b) + ;; + ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing + ;; "Select Previous Buffer". + (setf *buffer-history-ptr* (cddr *buffer-history*)) + (setf (last-command-type) :previous-buffer)))) + +(defcommand "Circulate Buffers" (p) + "Advance through buffer history, selecting successively previous buffer." + "Advance through buffer history, selecting successively previous buffer." + (declare (ignore p)) + (if (and (eq (last-command-type) :previous-buffer) + *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER. + (let ((b (pop *buffer-history-ptr*))) + (when (eq b (current-buffer)) + (setf b (pop *buffer-history-ptr*))) + (unless b + (setf *buffer-history-ptr* + (or (cdr *buffer-history*) *buffer-history*)) + (setf b (car *buffer-history*))) + (setf (current-buffer) b) + (setf (window-buffer (current-window)) b) + (setf (last-command-type) :previous-buffer)) + (select-previous-buffer-command nil))) + + +(defcommand "Buffer Not Modified" (p) + "Make the current buffer not modified." + "Make the current buffer not modified." + (declare (ignore p)) + (setf (buffer-modified (current-buffer)) nil) + (message "Buffer marked as unmodified.")) + + + +(defcommand "Set Buffer Read-Only" (p) + "Toggles the read-only flag for the current buffer." + "Toggles the read-only flag for the current buffer." + (declare (ignore p)) + (let ((buffer (current-buffer))) + (message "Buffer ~S is now ~:[read-only~;writable~]." + (buffer-name buffer) + (setf (buffer-writable buffer) (not (buffer-writable buffer)))))) + +(defcommand "Set Buffer Writable" (p) + "Make the current buffer modifiable." + "Make the current buffer modifiable." + (declare (ignore p)) + (let ((buffer (current-buffer))) + (setf (buffer-writable buffer) t) + (message "Buffer ~S is now writable." (buffer-name buffer)))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + +(defun universal-time-to-string (ut) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time ut) + (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D" + day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec") + (1- month)) + (rem year 100) + hour min sec))) + + + + + + +;;;; Window hacking commands: + + + +(defcommand "Split Window" (p) + "Make a new window by splitting the current window. + The new window is made the current window and displays starting at + the same place as the current window." + "Create a new window which displays starting at the same place + as the current window." + (declare (ignore p)) + (let ((new (make-window (window-display-start (current-window))))) + (unless new (editor-error "Could not make a new window.")) + (setf (current-window) new))) + + + + + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/files.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/files.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/files.lisp (revision 8058) @@ -0,0 +1,113 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock File manipulation functions. +;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan. +;;; Unhacked by Gilbert Baumann. +;;; + +(in-package :hemlock-internals) + + + +;;;; Utility functions. + +;; FIND-CHAR-FROM-SAP was here, deleted --GB + + + +;;; Read-File: + +(defun read-file (pathname mark) + "Inserts the contents of the file named by Pathname at the Mark." + (with-mark ((mark mark :left-inserting)) + (let* ((first-line (mark-line mark)) + (buffer (line-%buffer first-line))) + (modifying-buffer buffer) + (cocoa-read-file pathname mark buffer)))) + + + + + +;;; Write-File: + +(defun write-file (region pathname &key append + (keep-backup (value hemlock::keep-backup-files)) + access) + "Writes the characters in region to the file named by pathname. This writes + region using a stream opened with :if-exists :rename-and-delete, unless + either append or keep-backup is supplied. If append is supplied, this + writes the file opened with :if-exists :append. If keep-backup is supplied, + this writes the file opened with :if-exists :rename. This signals an error + if both append and keep-backup are supplied. Access is an implementation + dependent value that is suitable for setting pathname's access or protection + bits." + (declare (ignorable access)) + (let ((if-exists-action (cond ((and keep-backup append) + (error "Cannot supply non-nil values for ~ + both keep-backup and append.")) + (keep-backup :rename) + (append :append) + (t :rename-and-delete)))) + (with-open-file (file pathname :direction :output + :element-type 'base-char + :if-exists if-exists-action) + (close-line) + (fast-write-file region file)) + ;; ### access is always ignored + #+NIL + (when access + (multiple-value-bind + (winp code) + ;; Must do a TRUENAME in case the file has never been written. + ;; It may have Common Lisp syntax that Unix can't handle. + ;; If this is ever moved to the beginning of this function to use + ;; Unix CREAT to create the file protected initially, they TRUENAME + ;; will signal an error, and LISP::PREDICT-NAME will have to be used. + (unix:unix-chmod (namestring (truename pathname)) access) + (unless winp + (error "Could not set access code: ~S" + (unix:get-unix-error-msg code))))))) + +(defun fast-write-file (region file) + (let* ((start (region-start region)) + (start-line (mark-line start)) + (start-charpos (mark-charpos start)) + (end (region-end region)) + (end-line (mark-line end)) + (end-charpos (mark-charpos end))) + (if (eq start-line end-line) + ;; just one line (fragment) + (write-string (line-chars start-line) file + :start start-charpos :end end-charpos) + ;; multiple lines + (let* ((first-length (- (line-length start-line) start-charpos)) + (length (+ first-length end-charpos 1))) + ;; count number of octets to be written + (do ((line (line-next start-line) (line-next line))) + ((eq line end-line)) + (incf length (1+ (line-length line)))) + ;; + (macrolet ((chars (line) + `(line-%chars ,line))) + (write-sequence (chars start-line) file :start start-charpos :end (+ start-charpos first-length)) + (write-char #\newline file) + (let ((offset (1+ first-length))) + (do ((line (line-next start-line) + (line-next line))) + ((eq line end-line)) + (let ((end (+ offset (line-length line)))) + (write-sequence (chars line) file :start 0 :end (- end offset)) + (write-char #\newline file) + (setf offset (1+ end)))) + (unless (zerop end-charpos) + (write-sequence (chars end-line) file :start 0 :end end-charpos)))))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/fill.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/fill.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/fill.lisp (revision 8058) @@ -0,0 +1,736 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains the implementation of Auto Fill Mode. Also, +;;; paragraph and region filling stuff is here. +;;; + +(in-package :hemlock) + + +;;; Fill Mode should be defined with some transparent bindings (linefeed and +;;; return) but with some that are not (space), so until this is possible, we +;;; kludge this effect by altering Auto Fill Linefeed and Auto Fill Return. +(defmode "Fill") + + + +;;;; -- Variables -- + +(defhvar "Fill Column" + "Used to determine at what column to force text to the next line." + :value 75) + +(defhvar "Fill Prefix" + "String to put before each line when filling." + :value ()) + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\". However, if there is a fill prefix, it is still preferred." + :value nil) + + + +;;;; -- New Attributes -- + +(defattribute "Paragraph Delimiter" + "is a character that delimits a paragraph by beginning a line." + '(mod 2) + 0) + + +;;; (setf (character-attribute :paragraph-delimiter #\@) 1) +;;; (setf (character-attribute :paragraph-delimiter #\\) 1) +;;; (setf (character-attribute :paragraph-delimiter #\/) 1) +;;; (setf (character-attribute :paragraph-delimiter #\-) 1) +;;; (setf (character-attribute :paragraph-delimiter #\') 1) +;;; (setf (character-attribute :paragraph-delimiter #\.) 1) +;;; These are useful for making certain text formatting command lines +;;; delimit paragraphs. Anyway, this is what EMACS documentation states, +;;; and #\' and #\. are always paragraph delimiters (don't ask me). + +(setf (character-attribute :paragraph-delimiter #\space) 1) +(setf (character-attribute :paragraph-delimiter #\linefeed) 1) +(setf (character-attribute :paragraph-delimiter + #+CMU #\formfeed #+(or sbcl EXCL CLISP OpenMCL) #\page) 1) +(setf (character-attribute :paragraph-delimiter #\tab) 1) +(setf (character-attribute :paragraph-delimiter #\newline) 1) + + + +(defattribute "Sentence Closing Char" + "is a delimiting character that may follow a sentence terminator + such as quotation marks and parentheses." + '(mod 2) + 0) + + +(setf (character-attribute :sentence-closing-char #\") 1) +(setf (character-attribute :sentence-closing-char #\') 1) +(setf (character-attribute :sentence-closing-char #\)) 1) +(setf (character-attribute :sentence-closing-char #\]) 1) +(setf (character-attribute :sentence-closing-char #\|) 1) +(setf (character-attribute :sentence-closing-char #\>) 1) + + +;;;; -- Commands -- + +(defcommand "Auto Fill Mode" (p) + "Breaks lines between words at the right margin. + A positive argument turns Fill mode on, while zero or a negative + argument turns it off. With no arguments, it is toggled. When space + is typed, text that extends past the right margin is put on the next + line. The right column is controlled by Fill Column." + "Determine if in Fill mode or not and set the mode accordingly." + (setf (buffer-minor-mode (current-buffer) "Fill") + (if p + (plusp p) + (not (buffer-minor-mode (current-buffer) "Fill"))))) + + +;;; This command should not have a transparent binding since it sometimes does +;;; not insert a spaces, and transparency would propagate to "Self Insert". +(defcommand "Auto Fill Space" (p) + "Insert space and a CRLF if text extends past margin. + If arg is 0, then may break line but will not insert the space. + If arg is positive, then inserts that many spaces without filling." + "Insert space and CRLF if text extends past margin. + If arg is 0, then may break line but will not insert the space. + If arg is positive, then inserts that many spaces without filling." + (let ((point (current-point))) + (check-fill-prefix (value fill-prefix) (value fill-column) point) + (cond ((and p (plusp p)) + (dotimes (x p) (insert-character point #\space))) + ((and p (zerop p)) (%auto-fill-space point nil)) + (t (%auto-fill-space point t))))) + + +(defcommand "Auto Fill Linefeed" (p) + "Does an immediate CRLF inserting Fill Prefix if it exists." + "Does an immediate CRLF inserting Fill Prefix if it exists." + (let ((point (current-point))) + (check-fill-prefix (value fill-prefix) (value fill-column) point) + (%auto-fill-space point nil) + ;; The remainder of this function should go away when + ;; transparent key bindings are per binding instead of + ;; per mode. + (multiple-value-bind (command t-bindings) + (get-command #k"Linefeed" :current) + (declare (ignore command)) ;command is this one, so don't invoke it + (dolist (c t-bindings) (funcall *invoke-hook* c p))) + (indent-new-line-command nil))) + + + +(defcommand "Auto Fill Return" (p) + "Does an Auto Fill Space with a prefix argument of 0 + followed by a newline." + "Does an Auto Fill Space with a prefix argument of 0 + followed by a newline." + (let ((point (current-point))) + (check-fill-prefix (value fill-prefix) (value fill-column) point) + (%auto-fill-space point nil) + ;; The remainder of this function should go away when + ;; transparent key bindings are per binding instead of + ;; per mode. + (multiple-value-bind (command t-bindings) + (get-command #k"Return" :current) + (declare (ignore command)) ;command is this one, so don't invoke it + (dolist (c t-bindings) (funcall *invoke-hook* c p))) + (new-line-command nil))) + + + +(defcommand "Fill Paragraph" (p) + "Fill this or next paragraph. + Point stays fixed, but text may move past it due to filling. + A paragraph is delimited by a blank line, a line beginning with a + special character (@,\,-,',and .), or it is begun with a line with at + least one whitespace character starting it. Prefixes are ignored or + skipped over before determining if a line starts or delimits a + paragraph." + "Fill this or next paragraph. + Point stays fixed, but text may move past it due to filling." + (let* ((prefix (value fill-prefix)) + (prefix-len (length prefix)) + (column (if p (abs p) (value fill-column))) + (point (current-point))) + (with-mark ((m point)) + (let ((paragraphp (paragraph-offset m 1))) + (unless (or paragraphp + (and (last-line-p m) + (end-line-p m) + (not (blank-line-p (mark-line m))))) + (editor-error)) + ;; + ;; start and end get deleted by the undo cleanup function + (let ((start (copy-mark m :right-inserting)) + (end (copy-mark m :left-inserting))) + (%fill-paragraph-start start prefix prefix-len) + (let* ((region (region start end)) + (undo-region (copy-region region))) + (fill-region region prefix column) + (make-region-undo :twiddle "Fill Paragraph" region undo-region))))))) + + +(defcommand "Fill Region" (p) + "Fill text from point to mark." + "Fill text from point to mark." + (let* ((region (current-region)) + (prefix (value fill-prefix)) + (column (if p (abs p) (value fill-column)))) + (check-fill-prefix prefix column (current-point)) + (fill-region-by-paragraphs region prefix column))) + + + +(defcommand "Set Fill Column" (p) + "Set Fill Column to current column or argument. + If argument is provided use its absolute value." + "Set Fill Column to current column or argument. + If argument is provided use its absolute value." + (let ((new-column (or (and p (abs p)) + (mark-column (current-point))))) + (defhvar "Fill Column" "This buffer's fill column" + :value new-column :buffer (current-buffer)) + (message "Fill Column = ~D" new-column))) + + +(defcommand "Set Fill Prefix" (p) + "Define Fill Prefix from the current line. + All of the current line up to point is the prefix. This may be + turned off by placing point at the beginning of a line when setting." + "Define Fill Prefix from the current line. + All of the current line up to point is the prefix. This may be + turned off by placing point at the beginning of a line when setting." + (declare (ignore p)) + (let ((point (current-point))) + (with-mark ((mark point)) + (line-start mark) + (let ((val (if (mark/= mark point) (region-to-string (region mark point))))) + (defhvar "Fill Prefix" "This buffer's fill prefix" + :value val :buffer (current-buffer)) + (message "Fill Prefix now ~:[empty~;~:*~S~]" val))))) + +(declaim (optimize (speed 2))); turn off byte compilation. + +;;;; -- Auto Filling -- + +;;; %AUTO-FILL-SPACE takes a point and an argument indicating +;;; whether it should insert a space or not. If point is past Fill +;;; Column then text is filled. Usually the else clause of the if +;;; will be executed. If the then clause is executed, then the first +;;; branch of the COND will usually be executed. The first branch +;;; handles the case of the end of a word extending past Fill Column +;;; while the second handles whitespace preceded by non-whitespace +;;; extending past the Fill Column. The last branch is for those who +;;; like to whitespace out a blank line. + +(defun %auto-fill-space (point insertp) + "Insert space, but CRLF if text extends past margin. + If arg is 0, then may break line but will not insert the space. + If arg is positive, then inserts that many spaces without filling." + (if (> (mark-column point) (value fill-column)) + (with-mark ((mark1 point :left-inserting)) + (let ((not-all-blank (reverse-find-attribute mark1 :whitespace #'zerop)) + (prefix (value fill-prefix)) + (column (value fill-column))) + (cond ((and not-all-blank (mark= point mark1)) + (%auto-fill-word-past-column point mark1 insertp prefix column)) + ((and not-all-blank (same-line-p mark1 point)) + (delete-region (region mark1 point)) + (if (> (mark-column point) column) + (%auto-fill-word-past-column point mark1 insertp prefix column) + (%filling-set-next-line point nil prefix))) + (t + (line-start mark1 (mark-line point)) + (delete-region (region mark1 point)) + (%filling-set-next-line point nil prefix))))) + (if insertp (insert-character point #\space)))) + + + +;;; %AUTO-FILL-WORD-PAST-COLUMN takes a point, a second mark that is +;;; mark= at the end of some word, and an indicator of whether a space +;;; should be inserted or not. First, point is moved before the previous +;;; "word." If the word is effectively the only word on the line, it +;;; should not be moved down to the next line as it will leave a blank +;;; line. The third branch handles when the typing began in the middle of +;;; some line (that is, right in front of some word). Note that the else +;;; clause is the usual case. + +(defun %auto-fill-word-past-column (point mark1 insertp prefix column) + (let ((point-moved-p (reverse-find-attribute point :whitespace))) + (with-mark ((mark2 point :left-inserting)) + (cond ((or (not point-moved-p) + (%auto-fill-blank-before-p point prefix)) + (move-mark point mark1) + (%filling-set-next-line point nil prefix)) + ((%auto-fill-line-as-region-p point mark2 column) + (if (and insertp + (not (or (end-line-p mark1) + (whitespace-attribute-p (next-character mark1))))) + (insert-character mark1 #\space)) + (auto-fill-line-as-region point (move-mark mark2 point) prefix column) + (move-mark point mark1) + (if (and insertp (end-line-p point)) + (insert-character point #\space))) + ((not (or (end-line-p mark1) + (whitespace-attribute-p (next-character mark1)))) + (insert-character mark1 #\space) + (%filling-set-next-line point nil prefix) + (mark-after point) + (%auto-fill-clean-previous-line mark1 mark2)) + (t + (%filling-set-next-line point insertp prefix) + (%auto-fill-clean-previous-line mark1 mark2)))))) + + + +;;; AUTO-FILL-LINE-AS-REGION basically grabs a line as a region and fills +;;; it. However, it knows about comments and makes auto filling a comment +;;; line as a region look the same as a typical "back up a word and break +;;; the line." When there is a comment, then region starts where the +;;; comment starts instead of the beginning of the line, but the presence +;;; of a prefix overrides all this. + +(defun auto-fill-line-as-region (point mark prefix column) + (let* ((start (value comment-start)) + (begin (value comment-begin)) + (end (value comment-end))) + (line-start mark) + (cond ((and (not prefix) start (to-line-comment mark start)) + (fill-region (region mark (line-end point)) + (gen-comment-prefix mark start begin) + column) + (when end + (line-start point) + (do () + ((mark>= mark point)) + (if (not (to-comment-end mark end)) (insert-string mark end)) + (line-offset mark 1 0)))) + (t (fill-region (region mark (line-end point)) prefix column))))) + + + +(defun %auto-fill-blank-before-p (point prefix) + "is true if whitespace only precedes point except for the prefix." + (or (blank-before-p point) + (with-mark ((temp point)) + (reverse-find-attribute temp :whitespace #'zerop) + (<= (mark-column temp) (length prefix))))) + + + +;;; %AUTO-FILL-LINE-AS-REGION-P determines if the line point and mark2 +;;; sit on is so long that it might as well be filled as if it were a +;;; region. Mark2 is mark= to point at the beginning of the last word on +;;; the line and is then moved over the whitespace before point. If the +;;; word end prior the last word on the line is on the same line and not +;;; before column, then fill the line as a region. + +(defun %auto-fill-line-as-region-p (point mark2 column) + (reverse-find-attribute mark2 :whitespace #'zerop) + (and (same-line-p mark2 point) + (> (mark-column mark2) column))) + + + +(defun %auto-fill-clean-previous-line (mark1 mark2) + (when (line-offset mark1 -1) + (line-end mark1) + (move-mark mark2 mark1) + (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) + (same-line-p mark1 mark2)) + (line-start mark1 (mark-line mark2))) + (delete-region (region mark1 mark2)))) + + + +;;; %FILLING-SET-NEXT-LINE gets a new blank line and sets it up with the +;;; prefix and places the point correctly. The argument point must alias +;;; (current-point). + +(defun %filling-set-next-line (point insertp prefix) + (cond ((and (value auto-fill-space-indent) (not prefix)) + (indent-new-comment-line-command nil)) + (t (new-line-command nil) + (if prefix (insert-string point prefix)))) + (if (not (find-attribute point :whitespace)) (line-end point)) + (if insertp (insert-character point #\space))) + + + +;;;; -- Paragraph Filling -- + + +;;; %FILL-PARAGRAPH-START takes a mark that has just been moved +;;; forward over some paragraph. After moving to the beginning of it, we +;;; place the mark appropriately for filling the paragraph as a region. + +(defun %fill-paragraph-start (mark prefix prefix-len) + (paragraph-offset mark -1) + (skip-prefix-if-here mark prefix prefix-len) + (if (text-blank-line-p mark) + (line-offset mark 1 0) + (line-start mark))) + + + +;;;; -- Region Filling -- + + +;;; FILL-REGION-BY-PARAGRAPHS finds paragraphs and uses region filling +;;; primitives to fill them. Tmark2 is only used for the first paragraph; we +;;; need a mark other than start in case start is in the middle of a paragraph +;;; instead of between two. +;;; +(defun fill-region-by-paragraphs (region &optional + (prefix (value fill-prefix)) + (column (value fill-column))) + "Finds paragraphs in region and fills them as distinct regions using + FILL-REGION." + (with-mark ((start (region-start region) :left-inserting)) + (with-mark ((tmark1 start :left-inserting) + (tmark2 start :left-inserting)) ;only used for first para. + (let ((region (region (copy-mark (region-start region)) ;deleted by undo. + (copy-mark (region-end region)))) + (undo-region (copy-region region)) + (end (region-end region)) + (prefix-len (length prefix)) + (paragraphp (paragraph-offset tmark1 1))) + (when paragraphp + (%fill-paragraph-start (move-mark tmark2 tmark1) prefix prefix-len) + (if (mark>= tmark2 start) (move-mark start tmark2)) + (cond ((mark>= tmark1 end) + (fill-region-aux start end prefix prefix-len column)) + (t + (fill-region-aux start tmark1 prefix prefix-len column) + (do ((paragraphp (mark-paragraph start tmark1) + (mark-paragraph start tmark1))) + ((not paragraphp)) + (if (mark> start end) + (return) + (cond ((mark>= tmark1 end) + (fill-region-aux start end prefix + prefix-len column) + (return)) + (t (fill-region-aux start tmark1 + prefix prefix-len column)))))))) + (make-region-undo :twiddle "Fill Region" region undo-region))))) + +(defun fill-region (region &optional + (prefix (value fill-prefix)) + (column (value fill-column))) + "Fills a region using the given prefix and column." + (let ((prefix (if (and prefix (string= prefix "")) () prefix))) + (with-mark ((start (region-start region) :left-inserting)) + (check-fill-prefix prefix column start) + (fill-region-aux start (region-end region) + prefix (length prefix) column)))) + + + +;;; FILL-REGION-AUX grinds over a region between fill-mark and +;;; end-mark deleting blank lines and filling lines. For each line, the +;;; extra whitespace between words is collapsed to one space, and at the +;;; end and beginning of the line it is deleted. We do not return after +;;; realizing that fill-mark is after end-mark if the line needs to be +;;; broken; it may be the case that there are several filled line lengths +;;; of material before end-mark on the current line. + +(defun fill-region-aux (fill-mark end-mark prefix prefix-len column) + (if (and (start-line-p fill-mark) prefix) + (fill-region-prefix-line fill-mark prefix prefix-len)) + (with-mark ((mark1 fill-mark :left-inserting) + (cmark fill-mark :left-inserting)) + (do ((collapse-p t)) + (nil) + (line-end fill-mark) + (line-start (move-mark mark1 fill-mark)) + (skip-prefix-if-here mark1 prefix prefix-len) + (cond ((mark>= fill-mark end-mark) + (if (mark= fill-mark end-mark) + (fill-region-clear-eol fill-mark)) + (cond ((> (mark-column end-mark) column) + (when collapse-p + (fill-region-collapse-whitespace cmark end-mark) + (setf collapse-p nil)) + (fill-region-break-line fill-mark prefix + prefix-len end-mark column)) + (t (return)))) + ((blank-after-p mark1) + (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len) + (cond ((mark< fill-mark end-mark) + (if prefix + (fill-region-prefix-line fill-mark prefix prefix-len)) + (fill-region-clear-bol fill-mark) + (move-mark cmark fill-mark)) + (t (return))) + (setf collapse-p t)) + (t (fill-region-clear-eol fill-mark) + (if collapse-p (fill-region-collapse-whitespace cmark fill-mark)) + (cond ((> (mark-column fill-mark) column) + (fill-region-break-line fill-mark prefix + prefix-len end-mark column) + (setf collapse-p nil)) + (t (fill-region-get-next-line fill-mark column + prefix prefix-len end-mark) + (move-mark cmark fill-mark) + (setf collapse-p t)))))) + (move-mark fill-mark end-mark))) + + + +;;; FILL-REGION-BREAK-LINE breaks lines as close to the low side +;;; column as possible. The first branch handles a word lying across +;;; column while the second takes care of whitespace passing column. If +;;; FILL-REGION-WORD-PAST-COLUMN encountered a single word stretching over +;;; column, it would leave an extra opened line that needs to be cleaned up +;;; or filled up. + +(defun fill-region-break-line (fill-mark prefix prefix-length + end-mark column) + (with-mark ((mark1 fill-mark :left-inserting)) + (move-to-column mark1 column) + (cond ((not (whitespace-attribute-p (next-character mark1))) + (if (not (find-attribute mark1 :whitespace)) + (line-end mark1)) + (move-mark fill-mark mark1) + (if (eq (fill-region-word-past-column fill-mark mark1 prefix) + :handled-oversized-word) + (if (mark>= fill-mark end-mark) + (delete-characters (line-start fill-mark) + prefix-length) + (delete-characters fill-mark 1)))) + (t (move-mark fill-mark mark1) + (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) + (same-line-p mark1 fill-mark)) + (line-start mark1 (mark-line fill-mark))) + ;; forward find must move mark because of cond branch we are in. + (find-attribute fill-mark :whitespace #'zerop) + (unless (same-line-p mark1 fill-mark) + (line-end fill-mark (mark-line mark1))) + (delete-region (region mark1 fill-mark)) + (insert-character fill-mark #\newline) + (if prefix (insert-string fill-mark prefix)))))) + + + +;;; FILL-REGION-WORD-PAST-COLUMN takes a point and a second mark that +;;; is mark= at the end of some word. First, point is moved before the +;;; previous "word." If the word is effectively the only word on the line, +;;; it should not be moved down to the next line as it will leave a blank +;;; line. + +(defun fill-region-word-past-column (point mark1 prefix) + (with-mark ((mark2 (copy-mark point :left-inserting))) + (let ((point-moved-p (reverse-find-attribute point :whitespace)) + (hack-for-fill-region :handled-normal-case)) + (cond ((or (not point-moved-p) + (%auto-fill-blank-before-p point prefix)) + (setf hack-for-fill-region :handled-oversized-word) + (move-mark point mark1) + (fill-region-set-next-line point prefix)) + (t (fill-region-set-next-line point prefix) + (%auto-fill-clean-previous-line mark1 mark2))) + hack-for-fill-region))) + +(defun fill-region-set-next-line (point prefix) + (insert-character point #\newline) + (if prefix (insert-string point prefix)) + (if (not (find-attribute point :whitespace)) (line-end point))) + + + +;;; FILL-REGION-GET-NEXT-LINE gets another line when the current one +;;; is short of the fill column. It cleans extraneous whitespace from the +;;; beginning of the next line to fill. To save typical redisplay the +;;; length of the first word is added to the ending column of the current +;;; line to see if it extends past the fill column; if it does, then the +;;; fill-mark is left on the new line instead of merging the new line with +;;; the current one. The fill-mark is left after a prefix (if there is one) +;;; on a new line, before the first word brought up to the current line, or +;;; after the end mark. + +(defun fill-region-get-next-line (fill-mark column prefix prefix-len end-mark) + (let ((prev-end-pos (mark-column fill-mark)) + (two-spaces-p (fill-region-insert-two-spaces-p fill-mark))) + (with-mark ((tmark fill-mark :left-inserting)) + (fill-region-find-next-line fill-mark prefix prefix-len end-mark) + (move-mark tmark fill-mark) + (cond ((mark< fill-mark end-mark) + (skip-prefix-if-here tmark prefix prefix-len) + (fill-region-clear-bol tmark) + (let ((beginning-pos (mark-column tmark))) + (find-attribute tmark :whitespace) + (cond ((> (+ prev-end-pos (if two-spaces-p 2 1) + (- (mark-column tmark) beginning-pos)) + column) + (if prefix + (fill-region-prefix-line fill-mark prefix prefix-len))) + (t + (if (and prefix + (%line-has-prefix-p fill-mark prefix prefix-len)) + (delete-characters fill-mark prefix-len)) + (delete-characters fill-mark -1) + (insert-character fill-mark #\space) + (if two-spaces-p (insert-character fill-mark #\space)))))) + (t + (mark-after fill-mark)))))) + + + +;;; FILL-REGION-FIND-NEXT-LINE finds the next non-blank line, modulo +;;; fill prefixes, and deletes the intervening lines. Fill-mark is left at +;;; the beginning of the next line. + +(defun fill-region-find-next-line (fill-mark prefix prefix-len end-mark) + (line-offset fill-mark 1 0) + (when (mark< fill-mark end-mark) + (skip-prefix-if-here fill-mark prefix prefix-len) + (if (blank-after-p fill-mark) + (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len) + (line-start fill-mark)))) + + + +;;; FILL-REGION-DELETE-BLANK-LINES deletes the blank line mark is on +;;; and all successive blank lines. Mark is left at the beginning of the +;;; first non-blank line by virtue of its placement and region deletions. + +(defun fill-region-delete-blank-lines (mark end-mark prefix prefix-len) + (line-start mark) + (with-mark ((tmark mark :left-inserting)) + (do ((linep (line-offset tmark 1 0) (line-offset tmark 1 0))) + ((not linep) + (move-mark tmark end-mark) + (delete-region (region mark tmark))) + (skip-prefix-if-here tmark prefix prefix-len) + (when (mark>= tmark end-mark) + (move-mark tmark end-mark) + (delete-region (region mark tmark)) + (return)) + (unless (blank-after-p tmark) + (line-start tmark) + (delete-region (region mark tmark)) + (return))))) + + + +;;; FILL-REGION-CLEAR-BOL clears the initial whitespace on a line +;;; known to be non-blank. Note that the fill prefix is not considered, so +;;; the mark must have been moved over it already if there is one. + +(defun fill-region-clear-bol (mark) + (with-mark ((tmark mark :left-inserting)) + (find-attribute tmark :whitespace #'zerop) + (unless (mark= mark tmark) + (delete-region (region mark tmark))))) + + + +;;; FILL-REGION-COLLAPSE-WHITESPACE deletes extra whitespace between +;;; blocks of non-whitespace characters from mark1 to mark2. Tabs are +;;; converted into a single space. Mark2 must be on the same line as mark1 +;;; since there is no concern of newlines, prefixes on a new line, blank +;;; lines between blocks of non-whitespace characters, etc. + +(defun fill-region-collapse-whitespace (mark1 mark2) + (with-mark ((tmark mark1 :left-inserting)) + ;; skip whitespace at beginning of line or single space between words + (find-attribute mark1 :whitespace #'zerop) + (unless (mark>= mark1 mark2) + (do () + (nil) + (if (not (find-attribute mark1 :whitespace)) ;not end of buffer + (return)) + (if (mark>= mark1 mark2) (return)) + (if (char/= (next-character mark1) #\space) + ;; since only on one line, must be tab or space + (setf (next-character mark1) #\space)) + (move-mark tmark mark1) + (if (mark= (mark-after mark1) mark2) (return)) + (let ((char (next-character mark1))) + (when (and (fill-region-insert-two-spaces-p tmark) + (char= char #\space)) + ;; if at the end of a sentence, don't blow away the second space + (if (mark= (mark-after mark1) mark2) + (return) + (setf char (next-character mark1)))) + (when (whitespace-attribute-p char) ;more whitespace than necessary + (find-attribute (move-mark tmark mark1) :whitespace #'zerop) + (if (mark>= tmark mark2) (move-mark tmark mark2)) + (delete-region (region mark1 tmark)))))))) + + + +;;; FILL-REGION-CLEAR-EOL must check the result of +;;; REVERSE-FIND-ATTRIBUTE because if fill-mark did not move, then we are +;;; only whitespace away from the beginning of the buffer. + +(defun fill-region-clear-eol (fill-mark) + (with-mark ((mark1 fill-mark :left-inserting)) + (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) + (same-line-p mark1 fill-mark)) + (line-start mark1 (mark-line fill-mark))) + (delete-region (region mark1 fill-mark)))) + + + +(defun fill-region-prefix-line (fill-mark prefix prefix-length) + (if (%line-has-prefix-p fill-mark prefix prefix-length) + (character-offset fill-mark prefix-length) + (insert-string fill-mark prefix))) + + + +(defun %line-has-prefix-p (mark prefix prefix-length) + (declare (simple-string prefix)) + (if (>= (line-length (mark-line mark)) prefix-length) + (string= prefix (the simple-string (line-string (mark-line mark))) + :end2 prefix-length))) + + + +;;; FILL-REGION-INSERT-TWO-SPACES-P returns true if a sentence +;;; terminator is followed by any number of "closing characters" such as +;;; ",',),etc. If there is a sentence terminator at the end of the current +;;; line, it must be assumed to be the end of a sentence as opposed to an +;;; abbreviation. Why? Because EMACS does, and besides, what would Lisp +;;; code be without heuristics. + +(defun fill-region-insert-two-spaces-p (mark) + (do ((n 0 (1+ n))) + ((not (sentence-closing-char-attribute-p (previous-character mark))) + (cond ((sentence-terminator-attribute-p (previous-character mark)) + (character-offset mark n)) + (t (character-offset mark n) nil))) + (mark-before mark))) + + + +(defun check-fill-prefix (prefix column mark) + (when prefix + (insert-character mark #\newline) + (insert-character mark #\newline) + (mark-before mark) + (insert-string mark prefix) + (let ((pos (mark-column mark))) + (declare (simple-string prefix)) + (mark-after mark) + (delete-characters mark (- (+ (length prefix) 2))) + (if (>= pos column) + (editor-error + "The fill prefix length is longer than the fill column."))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/font.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/font.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/font.lisp (revision 8058) @@ -0,0 +1,101 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; Modified by Bill Chiles toward Hemlock running under X. +;;; +;;; This file contains various functions that make up the user interface to +;;; fonts. +;;; + +(in-package :hemlock-internals) + +;;; Default-font used to be in the above list, but when I cleaned up the way +;;; Hemlock compiles, a name conflict occurred because "Default Font" is a +;;; Hemlock variable. It is now exported by the export list in rompsite.lisp. + +(defvar *default-font-family* (make-font-family)) + + + + +;;;; Creating, Deleting, and Moving. + +(defun new-font-region (buffer start-mark end-mark font) + (let* ((start-line (mark-line start-mark)) + (end-line (mark-line end-mark)) + (font-start (internal-make-font-mark start-line + (mark-charpos start-mark) + :right-inserting + font)) + (font-end (internal-make-font-mark end-line + (mark-charpos end-mark) + :right-inserting + font)) + (region (internal-make-font-region font-start font-end))) + (setf (font-mark-region font-start) region + (font-mark-region font-end) region) + (push font-start (line-marks start-line)) + (push font-end (line-marks end-line)) + (add-buffer-font-region buffer region) + (buffer-note-font-change buffer region font) + region)) + + + + + +(defun font-mark (line charpos font &optional (kind :right-inserting)) + "Returns a font on line at charpos with font. Font marks must be permanent + marks." + (unless (or (eq kind :right-inserting) (eq kind :left-inserting)) + (error "A Font-Mark must be :left-inserting or :right-inserting.")) + (unless (and (>= font 0) (< font font-map-size)) + (error "Font number ~S out of range." font)) + (let ((new (internal-make-font-mark line charpos kind font))) + (new-font-mark new line) + (push new (line-marks line)) + (incf (line-font-mark-count line)) + new)) + +(defun delete-font-mark (font-mark) + "Deletes a font mark." + (check-type font-mark font-mark) + (let ((line (mark-line font-mark))) + (when line + (setf (line-marks line) (delq font-mark (line-marks line))) + (decf (line-font-mark-count line)) + (nuke-font-mark font-mark line) + (setf (mark-line font-mark) nil)))) + +(defun delete-line-font-marks (line) + "Deletes all font marks on line." + (dolist (m (line-marks line)) + (when (fast-font-mark-p m) + (delete-font-mark m)))) + +(defun move-font-mark (font-mark new-position) + "Moves font mark font-mark to location of mark new-position." + (check-type font-mark font-mark) + (let ((old-line (mark-line font-mark)) + (new-line (mark-line new-position))) + (nuke-font-mark font-mark old-line) + (move-mark font-mark new-position) + (new-font-mark font-mark new-line) + font-mark)) + +(defun nuke-font-mark (mark line) + (new-font-mark mark line)) + +(defun new-font-mark (mark line) + (declare (ignore mark line)) +) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/hemlock-ext.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/hemlock-ext.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/hemlock-ext.lisp (revision 8058) @@ -0,0 +1,801 @@ +;;; -*- Mode: LISP; Package: HEMLOCK-EXT -*- + +(in-package :hemlock-ext) + +(defconstant hi::char-code-limit 256) +(defconstant char-code-limit 256) + +(defmacro file-comment (&rest ignore) + (declare (ignore ignore)) + nil) + +(defun skip-whitespace (&optional (stream *standard-input*)) + (peek-char t stream)) + +#+clx +(defun disable-clx-event-handling (display) + ) + +(defun quit () + ) + +(defun sap-ref-8 (vec index) + (declare (ignore vec index)) + (error "SAP-REF-8 called.") ) + +(defvar hi::*command-line-switches* nil) + +(defun hi::get-terminal-name () + "vt100") + +(defun hi::get-termcap-env-var () + (getenv "TERMCAP")) + +(defun default-directory () + "Returns the pathname for the default directory. This is the place where + a file will be written if no directory is specified. This may be changed + with setf." + (truename #p"")) + +;;;;;;;;;;;; + +(defstruct (object-set (:constructor make-object-set (name &optional default-handler))) + name + default-handler + (table (make-hash-table))) + +(defvar *xwindow-hash* (make-hash-table :test #'eq)) + +(defun hi::add-xwindow-object (window object object-set) + (setf (gethash window *xwindow-hash*) (list object object-set))) + +(defun hi::remove-xwindow-object (window) + (remhash window *xwindow-hash*)) + +(defun lisp--map-xwindow (window) + ;; -> object object-set + (values-list (gethash window *xwindow-hash*))) + + + +;;;; Object set event handling. + +;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear +;;; events on the display before signalling any errors. This is necessary +;;; since reading on certain CMU Common Lisp streams involves SERVER, and +;;; getting an error while trying to handle an event causes repeated attempts +;;; to handle the same event. +;;; +(defvar *process-clx-event-display* nil) + +(defvar *object-set-event-handler-print* nil) + +(declaim (declaration values)) + +#+clx +(defun object-set-event-handler (display &optional (timeout 0)) + "This display event handler uses object sets to map event windows cross + event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots + of each event, calling the handlers on all these values in addition to + the event key and send-event-p. Describe EXT:SERVE-MUMBLE, where mumble + is an event keyword name for the exact order of arguments. + :mapping-notify and :keymap-notify events are ignored since they do not + occur on any particular window. After calling a handler, each branch + returns t to discard the event. While the handler is executing, all + errors go through a handler that flushes all the display's events and + returns. This prevents infinite errors since the debug and terminal + streams loop over SYSTEM:SERVE-EVENT. This function returns t if there + were some event to handle, nil otherwise. It returns immediately if + there is no event to handle." + (macrolet ((dispatch (event-key &rest args) + `(multiple-value-bind (object object-set) + (lisp--map-xwindow event-window) + (unless object + (cond ((not (typep event-window 'xlib:window)) + ;;(xlib:discard-current-event display) + (warn "Discarding ~S event on non-window ~S." + ,event-key event-window) + (return-from object-set-event-handler nil) + ) + (t + (flush-display-events display) + (error "~S not a known X window.~%~ + Received event ~S." + event-window ,event-key)))) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (when *object-set-event-handler-print* + (print ,event-key) (force-output)) + (funcall (gethash ,event-key + (object-set-table object-set) + (object-set-default-handler + object-set)) + object ,event-key + ,@args)) + (setf result t)))) + (let ((*process-clx-event-display* display) + (result nil)) + (xlib:event-case (display :timeout timeout) + ((:key-press :key-release :button-press :button-release) + (event-key event-window root child same-screen-p + x y root-x root-y state time code send-event-p) + (dispatch event-key event-window root child same-screen-p + x y root-x root-y state time code send-event-p)) + (:motion-notify (event-window root child same-screen-p + x y root-x root-y state time hint-p send-event-p) + (dispatch :motion-notify event-window root child same-screen-p + x y root-x root-y state time hint-p send-event-p)) + (:enter-notify (event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (dispatch :enter-notify event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (:leave-notify (event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (dispatch :leave-notify event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (:exposure (event-window x y width height count send-event-p) + (dispatch :exposure event-window x y width height count send-event-p)) + (:graphics-exposure (event-window x y width height count major minor + send-event-p) + (dispatch :graphics-exposure event-window x y width height + count major minor send-event-p)) + (:no-exposure (event-window major minor send-event-p) + (dispatch :no-exposure event-window major minor send-event-p)) + (:focus-in (event-window mode kind send-event-p) + (dispatch :focus-in event-window mode kind send-event-p)) + (:focus-out (event-window mode kind send-event-p) + (dispatch :focus-out event-window mode kind send-event-p)) + (:keymap-notify () + (warn "Ignoring keymap notify event.") + (when *object-set-event-handler-print* + (print :keymap-notify) (force-output)) + (setf result t)) + (:visibility-notify (event-window state send-event-p) + (dispatch :visibility-notify event-window state send-event-p)) + (:create-notify (event-window window x y width height border-width + override-redirect-p send-event-p) + (dispatch :create-notify event-window window x y width height + border-width override-redirect-p send-event-p)) + (:destroy-notify (event-window window send-event-p) + (dispatch :destroy-notify event-window window send-event-p)) + (:unmap-notify (event-window window configure-p send-event-p) + (dispatch :unmap-notify event-window window configure-p send-event-p)) + (:map-notify (event-window window override-redirect-p send-event-p) + (dispatch :map-notify event-window window override-redirect-p + send-event-p)) + (:map-request (event-window window send-event-p) + (dispatch :map-request event-window window send-event-p)) + (:reparent-notify (event-window window parent x y override-redirect-p + send-event-p) + (dispatch :reparent-notify event-window window parent x y + override-redirect-p send-event-p)) + (:configure-notify (event-window window x y width height border-width + above-sibling override-redirect-p send-event-p) + (dispatch :configure-notify event-window window x y width height + border-width above-sibling override-redirect-p + send-event-p)) + (:gravity-notify (event-window window x y send-event-p) + (dispatch :gravity-notify event-window window x y send-event-p)) + (:resize-request (event-window width height send-event-p) + (dispatch :resize-request event-window width height send-event-p)) + (:configure-request (event-window window x y width height border-width + stack-mode above-sibling value-mask send-event-p) + (dispatch :configure-request event-window window x y width height + border-width stack-mode above-sibling value-mask + send-event-p)) + (:circulate-notify (event-window window place send-event-p) + (dispatch :circulate-notify event-window window place send-event-p)) + (:circulate-request (event-window window place send-event-p) + (dispatch :circulate-request event-window window place send-event-p)) + (:property-notify (event-window atom state time send-event-p) + (dispatch :property-notify event-window atom state time send-event-p)) + (:selection-clear (event-window selection time send-event-p) + (dispatch :selection-notify event-window selection time send-event-p)) + (:selection-request (event-window requestor selection target property + time send-event-p) + (dispatch :selection-request event-window requestor selection target + property time send-event-p)) + (:selection-notify (event-window selection target property time + send-event-p) + (dispatch :selection-notify event-window selection target property time + send-event-p)) + (:colormap-notify (event-window colormap new-p installed-p send-event-p) + (dispatch :colormap-notify event-window colormap new-p installed-p + send-event-p)) + (:mapping-notify (request) + (warn "Ignoring mapping notify event -- ~S." request) + (when *object-set-event-handler-print* + (print :mapping-notify) (force-output)) + (setf result t)) + (:client-message (event-window format data send-event-p) + (dispatch :client-message event-window format data send-event-p))) + result))) + +#+clx +(defun default-clx-event-handler (object event-key event-window &rest ignore) + (declare (ignore ignore)) + (flush-display-events *process-clx-event-display*) + (error "No handler for event type ~S on ~S in ~S." + event-key object (lisp--map-xwindow event-window))) + +#+clx +(defun flush-display-events (display) + "Dumps all the events in display's event queue including the current one + in case this is called from within XLIB:EVENT-CASE, etc." + (xlib:discard-current-event display) + (xlib:event-case (display :discard-p t :timeout 0) + (t () nil))) + +#+clx +(defmacro with-clx-event-handling ((display handler) &rest body) + "Evaluates body in a context where events are handled for the display + by calling handler on the display. This destroys any previously established + handler for display." + `(unwind-protect + (progn + (enable-clx-event-handling ,display ,handler) + ,@body) + (disable-clx-event-handling ,display) )) + +#+clx +(defun enable-clx-event-handling (display handler) + nil) + +#+clx +(defun disable-clx-event-handling (display) + nil) + +#|| +;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in +;;; *display-event-handlers*. It also uses SYSTEM:ADD-FD-HANDLER to have +;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows +;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a +;;; file descriptor, the file descriptor is also mapped to the display in +;;; *clx-fds-to-displays*, so the user's handler can be called on the display. +;;; +(defun enable-clx-event-handling (display handler) + "After calling this, when SYSTEM:SERVE-EVENT notices input on display's + connection to the X11 server, handler is called on the display. Handler + is invoked in a dynamic context with an error handler bound that will + flush all events from the display and return. By returning, it declines + to handle the error, but it will have cleared all events; thus, entering + the debugger will not result in infinite errors due to streams that wait + via SYSTEM:SERVE-EVENT for input. Calling this repeatedly on the same + display establishes handler as a new handler, replacing any previous one + for display." + (check-type display xlib:display) + (let ((change-handler (assoc display *display-event-handlers*))) + (if change-handler + (setf (cdr change-handler) handler) + (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) + (system:add-fd-handler fd :input #'call-display-event-handler) + (setf (gethash fd *clx-fds-to-displays*) display) + (push (cons display handler) *display-event-handlers*))))) + +;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps +;;; the display to its handler. If we can't find the display, we remove the +;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the +;;; display from *display-event-handlers*. This is necessary to try to keep +;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and +;;; over. This is possible since many CMU Common Lisp streams loop over +;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are +;;; possible. +;;; +(defun call-display-event-handler (file-descriptor) + (let ((display (gethash file-descriptor *clx-fds-to-displays*))) + (unless display + (system:invalidate-descriptor file-descriptor) + (setf *display-event-handlers* + (delete file-descriptor *display-event-handlers* + :key #'(lambda (d/h) + (fd-stream-fd + (xlib::display-input-stream + (car d/h)))))) + (error "File descriptor ~S not associated with any CLX display.~%~ + It has been removed from system:serve-event's knowledge." + file-descriptor)) + (let ((handler (cdr (assoc display *display-event-handlers*)))) + (unless handler + (flush-display-events display) + (error "Display ~S not associated with any event handler." display)) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (funcall handler display))))) + +(defun disable-clx-event-handling (display) + "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING." + (setf *display-event-handlers* + (delete display *display-event-handlers* :key #'car)) + (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) + (remhash fd *clx-fds-to-displays*) + (system:invalidate-descriptor fd))) +||# + + + +;;;; Key and button service. + +(defun serve-key-press (object-set fun) + "Associate a method in the object-set with :key-press events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :key-press (object-set-table object-set)) fun)) + +(defun serve-key-release (object-set fun) + "Associate a method in the object-set with :key-release events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :key-release (object-set-table object-set)) fun)) + +(defun serve-button-press (object-set fun) + "Associate a method in the object-set with :button-press events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :button-press (object-set-table object-set)) fun)) + +(defun serve-button-release (object-set fun) + "Associate a method in the object-set with :button-release events. The + method is called on the object the event occurred, event key, event window, + root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :button-release (object-set-table object-set)) fun)) + + + + +;;;; Mouse service. + +(defun serve-motion-notify (object-set fun) + "Associate a method in the object-set with :motion-notify events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and + send-event-p." + (setf (gethash :motion-notify (object-set-table object-set)) fun)) + +(defun serve-enter-notify (object-set fun) + "Associate a method in the object-set with :enter-notify events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, + and send-event-p." + (setf (gethash :enter-notify (object-set-table object-set)) fun)) + +(defun serve-leave-notify (object-set fun) + "Associate a method in the object-set with :leave-notify events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, + and send-event-p." + (setf (gethash :leave-notify (object-set-table object-set)) fun)) + + + + +;;;; Keyboard service. + +(defun serve-focus-in (object-set fun) + "Associate a method in the object-set with :focus-in events. The method + is called on the object the event occurred, event key, event window, mode, + kind, and send-event-p." + (setf (gethash :focus-in (object-set-table object-set)) fun)) + +(defun serve-focus-out (object-set fun) + "Associate a method in the object-set with :focus-out events. The method + is called on the object the event occurred, event key, event window, mode, + kind, and send-event-p." + (setf (gethash :focus-out (object-set-table object-set)) fun)) + + + + +;;;; Exposure service. + +(defun serve-exposure (object-set fun) + "Associate a method in the object-set with :exposure events. The method + is called on the object the event occurred, event key, event window, x, y, + width, height, count, and send-event-p." + (setf (gethash :exposure (object-set-table object-set)) fun)) + +(defun serve-graphics-exposure (object-set fun) + "Associate a method in the object-set with :graphics-exposure events. The + method is called on the object the event occurred, event key, event window, + x, y, width, height, count, major, minor, and send-event-p." + (setf (gethash :graphics-exposure (object-set-table object-set)) fun)) + +(defun serve-no-exposure (object-set fun) + "Associate a method in the object-set with :no-exposure events. The method + is called on the object the event occurred, event key, event window, major, + minor, and send-event-p." + (setf (gethash :no-exposure (object-set-table object-set)) fun)) + + + + +;;;; Structure service. + +(defun serve-visibility-notify (object-set fun) + "Associate a method in the object-set with :visibility-notify events. The + method is called on the object the event occurred, event key, event window, + state, and send-event-p." + (setf (gethash :visibility-notify (object-set-table object-set)) fun)) + +(defun serve-create-notify (object-set fun) + "Associate a method in the object-set with :create-notify events. The + method is called on the object the event occurred, event key, event window, + window, x, y, width, height, border-width, override-redirect-p, and + send-event-p." + (setf (gethash :create-notify (object-set-table object-set)) fun)) + +(defun serve-destroy-notify (object-set fun) + "Associate a method in the object-set with :destroy-notify events. The + method is called on the object the event occurred, event key, event window, + window, and send-event-p." + (setf (gethash :destroy-notify (object-set-table object-set)) fun)) + +(defun serve-unmap-notify (object-set fun) + "Associate a method in the object-set with :unmap-notify events. The + method is called on the object the event occurred, event key, event window, + window, configure-p, and send-event-p." + (setf (gethash :unmap-notify (object-set-table object-set)) fun)) + +(defun serve-map-notify (object-set fun) + "Associate a method in the object-set with :map-notify events. The + method is called on the object the event occurred, event key, event window, + window, override-redirect-p, and send-event-p." + (setf (gethash :map-notify (object-set-table object-set)) fun)) + +(defun serve-map-request (object-set fun) + "Associate a method in the object-set with :map-request events. The + method is called on the object the event occurred, event key, event window, + window, and send-event-p." + (setf (gethash :map-request (object-set-table object-set)) fun)) + +(defun serve-reparent-notify (object-set fun) + "Associate a method in the object-set with :reparent-notify events. The + method is called on the object the event occurred, event key, event window, + window, parent, x, y, override-redirect-p, and send-event-p." + (setf (gethash :reparent-notify (object-set-table object-set)) fun)) + +(defun serve-configure-notify (object-set fun) + "Associate a method in the object-set with :configure-notify events. The + method is called on the object the event occurred, event key, event window, + window, x, y, width, height, border-width, above-sibling, + override-redirect-p, and send-event-p." + (setf (gethash :configure-notify (object-set-table object-set)) fun)) + +(defun serve-gravity-notify (object-set fun) + "Associate a method in the object-set with :gravity-notify events. The + method is called on the object the event occurred, event key, event window, + window, x, y, and send-event-p." + (setf (gethash :gravity-notify (object-set-table object-set)) fun)) + +(defun serve-resize-request (object-set fun) + "Associate a method in the object-set with :resize-request events. The + method is called on the object the event occurred, event key, event window, + width, height, and send-event-p." + (setf (gethash :resize-request (object-set-table object-set)) fun)) + +(defun serve-configure-request (object-set fun) + "Associate a method in the object-set with :configure-request events. The + method is called on the object the event occurred, event key, event window, + window, x, y, width, height, border-width, stack-mode, above-sibling, + value-mask, and send-event-p." + (setf (gethash :configure-request (object-set-table object-set)) fun)) + +(defun serve-circulate-notify (object-set fun) + "Associate a method in the object-set with :circulate-notify events. The + method is called on the object the event occurred, event key, event window, + window, place, and send-event-p." + (setf (gethash :circulate-notify (object-set-table object-set)) fun)) + +(defun serve-circulate-request (object-set fun) + "Associate a method in the object-set with :circulate-request events. The + method is called on the object the event occurred, event key, event window, + window, place, and send-event-p." + (setf (gethash :circulate-request (object-set-table object-set)) fun)) + + + + +;;;; Misc. service. + +(defun serve-property-notify (object-set fun) + "Associate a method in the object-set with :property-notify events. The + method is called on the object the event occurred, event key, event window, + atom, state, time, and send-event-p." + (setf (gethash :property-notify (object-set-table object-set)) fun)) + +(defun serve-selection-clear (object-set fun) + "Associate a method in the object-set with :selection-clear events. The + method is called on the object the event occurred, event key, event window, + selection, time, and send-event-p." + (setf (gethash :selection-clear (object-set-table object-set)) fun)) + +(defun serve-selection-request (object-set fun) + "Associate a method in the object-set with :selection-request events. The + method is called on the object the event occurred, event key, event window, + requestor, selection, target, property, time, and send-event-p." + (setf (gethash :selection-request (object-set-table object-set)) fun)) + +(defun serve-selection-notify (object-set fun) + "Associate a method in the object-set with :selection-notify events. The + method is called on the object the event occurred, event key, event window, + selection, target, property, time, and send-event-p." + (setf (gethash :selection-notify (object-set-table object-set)) fun)) + +(defun serve-colormap-notify (object-set fun) + "Associate a method in the object-set with :colormap-notify events. The + method is called on the object the event occurred, event key, event window, + colormap, new-p, installed-p, and send-event-p." + (setf (gethash :colormap-notify (object-set-table object-set)) fun)) + +(defun serve-client-message (object-set fun) + "Associate a method in the object-set with :client-message events. The + method is called on the object the event occurred, event key, event window, + format, data, and send-event-p." + (setf (gethash :client-message (object-set-table object-set)) fun)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hi::%sp-byte-blt (src start dest dstart end) + (declare (type (simple-base-string src dest))) + (loop for s from start + for d from dstart below end + do + (setf (aref dest d) (aref src s)))) + +#+clx +(defun serve-event (&optional timeout) + (let ((dps)) + (maphash (lambda (win value) + (pushnew (xlib:window-display win) dps)) + *xwindow-hash*) + (when dps + (object-set-event-handler (car dps) timeout)))) + +#+CLISP +(progn + + #-NIL + (defun serve-event (&optional timeout) + (hemlock.wire::serve-event timeout)) + +;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in +;;; *display-event-handlers*. It also uses SYSTEM:ADD-FD-HANDLER to have +;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows +;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a +;;; file descriptor, the file descriptor is also mapped to the display in +;;; *clx-fds-to-displays*, so the user's handler can be called on the display. +;;; + + (defvar *display-event-handlers* nil) + + (defun enable-clx-event-handling (display handler) + "After calling this, when SYSTEM:SERVE-EVENT notices input on display's + connection to the X11 server, handler is called on the display. Handler + is invoked in a dynamic context with an error handler bound that will + flush all events from the display and return. By returning, it declines + to handle the error, but it will have cleared all events; thus, entering + the debugger will not result in infinite errors due to streams that wait + via SYSTEM:SERVE-EVENT for input. Calling this repeatedly on the same + display establishes handler as a new handler, replacing any previous one + for display." + (check-type display xlib:display) + (let ((change-handler (assoc display *display-event-handlers*))) + (if change-handler + (setf (cadr change-handler) handler) + (let ((fd-handler + (hemlock.wire::add-fd-handler display :input #'call-display-event-handler))) + (push (list display handler fd-handler) *display-event-handlers*))))) + +;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps +;;; the display to its handler. If we can't find the display, we remove the +;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the +;;; display from *display-event-handlers*. This is necessary to try to keep +;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and +;;; over. This is possible since many CMU Common Lisp streams loop over +;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are +;;; possible. +;;; + (defun call-display-event-handler (display) + (let ((handler (cadr (assoc display *display-event-handlers*)))) + (unless handler + (flush-display-events display) + (error "Display ~S not associated with any event handler." display)) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (funcall handler display)))) + + (defun disable-clx-event-handling (display) + "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING." + (let ((change-handler (assoc display *display-event-handlers*))) + (when change-handler + (hemlock.wire::remove-fd-handler (third change-handler)))) + (setf *display-event-handlers* + (delete display *display-event-handlers* :key #'car)) + ) ) + + +;;(trace object-set-event-handler hi::invoke-scheduled-events hi::next-scheduled-event-wait serve-event) + +(defun hi::%sp-find-character-with-attribute (string start end table mask) + ;;(declare (type (simple-array (mod 256) char-code-max) table)) + (declare (simple-string string)) + (declare (fixnum start end)) + "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask + The codes of the characters of String from Start to End are used as indices + into the Table, which is a U-Vector of 8-bit bytes. When the number picked + up from the table bitwise ANDed with Mask is non-zero, the current + index into the String is returned. The corresponds to SCANC on the Vax." + (do ((index start (1+ index))) + ((= index end) nil) + (declare (fixnum index)) + (if (/= (logand (aref table (min 255 (char-code (schar string index)))) mask) 0) + (return index)))) + +(defun hi::%sp-reverse-find-character-with-attribute (string start end table + mask) + ;;(declare (type (simple-array (mod 256) char-code-max) table)) + (declare (simple-string string)) + (declare (fixnum start end)) + "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." + (do ((index (1- end) (1- index))) + ((< index start) nil) + (declare (fixnum index)) + (if (/= (logand (aref table (min 255 (char-code (aref string index)))) mask) 0) + (return index)))) + +(defun hi::%sp-find-character (string start end character) + "%SP-Find-Character String, Start, End, Character + Searches String for the Character from Start to End. If the character is + found, the corresponding index into String is returned, otherwise NIL is + returned." + (declare (simple-string string) + (fixnum start end) + (optimize (speed 3) (safety 0))) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (when (eq character (schar string i)) + (return i)))) + +(defun delq (item list) + (delete item list :test #'eq)) + +(defun memq (item list) + (member item list :test #'eq)) + +(defun assq (item alist) + (assoc item alist :test #'eq)) + +;;;; complete-file + +#-CMU +(progn + (defun complete-file (pathname &key (defaults *default-pathname-defaults*) + ignore-types) + (let ((files (complete-file-directory pathname defaults))) + (cond ((null files) + (values nil nil)) + ((null (cdr files)) + (values (car files) + t)) + (t + (let ((good-files + (delete-if #'(lambda (pathname) + (and (simple-string-p + (pathname-type pathname)) + (member (pathname-type pathname) + ignore-types + :test #'string=))) + files))) + (cond ((null good-files)) + ((null (cdr good-files)) + (return-from complete-file + (values (car good-files) + t))) + (t + (setf files good-files))) + (let ((common (file-namestring (car files)))) + (dolist (file (cdr files)) + (let ((name (file-namestring file))) + (dotimes (i (min (length common) (length name)) + (when (< (length name) (length common)) + (setf common name))) + (unless (char= (schar common i) (schar name i)) + (setf common (subseq common 0 i)) + (return))))) + (values (merge-pathnames common pathname) + nil))))))) + +;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal. +;;; + (defun complete-file-directory (pathname defaults) + (let* ((pathname (merge-pathnames pathname (directory-namestring defaults))) + (type (pathname-type pathname))) + (setf pathname + (make-pathname :defaults (truename (make-pathname :defaults pathname :name nil :type nil)) + :name (pathname-name pathname) + :type type)) + (delete-if-not (lambda (candidate) + (search (namestring pathname) (namestring candidate))) + (append + #+CLISP + (directory + (make-pathname :defaults pathname + :name :wild + :type nil)) ;gosh! + #+CLISP + (directory + (make-pathname :defaults pathname + :directory (append (pathname-directory pathname) (list "*")) ;gosh gosh! + :name nil + :type nil)))))) + +;;; Ambiguous-Files -- Public +;;; + (defun ambiguous-files (pathname + &optional (defaults *default-pathname-defaults*)) + "Return a list of all files which are possible completions of Pathname. + We look in the directory specified by Defaults as well as looking down + the search list." + (complete-file-directory pathname defaults)) ) + + +;;;; CLISP fixage + +#+CLISP +(in-package :xlib) + +#+CLISP +'(progn + (defvar *lookahead* nil) + + (setf *buffer-read-polling-time* .01) + + (defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) nil) + ((eql timeout 0) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream))) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout))))) + + (defun buffer-read-default (display vector start end timeout) + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null fixnum) timeout)) + ;; #.(declare-buffun) + (let ((stream (display-input-stream display))) + (cond ((and (eql timeout 0) + (not (setf *lookahead* (or *lookahead* (ext:read-byte-no-hang stream)))) ) + :timeout) + (t + (if *lookahead* + (progn + (setf (aref vector start) *lookahead*) + (setf *lookahead* nil) + (system::read-n-bytes stream vector (+ start 1) (- end start 1))) + (system::read-n-bytes stream vector start (- end start))) + nil)) ) ) ) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext1.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext1.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext1.lisp (revision 8058) @@ -0,0 +1,694 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock Text-Manipulation functions. +;;; Written by Skef Wholey. +;;; +;;; The code in this file implements the functions in the "Representation +;;; of Text," "Buffers," and "Predicates" chapters of the Hemlock design +;;; document. +;;; + +(in-package :hemlock-internals) + + + +;;;; Representation of Text: + +;;; Line cache mechanism. +;;; +;;; The "open line" is used when inserting and deleting characters from a line. +;;; It acts as a cache that provides a more flexible (but more expensive) +;;; representation of the line for multiple insertions and deletions. When a +;;; line is open, it is represented as a vector of characters and two indices: +;;; +;;; +-----------------------------------------------------------+ +;;; | F | O | O | | B | x | x | x | x | x | x | x | x | A | R | +;;; +-----------------------------------------------------------+ +;;; ^ ^ +;;; Left Pointer Right Pointer +;;; +;;; The open line is represented by 4 special variables: +;;; (current-open-line): the line object that is opened +;;; (current-open-chars): the vector of cached characters +;;; (current-left-open-pos): index of first free character in the gap +;;; (current-right-open-pos): index of first used character after the gap +;;; +;;; Note: +;;; Any modificiation of the line cache must be protected by +;;; Without-Interrupts. This is done automatically by modifying-buffer; other +;;; users beware. + + + +#+no +(defvar *line-cache-length* 200 + "Length of Open-Chars.") + + + +#+no +(defvar *open-line* () + "Line open for hacking on.") + + + +#+no +(defvar *open-chars* (make-string *line-cache-length*) + "Vector of characters for hacking on.") + + + +#+no +(defvar *left-open-pos* 0 + "Index to first free character to left of mark in *Open-Chars*.") + + + +#+no +(defvar *right-open-pos* 0 + "Index to first used character to right of mark in *Open-Chars*.") + +(defun grow-open-chars (&optional (new-length (* (current-line-cache-length) 2))) + "Grows (current-open-chars) to twice its current length, or the New-Length if + specified." + (let* ((old-chars (current-open-chars)) + (old-right (current-right-open-pos)) + (new-chars (make-string new-length)) + (new-right (- new-length (- (current-line-cache-length) old-right)))) + (%sp-byte-blt old-chars 0 new-chars 0 (current-left-open-pos)) + (%sp-byte-blt old-chars old-right new-chars new-right new-length) + (setf (current-right-open-pos) new-right) + (setf (current-open-chars) new-chars) + (setf (current-line-cache-length) new-length))) + + +(defun close-line () + "Stuffs the characters in the currently open line back into the line they + came from, and sets (current-open-line) to Nil." + (when (current-open-line) + (hemlock-ext:without-interrupts + (let* ((open-chars (current-open-chars)) + (right-pos (current-right-open-pos)) + (left-pos (current-left-open-pos)) + (length (+ left-pos (- (current-line-cache-length) right-pos))) + (string (make-string length))) + (%sp-byte-blt open-chars 0 string 0 left-pos) + (%sp-byte-blt open-chars right-pos string left-pos length) + (setf (line-chars (current-open-line)) string) + (setf (current-open-line) nil))))) + +;;; We stick decrementing fixnums in the line-chars slot of the open line +;;; so that whenever the cache is changed the chars are no longer eq. +;;; They decrement so that they will be distinct from positive fixnums, +;;; which might mean something else. +;;; +(defvar *cache-modification-tick* -1 + "The counter for the fixnums we stick in the chars of the cached line.") + +(defun open-line (line mark) + "Closes the current open line and opens the given Line at the Mark. + Don't call this, use modifying-line instead." + (cond ((current-open-line-p line) + (let ((charpos (mark-charpos mark)) + (open-chars (current-open-chars))) + (cond ((< charpos (current-left-open-pos)) ; BLT 'em right! + (let ((right-start (- (current-right-open-pos) + (- (current-left-open-pos) charpos)))) + (%sp-byte-blt open-chars + charpos + open-chars + right-start + (current-right-open-pos)) + (setf (current-left-open-pos) charpos) + (setf (current-right-open-pos) right-start))) + ((> charpos (current-left-open-pos)) ; BLT 'em left! + (%sp-byte-blt open-chars + (current-right-open-pos) + open-chars + (current-left-open-pos) + charpos) + (incf (current-right-open-pos) (- charpos (current-left-open-pos))) + (setf (current-left-open-pos) charpos))))) + + (t + (close-line) + (let* ((chars (line-chars line)) + (len (length chars))) + (declare (simple-string chars)) + (when (> len (current-line-cache-length)) + (setf (current-line-cache-length) (* len 2)) + (setf (current-open-chars) (make-string (current-line-cache-length)))) + (setf (current-open-line) line) + (setf (current-left-open-pos) (mark-charpos mark)) + (setf (current-right-open-pos) + (- (current-line-cache-length) + (- (length chars) (current-left-open-pos)))) + (%sp-byte-blt chars 0 (current-open-chars) 0 + (current-left-open-pos)) + (%sp-byte-blt chars (current-left-open-pos) + (current-open-chars) + (current-right-open-pos) + (current-line-cache-length)))))) + + +;;;; Some macros for Text hacking: + + +(defmacro modifying-line (line mark) + "Checks to see if the Line is already opened at the Mark, and calls Open-Line + if not. Sticks a tick in the current-open-line's chars. This must be called within + the body of a Modifying-Buffer form." + `(progn + (unless (and (= (mark-charpos ,mark) (current-left-open-pos)) (current-open-line-p ,line)) + (open-line ,line ,mark)) + (setf (line-chars (current-open-line)) (decf *cache-modification-tick*)))) + +;;; Now-Tick tells us when now is and isn't. +;;; +(defvar now-tick 0 "Current tick.") + +(defmacro tick () + "Increments the ``now'' tick." + `(ccl::atomic-incf now-tick)) + + +(defun buffer-document-begin-editing (buffer) + (when (bufferp buffer) + (let* ((document (buffer-document buffer))) + (when document + (lock-buffer buffer) + (document-begin-editing document))))) + +(defun buffer-document-end-editing (buffer) + (when (bufferp buffer) + (let* ((document (buffer-document buffer))) + (when document + (unlock-buffer buffer) + (document-end-editing document))))) + + + +;;; Yeah, the following is kind of obscure, but at least it doesn't +;;; call Bufferp twice. The without-interrupts is just to prevent +;;; people from being screwed by interrupting when the buffer structure +;;; is in an inconsistent state. +;;; +(defmacro modifying-buffer (buffer &body forms) + "Does groovy stuff for modifying buffers." + (let* ((b (gensym)) + (bp (gensym))) + `(let* ((,b ,buffer) + (,bp (bufferp ,b))) + (when ,bp + (unless (buffer-writable ,b) + (error "Buffer ~S is read only." (buffer-name ,b))) + (when (< (buffer-modified-tick ,b) + (buffer-unmodified-tick ,b)) + (invoke-hook hemlock::buffer-modified-hook ,b t)) + (setf (buffer-modified ,b) t)) + (hemlock-ext:without-interrupts ,@forms)))) + +(defmacro always-change-line (mark new-line) + (let ((scan (gensym)) + (prev (gensym)) + (old-line (gensym))) + `(let ((,old-line (mark-line ,mark))) + (when (not (eq (mark-%kind ,mark) :temporary)) + (do ((,scan (line-marks ,old-line) (cdr ,scan)) + (,prev () ,scan)) + ((eq (car ,scan) ,mark) + (if ,prev + (setf (cdr ,prev) (cdr ,scan)) + (setf (line-marks ,old-line) (cdr ,scan))) + (setf (cdr ,scan) (line-marks ,new-line) + (line-marks ,new-line) ,scan)))) + (setf (mark-line ,mark) ,new-line)))) + +(defmacro change-line (mark new-line) + (let ((scan (gensym)) + (prev (gensym)) + (old-line (gensym))) + `(let ((,old-line (mark-line ,mark))) + (unless (or (eq (mark-%kind ,mark) :temporary) + (eq ,old-line ,new-line)) + (do ((,scan (line-marks ,old-line) (cdr ,scan)) + (,prev () ,scan)) + ((eq (car ,scan) ,mark) + (if ,prev + (setf (cdr ,prev) (cdr ,scan)) + (setf (line-marks ,old-line) (cdr ,scan))) + (setf (cdr ,scan) (line-marks ,new-line) + (line-marks ,new-line) ,scan)))) + (setf (mark-line ,mark) ,new-line)))) + +;;; MOVE-SOME-MARKS -- Internal +;;; +;;; Move all the marks from the line Old to New, performing some +;;; function on their charpos'es. Charpos is bound to the charpos of +;;; the mark, and the result of the evaluation of the last form in +;;; the body should be the new charpos for the mark. If New is +;;; not supplied then the marks are left on the old line. +;;; +(defmacro move-some-marks ((charpos old &optional new) &body body) + (let ((last (gensym)) (mark (gensym)) (marks (gensym))) + (if new + `(let ((,marks (line-marks ,old))) + (do ((,mark ,marks (cdr ,mark)) + (,last nil ,mark)) + ((null ,mark) + (when ,last + (shiftf (cdr ,last) (line-marks ,new) ,marks)) + (setf (line-marks ,old) nil)) + (setf (mark-line (car ,mark)) ,new) + (setf (mark-charpos (car ,mark)) + (let ((,charpos (mark-charpos (car ,mark)))) + ,@body)))) + `(dolist (,mark (line-marks ,old)) + (setf (mark-charpos ,mark) + (let ((,charpos (mark-charpos ,mark))) + ,@body)))))) + +;;; Maybe-Move-Some-Marks -- Internal +;;; +;;; Like Move-Some-Marks, but only moves the mark if the +;;; charpos is greater than the bound, OR the charpos equals the bound +;;; and the marks %kind is :left-inserting. +;;; +(defmacro maybe-move-some-marks ((charpos old &optional new) bound &body body) + (let ((mark (gensym)) (marks (gensym)) (prev (gensym))) + (if new + `(do ((,mark (line-marks ,old)) + (,marks (line-marks ,new)) + (,prev ())) + ((null ,mark) + (setf (line-marks ,new) ,marks)) + (let ((,charpos (mark-charpos (car ,mark)))) + (cond + ((or (> ,charpos ,bound) + (and (= ,charpos ,bound) + (eq (mark-%kind (car ,mark)) :left-inserting))) + (setf (mark-line (car ,mark)) ,new) + (setf (mark-charpos (car ,mark)) (progn ,@body)) + (if ,prev + (setf (cdr ,prev) (cdr ,mark)) + (setf (line-marks ,old) (cdr ,mark))) + (rotatef (cdr ,mark) ,marks ,mark)) + (t + (setq ,prev ,mark ,mark (cdr ,mark)))))) + `(dolist (,mark (line-marks ,old)) + (let ((,charpos (mark-charpos ,mark))) + (when (or (> ,charpos ,bound) + (and (= ,charpos ,bound) + (eq (mark-%kind ,mark) :left-inserting))) + (setf (mark-charpos ,mark) (progn ,@body)))))))) + + + +;;; Maybe-Move-Some-Marks* -- Internal +;;; +;;; Like Maybe-Move-Some-Marks, but ignores the mark %kind. +;;; +(defmacro maybe-move-some-marks* ((charpos old &optional new) bound &body body) + (let ((mark (gensym)) (marks (gensym)) (prev (gensym))) + (if new + `(do ((,mark (line-marks ,old)) + (,marks (line-marks ,new)) + (,prev ())) + ((null ,mark) + (setf (line-marks ,new) ,marks)) + (let ((,charpos (mark-charpos (car ,mark)))) + (cond + ((> ,charpos ,bound) + (setf (mark-line (car ,mark)) ,new) + (setf (mark-charpos (car ,mark)) (progn ,@body)) + (if ,prev + (setf (cdr ,prev) (cdr ,mark)) + (setf (line-marks ,old) (cdr ,mark))) + (rotatef (cdr ,mark) ,marks ,mark)) + (t + (setq ,prev ,mark ,mark (cdr ,mark)))))) + `(dolist (,mark (line-marks ,old)) + (let ((,charpos (mark-charpos ,mark))) + (when (> ,charpos ,bound) + (setf (mark-charpos ,mark) (progn ,@body)))))))) + + +;;;; Lines. + +(defun line-length (line) + "Returns the number of characters on the line." + (if (linep line) + (line-length* line) + (error "~S is not a line!" line))) + +(defun line-buffer (line) + "Returns the buffer with which the Line is associated. If the line is + not in any buffer then Nil is returned." + (let ((buffer (line-%buffer line))) + (if (bufferp buffer) buffer))) + +(defun line-string (line) + "Returns the characters in the line as a string. The resulting string + must not be destructively modified. This may be set with Setf." + (if (current-open-line-p line) + (close-line)) + (line-chars line)) + +(defun %set-line-string (line string) + (let ((buffer (line-%buffer line))) + (modifying-buffer buffer + (unless (simple-string-p string) + (setq string (coerce string 'simple-string))) + (when (current-open-line-p line) (setf (current-open-line) nil)) + (let ((length (length (the simple-string string)))) + (dolist (m (line-marks line)) + (if (eq (mark-%kind m) :left-inserting) + (setf (mark-charpos m) length) + (setf (mark-charpos m) 0)))) + (setf (line-chars line) string)))) + +(defun line-character (line index) + "Return the Index'th character in Line. If the index is the length of the + line then #\newline is returned." + (if (current-open-line-p line) + (if (< index (current-left-open-pos)) + (schar (current-open-chars) index) + (let ((index (+ index (- (current-right-open-pos) (current-left-open-pos))))) + (if (= index (current-line-cache-length)) + #\newline + (schar (current-open-chars) index)))) + (let ((chars (line-chars line))) + (declare (simple-string chars)) + (if (= index (length chars)) + #\newline + (schar chars index))))) + + +;;;; Marks. + +(defun mark (line charpos &optional (kind :temporary)) + "Returns a mark to the Charpos'th character of the Line. Kind is the + kind of mark to make, one of :temporary (the default), :left-inserting + or :right-inserting." + (let ((mark (internal-make-mark line charpos kind))) + (if (not (eq kind :temporary)) + (push mark (line-marks line))) + mark)) + +(defun mark-kind (mark) + "Returns the kind of the given Mark, :Temporary, :Left-Inserting, or + :Right-Inserting. This may be set with Setf." + (mark-%kind mark)) + +(defun %set-mark-kind (mark kind) + (let ((line (mark-line mark))) + (cond ((eq kind :temporary) + (setf (line-marks line) (delq mark (line-marks line))) + (setf (mark-%kind mark) kind)) + ((or (eq kind :left-inserting) (eq kind :right-inserting)) + (if (not (member mark (line-marks line))) + (push mark (line-marks line))) + (setf (mark-%kind mark) kind)) + (t + (error "~S is an invalid mark type." kind))))) + +(defun copy-mark (mark &optional (kind (mark-%kind mark))) + "Returns a new mark pointing to the same position as Mark. The kind + of mark created may be specified by Kind, which defaults to the + kind of the copied mark." + (let ((mark (internal-make-mark (mark-line mark) (mark-charpos mark) kind))) + (if (not (eq kind :temporary)) + (push mark (line-marks (mark-line mark)))) + mark)) + +(defun delete-mark (mark) + "Deletes the Mark. This should be done to any mark that may not be + temporary which is no longer needed." + (if (not (eq (mark-%kind mark) :temporary)) + (let ((line (mark-line mark))) + (when line + (setf (line-marks line) (delq mark (line-marks line)))) + nil)) + (setf (mark-line mark) nil)) + +(defun move-to-position (mark charpos &optional (line (mark-line mark))) + "Changes the Mark to point to the given character position on the Line, + which defaults to the line the mark is currently on." + (change-line mark line) + (setf (mark-charpos mark) charpos) + mark) + + +;;;; Regions. + +(defun region (start end) + "Returns a region constructed from the marks Start and End." + (let ((l1 (mark-line start)) + (l2 (mark-line end))) + (unless (eq (line-%buffer l1) (line-%buffer l2)) + (error "Can't make a region with lines of different buffers.")) + (unless (if (eq l1 l2) + (<= (mark-charpos start) (mark-charpos end)) + (< (line-number l1) (line-number l2))) + (error "Start ~S is after end ~S." start end))) + (internal-make-region start end)) + +;;; The *Disembodied-Buffer-Counter* exists to give that are not in any buffer +;;; unique buffer slots. + +(defvar *disembodied-buffer-counter* 0 + "``Buffer'' given to lines in regions not in any buffer.") + +(defun make-empty-region () + "Returns a region with start and end marks pointing to the start of one empty + line. The start mark is right-inserting and the end mark is left-inserting." + (let* ((line (make-line :chars "" :number 0 + :%buffer (incf *disembodied-buffer-counter*))) + (start (mark line 0 :right-inserting)) + (end (mark line 0 :left-inserting))) + (internal-make-region start end))) + +;;; Line-Increment is the default difference for line numbers when we don't +;;; know any better. + +(defconstant line-increment 256 "Default difference for line numbers.") + +;;; Renumber-Region is used internally to keep line numbers in ascending order. +;;; The lines in the region are numbered starting with the given Start value +;;; by increments of the given Step value. It returns the region. + +(defun renumber-region (region &optional (start 0) (step line-increment)) + (do ((line (mark-line (region-start region)) (line-next line)) + (last-line (mark-line (region-end region))) + (number start (+ number step))) + ((eq line last-line) + (setf (line-number line) number) + region) + (setf (line-number line) number)) + region) + +;;; Renumber-Region-Containing renumbers the region containing the given line. + +(defun renumber-region-containing (line) + (cond ((line-buffer line) + (renumber-region (buffer-region (line-%buffer line)))) + (t + (do ((line line (line-previous line)) + (number 0 (- number line-increment))) + ((null line)) + (setf (line-number line) number)) + (do ((line (line-next line) (line-next line)) + (number line-increment (+ number line-increment))) + ((null line)) + (setf (line-number line) number))))) + + +;;; Number-Line numbers a newly created line. The line has to have a previous +;;; line. +(defun number-line (line) + (let ((prev (line-number (line-previous line))) + (next (line-next line))) + (if (null next) + (setf (line-number line) (+ prev line-increment)) + (let ((new (+ prev (truncate (- (line-number next) prev) 2)))) + (if (= new prev) + (renumber-region-containing line) + (setf (line-number line) new)))))) + + + + +;;;; Buffers. + +;;; BUFFER-SIGNATURE is the exported interface to the internal function, +;;; BUFFER-MODIFIED-TICK +;;; +(defun buffer-signature (buffer) + "Returns an arbitrary number which reflects the buffers current + \"signature.\" The value returned by buffer-signature is guaranteed + to be eql to the value returned by a previous call of buffer-signature + iff the buffer has not been modified between the calls." + (unless (bufferp buffer) + (error "~S is not a buffer." buffer)) + (buffer-modified-tick buffer)) + + + + +;;;; Predicates: + + +(defun start-line-p (mark) + "Returns T if the Mark points before the first character in a line, Nil + otherwise." + (= (mark-charpos mark) 0)) + +(defun end-line-p (mark) + "Returns T if the Mark points after the last character in a line, Nil + otherwise." + (= (mark-charpos mark) (line-length (mark-line mark)))) + +(defun empty-line-p (mark) + "Returns T if the line pointer to by Mark contains no characters, Nil + or otherwise." + (let ((line (mark-line mark))) + (if (current-open-line-p line) + (and (= (current-left-open-pos) 0) (= (current-right-open-pos) (current-line-cache-length))) + (= (length (line-chars line)) 0)))) + +;;; blank-between-positions -- Internal +;;; +;;; Check if a line is blank between two positions. Used by blank-XXX-p. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro check-range (chars start end) + `(do ((i ,start (1+ i))) + ((= i ,end) t) + (when (zerop (character-attribute :whitespace (schar ,chars i))) + (return nil))))) +;;; +(defun blank-between-positions (line start end) + (if (current-open-line-p line) + (let ((gap (- (current-right-open-pos) (current-left-open-pos)))) + (cond ((>= start (current-left-open-pos)) + (check-range (current-open-chars) (+ start gap) (+ end gap))) + ((<= end (current-left-open-pos)) + (check-range (current-open-chars) start end)) + (t + (and (check-range (current-open-chars) start (current-left-open-pos)) + (check-range (current-open-chars) (current-right-open-pos) (+ end gap)))))) + (let ((chars (line-chars line))) + (check-range chars start end)))) + +(defun blank-line-p (line) + "True if line contains only characters with a :whitespace attribute of 1." + (blank-between-positions line 0 (line-length line))) + +(defun blank-before-p (mark) + "True is all of the characters before Mark on the line it is on have a + :whitespace attribute of 1." + (blank-between-positions (mark-line mark) 0 (mark-charpos mark))) + +(defun blank-after-p (mark) + "True if all characters on the part part of the line after Mark have + a :whitespace attribute of 1." + (let ((line (mark-line mark))) + (blank-between-positions line (mark-charpos mark) + (line-length line)))) + +(defun same-line-p (mark1 mark2) + "Returns T if Mark1 and Mark2 point to the same line, Nil otherwise." + (eq (mark-line mark1) (mark-line mark2))) + +(defun mark< (mark1 mark2) + "Returns T if Mark1 points to a character before Mark2, Nil otherwise." + (if (not (eq (line-%buffer (mark-line mark1)) + (line-%buffer (mark-line mark2)))) + (error "Marks in different buffers have no relation.")) + (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (< (mark-charpos mark1) (mark-charpos mark2))))) + +(defun mark<= (mark1 mark2) + "Returns T if Mark1 points to a character at or before Mark2, Nil otherwise." + (if (not (eq (line-%buffer (mark-line mark1)) + (line-%buffer (mark-line mark2)))) + (error "Marks in different buffers have no relation.")) + (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (<= (mark-charpos mark1) (mark-charpos mark2))))) + +(defun mark> (mark1 mark2) + "Returns T if Mark1 points to a character after Mark2, Nil otherwise." + (if (not (eq (line-%buffer (mark-line mark1)) + (line-%buffer (mark-line mark2)))) + (error "Marks in different buffers have no relation.")) + (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (> (mark-charpos mark1) (mark-charpos mark2))))) + +(defun mark>= (mark1 mark2) + "Returns T if Mark1 points to a character at or after Mark2, Nil otherwise." + (if (not (eq (line-%buffer (mark-line mark1)) + (line-%buffer (mark-line mark2)))) + (error "Marks in different buffers have no relation.")) + (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2))) + (>= (mark-charpos mark1) (mark-charpos mark2))))) + +(defun mark= (mark1 mark2) + "Returns T if both marks point to the same position, Nil otherwise." + (and (eq (mark-line mark1) (mark-line mark2)) + (= (mark-charpos mark1) (mark-charpos mark2)))) + +(defun mark/= (mark1 mark2) + "Returns T if both marks point to different positions, Nil otherwise." + (not (and (eq (mark-line mark1) (mark-line mark2)) + (= (mark-charpos mark1) (mark-charpos mark2))))) + +(defun line< (line1 line2) + "Returns T if Line1 comes before Line2, NIL otherwise." + (if (neq (line-%buffer line1) (line-%buffer line2)) + (error "Lines in different buffers have no relation.")) + (< (line-number line1) (line-number line2))) + +(defun line<= (line1 line2) + "Returns T if Line1 comes before or is the same as Line2, NIL otherwise." + (if (neq (line-%buffer line1) (line-%buffer line2)) + (error "Lines in different buffers have no relation.")) + (<= (line-number line1) (line-number line2))) + +(defun line>= (line1 line2) + "Returns T if Line1 comes after or is the same as Line2, NIL otherwise." + (if (neq (line-%buffer line1) (line-%buffer line2)) + (error "Lines in different buffers have no relation.")) + (>= (line-number line1) (line-number line2))) + +(defun line> (line1 line2) + "Returns T if Line1 comes after Line2, NIL otherwise." + (if (neq (line-%buffer line1) (line-%buffer line2)) + (error "Lines in different buffers have no relation.")) + (> (line-number line1) (line-number line2))) + +(defun lines-related (line1 line2) + "Returns T if an order relation exists between Line1 and Line2." + (eq (line-%buffer line1) (line-%buffer line2))) + +(defun first-line-p (mark) + "Returns T if the line pointed to by mark has no previous line, + Nil otherwise." + (null (line-previous (mark-line mark)))) + +(defun last-line-p (mark) + "Returns T if the line pointed to by mark has no next line, + Nil otherwise." + (null (line-next (mark-line mark)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext2.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext2.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext2.lisp (revision 8058) @@ -0,0 +1,525 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; More Hemlock Text-Manipulation functions. +;;; Written by Skef Wholey. +;;; +;;; The code in this file implements the non-insert/delete functions in the +;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. +;;; + +(in-package :hemlock-internals) + + + + + + +(defun region-to-string (region &optional output-string) + "Returns a string containing the characters in the given Region." + (close-line) + (let* ((dst-length (count-characters region)) + (string (if (and output-string + (<= dst-length (length output-string))) + output-string + (make-string dst-length))) + (start-mark (region-start region)) + (end-mark (region-end region)) + (start-line (mark-line start-mark)) + (end-line (mark-line end-mark)) + (start-charpos (mark-charpos start-mark))) + (declare (simple-string string)) + (if (eq start-line end-line) + (%sp-byte-blt (line-chars start-line) start-charpos string 0 + dst-length) + (let ((index ())) + (let* ((line-chars (line-chars start-line)) + (dst-end (- (length line-chars) start-charpos))) + (declare (simple-string line-chars)) + (%sp-byte-blt line-chars start-charpos string 0 dst-end) + (setf (char string dst-end) #\newline) + (setq index (1+ dst-end))) + (do* ((line (line-next start-line) (line-next line)) + (chars (line-chars line) (line-chars line))) + ((eq line end-line) + (%sp-byte-blt (line-chars line) 0 string index dst-length)) + (declare (simple-string chars)) + (%sp-byte-blt (line-chars line) 0 string index + (incf index (length chars))) + (setf (char string index) #\newline) + (setq index (1+ index))))) + (values string dst-length))) + + +(defun string-to-region (string) + "Returns a region containing the characters in the given String." + (let* ((string (if (simple-string-p string) + string (coerce string 'simple-string))) + (end (length string))) + (declare (simple-string string)) + (do* ((index 0) + (buffer (incf *disembodied-buffer-counter*)) + (previous-line) + (line (make-line :%buffer buffer)) + (first-line line)) + (()) + (let ((right-index (%sp-find-character string index end #\newline))) + (cond (right-index + (let* ((length (- right-index index)) + (chars (make-string length))) + (%sp-byte-blt string index chars 0 length) + (setf (line-chars line) chars)) + (setq index (1+ right-index)) + (setq previous-line line) + (setq line (make-line :%buffer buffer)) + (setf (line-next previous-line) line) + (setf (line-previous line) previous-line)) + (t + (let* ((length (- end index)) + (chars (make-string length))) + (%sp-byte-blt string index chars 0 length) + (setf (line-chars line) chars)) + (return (renumber-region + (internal-make-region + (mark first-line 0 :right-inserting) + (mark line (length (line-chars line)) + :left-inserting)))))))))) + +(defun line-to-region (line) + "Returns a region containing the specified line." + (internal-make-region (mark line 0 :right-inserting) + (mark line (line-length* line) :left-inserting))) + + +(defun previous-character (mark) + "Returns the character immediately before the given Mark." + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (if (= charpos 0) + (if (line-previous line) + #\newline + nil) + (if (current-open-line-p line) + (char (the simple-string (current-open-chars)) + (if (<= charpos (current-left-open-pos)) + (1- charpos) + (1- (+ (current-right-open-pos) (- charpos (current-left-open-pos)))))) + (schar (line-chars line) (1- charpos)))))) + +(defun next-character (mark) + "Returns the character immediately after the given Mark." + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (if (current-open-line-p line) + (if (= charpos (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos)))) + (if (line-next line) + #\newline + nil) + (schar (current-open-chars) + (if (< charpos (current-left-open-pos)) + charpos + (+ (current-right-open-pos) (- charpos (current-left-open-pos)))))) + (let ((chars (line-chars line))) + (if (= charpos (strlen chars)) + (if (line-next line) + #\newline + nil) + (schar chars charpos)))))) + + +;;; %Set-Next-Character -- Internal +;;; +;;; This is the setf form for Next-Character. Since we may change a +;;; character to or from a newline, we must be prepared to split and +;;; join lines. We cannot just delete a character and insert the new one +;;; because the marks would not be right. +;;; +(defun %set-next-character (mark character) + (let* ((line (mark-line mark)) + (next (line-next line)) + (buffer (line-%buffer line))) + (check-buffer-modification buffer mark) + (modifying-buffer buffer + (modifying-line line mark) + (cond ((= (mark-charpos mark) + (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos)))) + ;; The mark is at the end of the line. + (unless next + (error "~S has no next character, so it cannot be set." mark)) + (unless (char= character #\newline) + ;; If the character is no longer a newline then mash two + ;; lines together. + (let ((chars (line-chars next))) + (declare (simple-string chars)) + (setf (current-right-open-pos) (- (current-line-cache-length) (length chars))) + (when (<= (current-right-open-pos) (current-left-open-pos)) + (grow-open-chars (* (+ (length chars) (current-left-open-pos) 1) 2))) + (%sp-byte-blt chars 0 (current-open-chars) (current-right-open-pos) + (current-line-cache-length)) + (setf (schar (current-open-chars) (current-left-open-pos)) character) + (incf (current-left-open-pos))) + (move-some-marks (charpos next line) + (+ charpos (current-left-open-pos))) + (setq next (line-next next)) + (setf (line-next line) next) + (when next (setf (line-previous next) line)))) + ((char= character #\newline) + ;; The char is being changed to a newline, so we must split lines. + (incf (current-right-open-pos)) + (let* ((len (- (current-line-cache-length) (current-right-open-pos))) + (chars (make-string len)) + (new (make-line :chars chars :previous line + :next next :%buffer buffer))) + (%sp-byte-blt (current-open-chars) (current-right-open-pos) chars 0 len) + (maybe-move-some-marks* (charpos line new) (current-left-open-pos) + (- charpos (current-left-open-pos) 1)) + (setf (line-next line) new) + (when next (setf (line-previous next) new)) + (setf (current-right-open-pos) (current-line-cache-length)) + (number-line new))) + (t + (setf (char (the simple-string (current-open-chars)) (current-right-open-pos)) + character) + (hi::buffer-note-modification buffer mark 1))))) + character) + +;;; %Set-Previous-Character -- Internal +;;; +;;; The setf form for Previous-Character. We just Temporarily move the +;;; mark back one and call %Set-Next-Character. +;;; +(defun %set-previous-character (mark character) + (unless (mark-before mark) + (error "~S has no previous character, so it cannot be set." mark)) + (%set-next-character mark character) + (mark-after mark) + character) + + +(defun count-lines (region) + "Returns the number of lines in the region, first and last lines inclusive." + (do ((line (mark-line (region-start region)) (line-next line)) + (count 1 (1+ count)) + (last-line (mark-line (region-end region)))) + ((eq line last-line) count))) + +(defun count-characters (region) + "Returns the number of characters in the region." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end))) + (if (eq first-line last-line) + (- (mark-charpos end) (mark-charpos start)) + (do ((line (line-next first-line) (line-next line)) + (count (1+ (- (line-length* first-line) (mark-charpos start))))) + ((eq line last-line) + (+ count (mark-charpos end))) + (setq count (+ 1 count (line-length* line))))))) + +(defun line-start (mark &optional line) + "Changes the Mark to point to the beginning of the Line and returns it. + Line defaults to the line Mark is on." + (when line + (change-line mark line)) + (setf (mark-charpos mark) 0) + mark) + +(defun line-end (mark &optional line) + "Changes the Mark to point to the end of the line and returns it. + Line defaults to the line Mark is on." + (if line + (change-line mark line) + (setq line (mark-line mark))) + (setf (mark-charpos mark) (line-length* line)) + mark) + +(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark)))) + "Change Mark to point to the beginning of Buffer, which defaults to + the buffer Mark is currently in." + (unless buffer (error "Mark ~S does not point into a buffer.")) + (move-mark mark (buffer-start-mark buffer))) + +(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark)))) + "Change Mark to point to the end of Buffer, which defaults to + the buffer Mark is currently in." + (unless buffer (error "Mark ~S does not point into a buffer.")) + (move-mark mark (buffer-end-mark buffer))) + +(defun move-mark (mark new-position) + "Changes the Mark to point to the same position as New-Position." + (let* ((line (mark-line new-position))) + (change-line mark line)) + (setf (mark-charpos mark) (mark-charpos new-position)) + mark) + + + +(defun mark-before (mark) + "Changes the Mark to point one character before where it currently points. + NIL is returned if there is no previous character." + (let ((charpos (mark-charpos mark))) + (cond ((zerop charpos) + (let ((prev (line-previous (mark-line mark)))) + (when prev + (always-change-line mark prev) + (setf (mark-charpos mark) (line-length* prev)) + mark))) + (t + (setf (mark-charpos mark) (1- charpos)) + mark)))) + +(defun mark-after (mark) + "Changes the Mark to point one character after where it currently points. + NIL is returned if there is no previous character." + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (cond ((= charpos (line-length* line)) + (let ((next (line-next line))) + (when next + (always-change-line mark next) + (setf (mark-charpos mark) 0) + mark))) + (t + (setf (mark-charpos mark) (1+ charpos)) + mark)))) + + +(defun character-offset (mark n) + "Changes the Mark to point N characters after (or -N before if N is negative) + where it currently points. If there aren't N characters before (or after) + the mark, Nil is returned." + (let* ((charpos (mark-charpos mark))) + (if (< n 0) + (let ((n (- n))) + (if (< charpos n) + (do ((line (line-previous (mark-line mark)) (line-previous line)) + (n (- n charpos 1))) + ((null line) nil) + (let ((length (line-length* line))) + (cond ((<= n length) + (always-change-line mark line) + (setf (mark-charpos mark) (- length n)) + (return mark)) + (t + (setq n (- n (1+ length))))))) + (progn (setf (mark-charpos mark) (- charpos n)) + mark))) + (let* ((line (mark-line mark)) + (length (line-length* line))) + (if (> (+ charpos n) length) + (do ((line (line-next line) (line-next line)) + (n (- n (1+ (- length charpos))))) + ((null line) nil) + (let ((length (line-length* line))) + (cond ((<= n length) + (always-change-line mark line) + (setf (mark-charpos mark) n) + (return mark)) + (t + (setq n (- n (1+ length))))))) + (progn (setf (mark-charpos mark) (+ charpos n)) + mark)))))) + + +(defun line-offset (mark n &optional charpos) + "Changes to Mark to point N lines after (-N before if N is negative) where + it currently points. If there aren't N lines after (or before) the Mark, + Nil is returned." + (if (< n 0) + (do ((line (mark-line mark) (line-previous line)) + (n n (1+ n))) + ((null line) nil) + (when (= n 0) + (always-change-line mark line) + (setf (mark-charpos mark) + (if charpos + (min (line-length line) charpos) + (min (line-length line) (mark-charpos mark)))) + (return mark))) + (do ((line (mark-line mark) (line-next line)) + (n n (1- n))) + ((null line) nil) + (when (= n 0) + (change-line mark line) + (setf (mark-charpos mark) + (if charpos + (min (line-length line) charpos) + (min (line-length line) (mark-charpos mark)))) + (return mark))))) + +;;; region-bounds -- Public +;;; +(defun region-bounds (region) + "Return as multiple-value the start and end of Region." + (values (region-start region) (region-end region))) + +(defun set-region-bounds (region start end) + "Set the start and end of Region to the marks Start and End." + (let ((sl (mark-line start)) + (el (mark-line end))) + (when (or (neq (line-%buffer sl) (line-%buffer el)) + (> (line-number sl) (line-number el)) + (and (eq sl el) (> (mark-charpos start) (mark-charpos end)))) + (error "Marks ~S and ~S cannot be made into a region." start end)) + (setf (region-start region) start (region-end region) end)) + region) + + + +;;;; Debugging stuff. + +(defun slf (string) + "For a good time, figure out what this function does, and why it was written." + (delete #\linefeed (the simple-string string))) + +(defun %print-whole-line (structure stream) + (let* ((hi::*current-buffer* (line-buffer structure))) + (cond ((current-open-line-p structure) + (write-string (current-open-chars) stream :end (current-left-open-pos)) + (write-string (current-open-chars) stream :start (current-right-open-pos) + :end (current-line-cache-length))) + (t + (write-string (line-chars structure) stream))))) + +(defun %print-before-mark (mark stream) + (let* ((hi::*current-buffer* (line-buffer (mark-line mark)))) + (if (mark-line mark) + (let* ((line (mark-line mark)) + (chars (line-chars line)) + (charpos (mark-charpos mark)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + ((current-open-line-p line) + (cond ((< charpos (current-left-open-pos)) + (write-string (current-open-chars) stream :end charpos)) + (t + (write-string (current-open-chars) stream :end (current-left-open-pos)) + (let ((p (+ charpos (- (current-right-open-pos) (current-left-open-pos))))) + (write-string (current-open-chars) stream :start (current-right-open-pos) + :end p))))) + (t + (write-string chars stream :end charpos)))) + (write-string "{deleted mark}" stream)))) + + +(defun %print-after-mark (mark stream) + (let* ((hi::*current-buffer* (line-buffer (mark-line mark)))) + (if (mark-line mark) + (let* ((line (mark-line mark)) + (chars (line-chars line)) + (charpos (mark-charpos mark)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + ((current-open-line-p line) + (cond ((< charpos (current-left-open-pos)) + (write-string (current-open-chars) stream :start charpos + :end (current-left-open-pos)) + (write-string (current-open-chars) stream :start (current-right-open-pos) + :end (current-line-cache-length))) + (t + (let ((p (+ charpos (- (current-right-open-pos) (current-left-open-pos))))) + (write-string (current-open-chars) stream :start p + :end (current-line-cache-length)))))) + (t + (write-string chars stream :start charpos :end length)))) + (write-string "{deleted mark}" stream)))) + +(defun %print-hline (structure stream d) + (declare (ignore d)) + (write-string "#" stream)) + +(defun %print-hmark (structure stream d) + (declare (ignore d)) + (let ((hi::*current-buffer* (line-buffer (mark-line structure)))) + (write-string "#" stream))) + +(defvar *print-region* 10 + "The number of lines to print out of a region, or NIL if none.") + +(defun %print-hregion (region stream d) + (declare (ignore d)) + (write-string "# ce len)) + (write-string "{bad region}" stream)) + ((current-open-line-p first-line) + (let ((gap (- (current-right-open-pos) (current-left-open-pos)))) + (cond + ((<= ce (current-left-open-pos)) + (write-string (current-open-chars) stream :start cs :end ce)) + ((>= cs (current-left-open-pos)) + (write-string (current-open-chars) stream :start (+ cs gap) + :end (+ ce gap))) + (t + (write-string (current-open-chars) stream :start cs + :end (current-left-open-pos)) + (write-string (current-open-chars) stream :start (current-right-open-pos) + :end (+ gap ce)))))) + (t + (write-string (line-chars first-line) stream :start cs + :end ce))))) + (t + (%print-after-mark start stream) + (write-char #\/ stream) + (do ((line (line-next first-line) (line-next line)) + (last-line (mark-line end)) + (cnt *print-region* (1- cnt))) + ((or (eq line last-line) + (when (zerop cnt) (write-string "..." stream) t)) + (%print-before-mark end stream)) + (%print-whole-line line stream) + (write-char #\/ stream))))) + (t + (write-string "{mumble}" stream)))) + (write-string "\">" stream)) + +(defun %print-hbuffer (structure stream d) + (declare (ignore d)) + (write-string "#" stream)) + +(defun check-buffer-modification (buffer mark) + (when (typep buffer 'buffer) + (let* ((protected-region (buffer-protected-region buffer))) + (when protected-region + (let* ((prot-start (region-start protected-region)) + (prot-end (region-end protected-region))) + + (when (and (mark>= mark prot-start) + (mark< mark prot-end)) + (editor-error "Can't modify protected buffer region."))))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext3.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext3.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext3.lisp (revision 8058) @@ -0,0 +1,273 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; More Hemlock Text-Manipulation functions. +;;; Written by Skef Wholey. +;;; +;;; The code in this file implements the insert functions in the +;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. +;;; + +(in-package :hemlock-internals) + +;;; Return (and deactivate) the current region. +(defun %buffer-current-region (b) + (when (and (typep b 'buffer) + (variable-value 'hemlock::active-regions-enabled) + (eql (buffer-signature b) + (buffer-region-active b))) + (let* ((mark (buffer-%mark b)) + (point (buffer-point b))) + (setf (buffer-region-active b) nil) + (if (mark< mark point) + (region mark point) + (region point mark))))) + +;;; Return T if the buffer has an active region (without deactivating +;;; it), NIL otherwise. +(defun %buffer-current-region-p (b) + (and (typep b 'buffer) + (variable-value 'hemlock::active-regions-enabled) + (eql (buffer-signature b) + (buffer-region-active b)))) + + + + + +(defun insert-character (mark character) + "Inserts the Character at the specified Mark." + (declare (type base-char character)) + (let* ((line (mark-line mark)) + (buffer (line-%buffer line))) + (modifying-buffer buffer + (modifying-line line mark) + (cond ((char= character #\newline) + (let* ((next (line-next line)) + (new-chars (subseq (the simple-string (current-open-chars)) + 0 (current-left-open-pos))) + (new-line (make-line :%buffer buffer + :chars (decf *cache-modification-tick*) + :previous line + :next next))) + (maybe-move-some-marks (charpos line new-line) (current-left-open-pos) + (- charpos (current-left-open-pos))) + (setf (line-%chars line) new-chars) + (setf (line-next line) new-line) + (if next (setf (line-previous next) new-line)) + (number-line new-line) + (setf (current-open-line) new-line + (current-left-open-pos) 0))) + (t + (if (= (current-right-open-pos) (current-left-open-pos)) + (grow-open-chars)) + + (maybe-move-some-marks (charpos line) (current-left-open-pos) + (1+ charpos)) + + (cond + ((eq (mark-%kind mark) :right-inserting) + (decf (current-right-open-pos)) + (setf (char (the simple-string (current-open-chars)) (current-right-open-pos)) + character)) + (t + (setf (char (the simple-string (current-open-chars)) (current-left-open-pos)) + character) + (incf (current-left-open-pos)))))) + (adjust-line-origins-forward line) + (buffer-note-insertion buffer mark 1)))) + + + +(defun insert-string (mark string #| &optional (start 0) (end (length string))|#) + "Inserts the String at the Mark. Do not use Start and End unless you + know what you're doing!" + (let* ((line (mark-line mark)) + (len (length string)) + (buffer (line-%buffer line)) + (string (coerce string 'simple-string))) + (declare (simple-string string)) + (unless (zerop len) + (if (%sp-find-character string 0 len #\newline) + (ninsert-region mark (string-to-region string)) + (modifying-buffer + buffer + (progn + (modifying-line line mark) + (if (<= (current-right-open-pos) (+ (current-left-open-pos) len)) + (grow-open-chars (* (+ (current-line-cache-length) len) 2))) + (maybe-move-some-marks (charpos line) (current-left-open-pos) + (+ charpos len)) + (cond + ((eq (mark-%kind mark) :right-inserting) + (let ((new (- (current-right-open-pos) len))) + (%sp-byte-blt string 0 (current-open-chars) new (current-right-open-pos)) + (setf (current-right-open-pos) new))) + (t + (let ((new (+ (current-left-open-pos) len))) + (%sp-byte-blt string 0 (current-open-chars) (current-left-open-pos) new) + (setf (current-left-open-pos) new))))) + (adjust-line-origins-forward line) + (buffer-note-insertion buffer mark (length string))))))) + + + + + +(defconstant line-number-interval-guess 8 + "Our first guess at how we should number an inserted region's lines.") + +(defun insert-region (mark region) + "Inserts the given Region at the Mark." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end)) + (nins (count-characters region))) + (cond + ((eq first-line last-line) + ;; simple case -- just BLT the characters in with insert-string + (if (current-open-line-p first-line) (close-line)) + (let* ((string (line-chars first-line))) + (unless (and (eql first-charpos 0) + (eql last-charpos (length string))) + (setq string (subseq string first-charpos last-charpos))) + (insert-string mark string))) + (t + (close-line) + (let* ((line (mark-line mark)) + (next (line-next line)) + (charpos (mark-charpos mark)) + (buffer (line-%buffer line)) + (old-chars (line-chars line))) + (declare (simple-string old-chars)) + (modifying-buffer buffer + ;;hack marked line's chars + (let* ((first-chars (line-chars first-line)) + (first-length (length first-chars)) + (new-length (+ charpos (- first-length first-charpos))) + (new-chars (make-string new-length))) + (declare (simple-string first-chars new-chars)) + (%sp-byte-blt old-chars 0 new-chars 0 charpos) + (%sp-byte-blt first-chars first-charpos new-chars charpos new-length) + (setf (line-chars line) new-chars)) + + ;; Copy intervening lines. We don't link the lines in until we are + ;; done in case the mark is within the region we are inserting. + (do* ((this-line (line-next first-line) (line-next this-line)) + (number (+ (line-number line) line-number-interval-guess) + (+ number line-number-interval-guess)) + (first (%copy-line this-line :previous line + :%buffer buffer :number number)) + (previous first) + (new-line first (%copy-line this-line :previous previous + :%buffer buffer :number number))) + ((eq this-line last-line) + ;;make last line + (let* ((last-chars (line-chars new-line)) + (old-length (length old-chars)) + (new-length (+ last-charpos (- old-length charpos))) + (new-chars (make-string new-length))) + (%sp-byte-blt last-chars 0 new-chars 0 last-charpos) + (%sp-byte-blt old-chars charpos new-chars last-charpos + new-length) + (setf (line-next line) first) + (setf (line-chars new-line) new-chars) + (setf (line-next previous) new-line) + (setf (line-next new-line) next) + (when next + (setf (line-previous next) new-line) + (if (<= (line-number next) number) + (renumber-region-containing new-line))) + ;;fix up the marks + (maybe-move-some-marks (this-charpos line new-line) charpos + (+ last-charpos (- this-charpos charpos))))) + (setf (line-next previous) new-line previous new-line)) + (adjust-line-origins-forward line) + (buffer-note-insertion buffer mark nins))))))) + + +(defun ninsert-region (mark region) + "Inserts the given Region at the Mark, possibly destroying the Region. + Region may not be a part of any buffer's region." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end)) + (nins (count-characters region))) + (cond + ((eq first-line last-line) + ;; Simple case -- just BLT the characters in with insert-string. + (if (current-open-line-p first-line) (close-line)) + (let* ((string (line-chars first-line))) + (unless (and (eq first-charpos 0) + (eql last-charpos (length string))) + (setq string (subseq string first-charpos last-charpos))) + (insert-string mark string))) + (t + (when (bufferp (line-%buffer first-line)) + (error "Region is linked into Buffer ~S." (line-%buffer first-line))) + (close-line) + (let* ((line (mark-line mark)) + (second-line (line-next first-line)) + (next (line-next line)) + (charpos (mark-charpos mark)) + (buffer (line-%buffer line)) + (old-chars (line-chars line))) + (declare (simple-string old-chars)) + (modifying-buffer buffer + ;; Make new chars for first and last lines. + (let* ((first-chars (line-chars first-line)) + (first-length (length first-chars)) + (new-length (+ charpos (- first-length first-charpos))) + (new-chars (make-string new-length))) + (declare (simple-string first-chars new-chars)) + (%sp-byte-blt old-chars 0 new-chars 0 charpos) + (%sp-byte-blt first-chars first-charpos new-chars charpos + new-length) + (setf (line-chars line) new-chars)) + (let* ((last-chars (line-chars last-line)) + (old-length (length old-chars)) + (new-length (+ last-charpos (- old-length charpos))) + (new-chars (make-string new-length))) + (%sp-byte-blt last-chars 0 new-chars 0 last-charpos) + (%sp-byte-blt old-chars charpos new-chars last-charpos new-length) + (setf (line-chars last-line) new-chars)) + + ;;; Link stuff together. + (setf (line-next last-line) next) + (setf (line-next line) second-line) + (setf (line-previous second-line) line) + + ;;Number the inserted stuff and mash any marks. + (do ((line second-line (line-next line)) + (number (+ (line-number line) line-number-interval-guess) + (+ number line-number-interval-guess))) + ((eq line next) + (when next + (setf (line-previous next) last-line) + (if (<= (line-number next) number) + (renumber-region-containing last-line)))) + (when (line-marks line) + (dolist (m (line-marks line)) + (setf (mark-line m) nil)) + (setf (line-marks line) nil)) + (setf (line-number line) number (line-%buffer line) buffer)) + + ;; Fix up the marks in the line inserted into. + (maybe-move-some-marks (this-charpos line last-line) charpos + (+ last-charpos (- this-charpos charpos))) + (adjust-line-origins-forward line) + (buffer-note-insertion buffer mark nins))))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext4.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext4.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/htext4.lisp (revision 8058) @@ -0,0 +1,442 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; More Hemlock Text-Manipulation functions. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; Modified by Bill Chiles. +;;; +;;; The code in this file implements the delete and copy functions in the +;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. +;;; + +(in-package :hemlock-internals) + + + +;;;; DELETE-CHARACTERS. + +(defvar *internal-temp-region* (make-empty-region)) +(defvar *internal-temp-mark* (internal-make-mark nil nil :temporary)) + + + +(defun delete-characters (mark &optional (n 1)) + "Deletes N characters after the mark (or -N before if N is negative)." + (let* ((line (mark-line mark)) + (charpos (mark-charpos mark)) + (length (line-length* line))) + (check-buffer-modification (line-%buffer line) mark) + (cond + ((zerop n) t) + ;; Deleting chars on one line, just bump the pointers. + ((<= 0 (+ charpos n) length) + (let* ((buffer (line-%buffer line))) + (modifying-buffer buffer + (modifying-line line mark) + (cond + ((minusp n) + (setf (current-left-open-pos) (+ (current-left-open-pos) n)) + (move-some-marks (pos line) + (if (> pos (current-left-open-pos)) + (if (<= pos charpos) (current-left-open-pos) (+ pos n)) + pos))) + + (t + (setf (current-right-open-pos) (+ (current-right-open-pos) n)) + (let ((bound (+ charpos n))) + (move-some-marks (pos line) + (if (> pos charpos) + (if (<= pos bound) (current-left-open-pos) (- pos n)) + pos))))) + (adjust-line-origins-forward line) + (buffer-note-deletion buffer mark n) + t))) + + ;; Deleting some newlines, punt out to delete-region. + (t + (setf (mark-line *internal-temp-mark*) line + (mark-charpos *internal-temp-mark*) charpos) + (let ((other-mark (character-offset *internal-temp-mark* n))) + (cond + (other-mark + (if (< n 0) + (setf (region-start *internal-temp-region*) other-mark + (region-end *internal-temp-region*) mark) + (setf (region-start *internal-temp-region*) mark + (region-end *internal-temp-region*) other-mark)) + (delete-region *internal-temp-region*) t) + (t nil))))))) + + + + +;;;; DELETE-REGION. + +(defun delete-region (region) + "Deletes the Region." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end)) + (buffer (line-%buffer first-line)) + (ndel (count-characters region))) + (unless (and (eq first-line last-line) + (= first-charpos last-charpos)) + (modifying-buffer buffer + (cond ((eq first-line last-line) + ;; Simple case -- just skip over the characters: + (modifying-line first-line start) + (let ((num (- last-charpos first-charpos))) + (setf (current-right-open-pos) (+ (current-right-open-pos) num)) + ;; and fix up any marks in there: + (move-some-marks (charpos first-line) + (if (> charpos first-charpos) + (if (<= charpos last-charpos) + first-charpos + (- charpos num)) + charpos)))) + (t + ;; hairy case -- squish lines together: + (close-line) + (let* ((first-chars (line-chars first-line)) + (last-chars (line-chars last-line)) + (last-length (length last-chars))) + (declare (simple-string last-chars first-chars)) + ;; Cons new chars for the first line. + (let* ((length (+ first-charpos (- last-length last-charpos))) + (new-chars (make-string length))) + (%sp-byte-blt first-chars 0 new-chars 0 first-charpos) + (%sp-byte-blt last-chars last-charpos new-chars first-charpos + length) + (setf (line-chars first-line) new-chars)) + ;; fix up the first line's marks: + (move-some-marks (charpos first-line) + (if (> charpos first-charpos) + first-charpos + charpos)) + ;; fix up the marks of the lines in the middle and mash + ;;line-%buffer: + (do* ((line (line-next first-line) (line-next line)) + (count (incf *disembodied-buffer-counter*))) + ((eq line last-line) + (setf (line-%buffer last-line) count)) + (setf (line-%buffer line) count) + (move-some-marks (ignore line first-line) + (declare (ignore ignore)) + first-charpos)) + ;; and fix up the last line's marks: + (move-some-marks (charpos last-line first-line) + (if (<= charpos last-charpos) + first-charpos + (+ (- charpos last-charpos) + first-charpos))) + ;; And splice the losers out: + (let ((next (line-next last-line))) + (setf (line-next first-line) next) + (when next (setf (line-previous next) first-line)))))) + (adjust-line-origins-forward first-line) + (buffer-note-deletion buffer start ndel))))) + + + + +;;;; DELETE-AND-SAVE-REGION. + +(defun delete-and-save-region (region) + "Deletes Region and returns a region containing the deleted characters." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end)) + (buffer (line-%buffer first-line)) + (ndel (count-characters region))) + (check-buffer-modification buffer start) + (check-buffer-modification buffer end) + (cond + ((and (eq first-line last-line) + (= first-charpos last-charpos)) + (make-empty-region)) + (t + (modifying-buffer + buffer + (prog1 + (cond ((eq first-line last-line) + ;; simple case -- just skip over the characters: + (modifying-line first-line start) + (let* ((num (- last-charpos first-charpos)) + (new-right (+ (current-right-open-pos) num)) + (new-chars (make-string num)) + (new-line (make-line + :chars new-chars :number 0 + :%buffer (incf *disembodied-buffer-counter*)))) + (declare (simple-string new-chars)) + (%sp-byte-blt (current-open-chars) (current-right-open-pos) new-chars 0 num) + (setf (current-right-open-pos) new-right) + ;; and fix up any marks in there: + (move-some-marks (charpos first-line) + (if (> charpos first-charpos) + (if (<= charpos last-charpos) + first-charpos + (- charpos num)) + charpos)) + ;; And return the region with the nuked characters: + (internal-make-region (mark new-line 0 :right-inserting) + (mark new-line num :left-inserting)))) + (t + ;; hairy case -- squish lines together: + (close-line) + (let* ((first-chars (line-chars first-line)) + (last-chars (line-chars last-line)) + (first-length (length first-chars)) + (last-length (length last-chars)) + (saved-first-length (- first-length first-charpos)) + (saved-first-chars (make-string saved-first-length)) + (saved-last-chars (make-string last-charpos)) + (count (incf *disembodied-buffer-counter*)) + (saved-line (make-line :chars saved-first-chars + :%buffer count))) + (declare (simple-string first-chars last-chars + saved-first-chars saved-last-chars)) + ;; Cons new chars for victim line. + (let* ((length (+ first-charpos (- last-length last-charpos))) + (new-chars (make-string length))) + (%sp-byte-blt first-chars 0 new-chars 0 first-charpos) + (%sp-byte-blt last-chars last-charpos new-chars first-charpos + length) + (setf (line-chars first-line) new-chars)) + ;; Make a region with all the lost stuff: + (%sp-byte-blt first-chars first-charpos saved-first-chars 0 + saved-first-length) + (%sp-byte-blt last-chars 0 saved-last-chars 0 last-charpos) + ;; Mash the chars and buff of the last line. + (setf (line-chars last-line) saved-last-chars + (line-%buffer last-line) count) + ;; fix up the marks of the lines in the middle and mash + ;;line-%buffer: + (do ((line (line-next first-line) (line-next line))) + ((eq line last-line) + (setf (line-%buffer last-line) count)) + (setf (line-%buffer line) count) + (move-some-marks (ignore line first-line) + (declare (ignore ignore)) + first-charpos)) + ;; And splice the losers out: + (let ((next (line-next first-line)) + (after (line-next last-line))) + (setf (line-next saved-line) next + (line-previous next) saved-line + (line-next first-line) after) + (when after + (setf (line-previous after) first-line + (line-next last-line) nil))) + + ;; fix up the first line's marks: + (move-some-marks (charpos first-line) + (if (> charpos first-charpos) + first-charpos + charpos)) + ;; and fix up the last line's marks: + (move-some-marks (charpos last-line first-line) + (if (<= charpos last-charpos) + first-charpos + (+ (- charpos last-charpos) + first-charpos))) + ;; And return the region with the nuked characters: + (renumber-region + (internal-make-region + (mark saved-line 0 :right-inserting) + (mark last-line last-charpos :left-inserting)))))) + (adjust-line-origins-forward first-line) + (buffer-note-deletion buffer start ndel))))))) + + + + +;;;; COPY-REGION. + +(defun copy-region (region) + "Returns a region containing a copy of the text within Region." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end)) + (count (incf *disembodied-buffer-counter*))) + (cond + ((eq first-line last-line) + (when (current-open-line-p first-line) (close-line)) + (let* ((length (- last-charpos first-charpos)) + (chars (make-string length)) + (line (make-line :chars chars :%buffer count :number 0))) + (%sp-byte-blt (line-chars first-line) first-charpos chars 0 length) + (internal-make-region (mark line 0 :right-inserting) + (mark line length :left-inserting)))) + (t + (close-line) + (let* ((first-chars (line-chars first-line)) + (length (- (length first-chars) first-charpos)) + (chars (make-string length)) + (first-copied-line (make-line :chars chars :%buffer count + :number 0))) + (declare (simple-string first-chars)) + (%sp-byte-blt first-chars first-charpos chars 0 length) + (do ((line (line-next first-line) (line-next line)) + (previous first-copied-line) + (number line-increment (+ number line-increment))) + ((eq line last-line) + (let* ((chars (make-string last-charpos)) + (last-copied-line (make-line :chars chars + :number number + :%buffer count + :previous previous))) + (%sp-byte-blt (line-chars last-line) 0 chars 0 last-charpos) + (setf (line-next previous) last-copied-line) + (internal-make-region + (mark first-copied-line 0 :right-inserting) + (mark last-copied-line last-charpos :left-inserting)))) + (let* ((new-line (%copy-line line :%buffer count + :number number + :previous previous))) + (setf (line-next previous) new-line) + (setq previous new-line)))))))) + + + + +;;;; FILTER-REGION. + +(eval-when (:compile-toplevel :execute) +(defmacro fcs (fun str) + `(let ((rs (funcall ,fun ,str))) + (if (simple-string-p rs) rs + (coerce rs 'simple-string)))) +); eval-when + +;;; FILTER-REGION -- Public +;;; +;;; After we deal with the nasty boundry conditions of the first and +;;; last lines, we just scan through lines in the region replacing their +;;; chars with the result of applying the function to the chars. +;;; +(defun filter-region (function region) + "This function filters the text in a region though a Lisp function. The + argument function must map from a string to a string. It is passed each + line string from region in order, and each resulting string replaces the + original. The function must neither destructively modify its argument nor + modify the result string after it is returned. The argument will always be + a simple-string. It is an error for any string returned to contain + newlines." + (let* ((start (region-start region)) + (count (hemlock::count-characters region)) + (origin (copy-mark start :right-inserting)) + (start-line (mark-line start)) + (first (mark-charpos start)) + (end (region-end region)) + (end-line (mark-line end)) + (last (mark-charpos end)) + (marks ()) + (buffer (line-%buffer start-line))) + (check-buffer-modification buffer start) + (check-buffer-modification buffer end) + (modifying-buffer buffer + (modifying-line end-line end) + (cond ((eq start-line end-line) + (let* ((res (fcs function (subseq (current-open-chars) first last))) + (rlen (length res)) + (new-left (+ first rlen)) + (delta (- new-left (current-left-open-pos)))) + (declare (simple-string res)) + (when (> new-left (current-right-open-pos)) + (grow-open-chars (+ new-left (current-line-cache-length)))) + (%sp-byte-blt res 0 (current-open-chars) first (current-left-open-pos)) + ;; + ;; Move marks to start or end of region, depending on kind. + (dolist (m (line-marks start-line)) + (let ((charpos (mark-charpos m))) + (when (>= charpos first) + (setf (mark-charpos m) + (if (<= charpos last) + (if (eq (mark-%kind m) :left-inserting) + new-left first) + (+ charpos delta)))))) + (setf (current-left-open-pos) new-left))) + (t + ;; + ;; Do the chars for the first line. + (let* ((first-chars (line-chars start-line)) + (first-len (length first-chars)) + (res (fcs function (subseq first-chars first first-len))) + (rlen (length res)) + (nlen (+ first rlen)) + (new (make-string nlen))) + (declare (simple-string res first-chars new)) + (%sp-byte-blt first-chars 0 new 0 first) + (%sp-byte-blt res 0 new first nlen) + (setf (line-%chars start-line) new)) + ;; + ;; Fix up marks on the first line, saving any within the region + ;; to be dealt with later. + (let ((outside ())) + (dolist (m (line-marks start-line)) + (if (<= (mark-charpos m) first) + (push m outside) (push m marks))) + (setf (line-marks start-line) outside)) + ;; + ;; Do chars of intermediate lines in the region, saving their + ;; marks. + (do ((line (line-next start-line) (line-next line))) + ((eq line end-line)) + (when (line-marks line) + (setq marks (nconc (line-marks line) marks)) + (setf (line-marks line) nil)) + (setf (line-%chars line) (fcs function (line-chars line)))) + ;; + ;; Do the last line, which is cached. + (let* ((res (fcs function (subseq (the simple-string (current-open-chars)) + 0 last))) + (rlen (length res)) + (delta (- rlen last))) + (declare (simple-string res)) + (when (> rlen (current-right-open-pos)) + (grow-open-chars (+ rlen (current-line-cache-length)))) + (%sp-byte-blt res 0 (current-open-chars) 0 rlen) + (setf (current-left-open-pos) rlen) + ;; + ;; Adjust marks after the end of the region and save ones in it. + (let ((outside ())) + (dolist (m (line-marks end-line)) + (let ((charpos (mark-charpos m))) + (cond ((> charpos last) + (setf (mark-charpos m) (+ charpos delta)) + (push m outside)) + (t + (push m marks))))) + (setf (line-marks end-line) outside)) + ;; + ;; Scan over saved marks, moving them to the correct end of the + ;; region. + (dolist (m marks) + (cond ((eq (mark-%kind m) :left-inserting) + (setf (mark-charpos m) rlen) + (setf (mark-line m) end-line) + (push m (line-marks end-line))) + (t + (setf (mark-charpos m) first) + (setf (mark-line m) start-line) + (push m (line-marks start-line))))))))) + (hi::buffer-note-modification buffer origin count) + (delete-mark origin) + region)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/icom.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/icom.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/icom.lisp (revision 8058) @@ -0,0 +1,74 @@ +;;; -*- Package: hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This is an italicized comment. + +(in-package :hemlock) + +(defun delete-line-italic-marks (line) + (dolist (m (hi::line-marks line)) + (when (and (hi::fast-font-mark-p m) + (eql (hi::font-mark-font m) 1)) + (delete-font-mark m)))) + +(defun set-comment-font (region font) + (do ((line (mark-line (region-start region)) + (line-next line)) + (end (line-next (mark-line (region-end region))))) + ((eq line end)) + (delete-line-italic-marks line) + (let ((pos (position #\; (the simple-string (line-string line))))) + (when pos + (font-mark line pos font :left-inserting))))) + +(defun delete-italic-marks-region (region) + (do ((line (mark-line (region-start region)) + (line-next line)) + (end (line-next (mark-line (region-end region))))) + ((eq line end)) + (delete-line-italic-marks line))) + + +(defmode "Italic" + :setup-function + #'(lambda (buffer) (set-comment-font (buffer-region buffer) 1)) + :cleanup-function + #'(lambda (buffer) (delete-italic-marks-region (buffer-region buffer)))) + +(define-file-option "Italicize Comments" (buffer value) + (declare (ignore value)) + (setf (buffer-minor-mode buffer "Italic") t)) + +(defcommand "Italic Comment Mode" (p) + "Toggle \"Italic\" mode in the current buffer. When in \"Italic\" mode, + semicolon comments are displayed in an italic font." + "Toggle \"Italic\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Italic") + (not (buffer-minor-mode (current-buffer) "Italic")))) + + +(defcommand "Start Italic Comment" (p) + "Italicize the text in this comment." + "Italicize the text in this comment." + (declare (ignore p)) + (let* ((point (current-point)) + (pos (mark-charpos point)) + (line (mark-line point))) + (delete-line-italic-marks line) + (insert-character point #\;) + (font-mark + line + (or (position #\; (the simple-string (line-string line))) pos) + 1 + :left-inserting))) + +(bind-key "Start Italic Comment" #k";" :mode "Italic") Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/indent.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/indent.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/indent.lisp (revision 8058) @@ -0,0 +1,293 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock indentation commands +;;; +;;; Written by Bill Maddox and Bill Chiles +;;; +(in-package :hemlock) + + + +(defhvar "Spaces per Tab" + "The number of spaces a tab is equivalent to. NOTE: This is not incorporated + everywhere in Hemlock yet, so do not change it." + :value 8) + +(defun indent-using-tabs (mark column) + "Inserts at mark a maximum number of tabs and a minimum number of spaces to + move mark to column. This assumes mark is at the beginning of a line." + (multiple-value-bind (tabs spaces) (floor column (value spaces-per-tab)) + (dotimes (i tabs) (insert-character mark #\tab)) + (dotimes (i spaces) (insert-character mark #\space)))) + +(defun indent-using-spaces (mark column) + "Inserts some spaces at MARK so that it moves to COLUMN. This assumes + mark is at the beginning of a line." + (insert-string mark (make-string column :initial-element #\space))) + + +(defhvar "Indent with Tabs" + "Function that takes a mark and a number of spaces and inserts tabs and spaces + to indent that number of spaces using \"Spaces per Tab\"." + :value #'indent-using-tabs) + + +(defun tab-to-tab-stop (mark) + (insert-character mark #\tab)) + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It takes a :left-inserting mark that may be moved." + :value #'tab-to-tab-stop) + + +(defun generic-indent (mark) + (let* ((line (mark-line mark)) + (prev (do ((line (line-previous line) (line-previous line))) + ((or (null line) (not (blank-line-p line))) line)))) + (unless prev (editor-error)) + (line-start mark prev) + (find-attribute mark :space #'zerop) + (let ((indentation (mark-column mark))) + (line-start mark line) + (delete-horizontal-space mark) + (funcall (value indent-with-tabs) mark indentation)))) + + +(defcommand "Indent New Line" (p) + "Moves point to a new blank line and indents it. + Any whitespace before point is deleted. The value of \"Indent Function\" + is used for indentation unless there is a Fill Prefix, in which case it is + used. Any argument is passed onto \"New Line\"." + "Moves point to a new blank line and indents it. + Any whitespace before point is deleted. The value of \"Indent Function\" + is used for indentation unless there is a Fill Prefix, in which case it is + used. Any argument is passed onto \"New Line\"." + (let ((point (current-point)) + (prefix (value fill-prefix))) + (delete-horizontal-space point) + (new-line-command p) + (if prefix + (insert-string point prefix) + (funcall (value indent-function) point)))) + + +(defcommand "Indent" (p) + "Invokes function held by the Hemlock variable \"Indent Function\", + moving point past region if called with argument." + "Invokes function held by the Hemlock variable \"Indent Function\" + moving point past region if called with argument." + (let ((point (current-point))) + (with-mark ((mark point :left-inserting)) + (cond ((or (not p) (zerop p)) + (funcall (value indent-function) mark) + (when (mark< point mark) + (move-mark point mark))) + (t + (if (plusp p) + (unless (line-offset point (1- p)) + (buffer-end point)) + (unless (line-offset mark (1+ p)) + (buffer-start mark))) + (indent-region-for-commands (region mark point)) + (find-attribute (line-start point) :whitespace #'zerop)))))) + +(defcommand "Indent Region" (p) + "Invokes function held by Hemlock variable \"Indent Function\" on every + line between point and mark, inclusively." + "Invokes function held by Hemlock variable \"Indent Function\" on every + line between point and mark, inclusively." + (declare (ignore p)) + (let* ((region (current-region))) + (with-mark ((start (region-start region) :left-inserting) + (end (region-end region) :left-inserting)) + (indent-region-for-commands (region start end))))) + +(defun indent-region-for-commands (region) + "Indents region undoably with INDENT-REGION." + (let* ((start (region-start region)) + (end (region-end region)) + (undo-region (copy-region (region (line-start start) (line-end end))))) + (indent-region region) + (make-region-undo :twiddle "Indent" + (region (line-start (copy-mark start :left-inserting)) + (line-end (copy-mark end :right-inserting))) + undo-region))) + +(defun indent-region (region) + "Invokes function held by Hemlock variable \"Indent Function\" on every + line of region." + (let ((indent-function (value indent-function))) + (with-mark ((start (region-start region) :left-inserting) + (end (region-end region))) + (line-start start) + (line-start end) + (loop (when (mark= start end) + (funcall indent-function start) + (return)) + (funcall indent-function start) + (line-offset start 1 0))))) + +(defcommand "Center Line" (p) + "Centers current line using \"Fill Column\". If an argument is supplied, + it is used instead of the \"Fill Column\"." + "Centers current line using fill-column." + (let* ((indent-function (value indent-with-tabs)) + (region (if (region-active-p) + (current-region) + (region (current-point) (current-point)))) + (end (region-end region))) + (with-mark ((temp (region-start region) :left-inserting)) + (loop + (when (mark> temp end) (return)) + (delete-horizontal-space (line-end temp)) + (delete-horizontal-space (line-start temp)) + (let* ((len (line-length (mark-line temp))) + (spaces (- (or p (value fill-column)) len))) + (if (and (plusp spaces) + (not (zerop len))) + (funcall indent-function temp (ceiling spaces 2))) + (unless (line-offset temp 1) (return)) + (line-start temp)))))) + + +(defcommand "Quote Tab" (p) + "Insert tab character." + "Insert tab character." + (if (and p (> p 1)) + (insert-string (current-point) (make-string p :initial-element #\tab)) + (insert-character (current-point) #\tab))) + + +(defcommand "Open Line" (p) + "Inserts a newline into the buffer without moving the point." + "Inserts a newline into the buffer without moving the point. + With argument, inserts p newlines." + (let ((point (current-point)) + (count (if p p 1))) + (if (not (minusp count)) + (dotimes (i count) + (insert-character point #\newline) + (mark-before point)) + (editor-error)))) + + +(defcommand "New Line" (p) + "Moves the point to a new blank line. + A newline is inserted if the next two lines are not already blank. + With an argument, repeats p times." + "Moves the point to a new blank line." + (let ((point (current-point)) + (count (if p p 1))) + (if (not (minusp count)) + (do* ((next (line-next (mark-line point)) + (line-next (mark-line point))) + (i 1 (1+ i))) + ((> i count)) + (cond ((and (blank-after-p point) + next (blank-line-p next) + (let ((after (line-next next))) + (or (not after) (blank-line-p after)))) + (line-start point next) + (let ((len (line-length next))) + (unless (zerop len) + (delete-characters point len)))) + (t + (insert-character point #\newline)))) + (editor-error)))) + + +(defattribute "Space" + "This attribute is used by the indentation commands to determine which + characters are treated as space." + '(mod 2) 0) + +(setf (character-attribute :space #\space) 1) +(setf (character-attribute :space #\tab) 1) + +(defun delete-horizontal-space (mark) + "Deletes all :space characters on either side of mark." + (with-mark ((start mark)) + (reverse-find-attribute start :space #'zerop) + (find-attribute mark :space #'zerop) + (delete-region (region start mark)))) + + + +(defcommand "Delete Indentation" (p) + "Join current line with the previous one, deleting excess whitespace. + All whitespace is replaced with a single space, unless it is at the beginning + of a line, immmediately following a \"(\", or immediately preceding a \")\", + in which case the whitespace is merely deleted. If the preceeding character + is a sentence terminator, two spaces are left instead of one. If a prefix + argument is given, the following line is joined with the current line." + "Join current line with the previous one, deleting excess whitespace." + (with-mark ((m (current-point) :right-inserting)) + (when p (line-offset m 1)) + (line-start m) + (unless (delete-characters m -1) (editor-error "No previous line.")) + (delete-horizontal-space m) + (let ((prev (previous-character m))) + (when (and prev (char/= prev #\newline)) + (cond ((not (zerop (character-attribute :sentence-terminator prev))) + (insert-string m " ")) + ((not (or (eq (character-attribute :lisp-syntax prev) :open-paren) + (eq (character-attribute :lisp-syntax (next-character m)) + :close-paren))) + (insert-character m #\space))))))) + + +(defcommand "Delete Horizontal Space" (p) + "Delete spaces and tabs surrounding the point." + "Delete spaces and tabs surrounding the point." + (declare (ignore p)) + (delete-horizontal-space (current-point))) + +(defcommand "Just One Space" (p) + "Leave one space. + Surrounding space is deleted, and then one space is inserted. + with prefix argument insert that number of spaces." + "Delete surrounding space and insert P spaces." + (let ((point (current-point))) + (delete-horizontal-space point) + (dotimes (i (or p 1)) (insert-character point #\space)))) + +(defcommand "Back to Indentation" (p) + "Move point to the first non-whitespace character on the line." + "Move point to the first non-whitespace character on the line." + (declare (ignore p)) + (let ((point (current-point))) + (line-start point) + (find-attribute point :whitespace #'zerop))) + +(defcommand "Indent Rigidly" (p) + "Indent the region rigidly by p spaces. + Each line in the region is moved p spaces to the right (left if p is + negative). When moving a line to the left, tabs are converted to spaces." + "Indent the region rigidly p spaces to the right (left if p is negative)." + (let ((p (or p (value spaces-per-tab))) + (region (current-region))) + (with-mark ((mark1 (region-start region) :left-inserting) + (mark2 (region-end region) :left-inserting)) + (line-start mark1) + (line-start mark2) + (do () + ((mark= mark1 mark2)) + (cond ((empty-line-p mark1)) + ((blank-after-p mark1) + (delete-characters mark1 (line-length (mark-line mark1)))) + (t (find-attribute mark1 :whitespace #'zerop) + (let ((new-column (+ p (mark-column mark1)))) + (delete-characters mark1 (- (mark-charpos mark1))) + (if (plusp new-column) + (funcall (value indent-with-tabs) mark1 new-column))))) + (line-offset mark1 1 0))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/interp.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/interp.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/interp.lisp (revision 8058) @@ -0,0 +1,522 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan and Blaine Burks. +;;; +;;; This file contains the routines which define hemlock commands and +;;; the command interpreter. +;;; + +(in-package :hemlock-internals) + + + + +(defun %print-hcommand (obj stream depth) + (declare (ignore depth)) + (write-string "#" stream)) + + + + +;;;; Key Tables: +;;; +;;; A key table provides a way to translate a sequence of characters to some +;;; lisp object. It is currently represented by a tree of hash-tables, where +;;; each level is a hashing from a key to either another hash-table or a value. + + +;;; GET-TABLE-ENTRY returns the value at the end of a series of hashings. For +;;; our purposes it is presently used to look up commands and key-translations. +;;; +(defun get-table-entry (table key) + (let ((foo nil)) + (dotimes (i (length key) foo) + (let ((key-event (aref key i))) + (setf foo (gethash key-event table)) + (unless (hash-table-p foo) (return foo)) + (setf table foo))))) + +;;; SET-TABLE-ENTRY sets the entry for key in table to val, creating new +;;; tables as needed. If val is nil, then use REMHASH to remove this element +;;; from the hash-table. +;;; +(defun set-table-entry (table key val) + (dotimes (i (1- (length key))) + (let* ((key-event (aref key i)) + (foo (gethash key-event table))) + (if (hash-table-p foo) + (setf table foo) + (let ((new-table (make-hash-table))) + (setf (gethash key-event table) new-table) + (setf table new-table))))) + (if (null val) + (remhash (aref key (1- (length key))) table) + (setf (gethash (aref key (1- (length key))) table) val))) + + + +;;;; Key Translation: +;;; +;;; Key translations are maintained using a key table. If a value is an +;;; integer, then it is prefix bits to be OR'ed with the next character. If it +;;; is a key, then we translate to that key. + +(defvar *key-translations* (make-hash-table)) +(defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t)) + + +;;; TRANSLATE-KEY -- Internal +;;; +;;; This is used internally to do key translations when we want the +;;; canonical representation for Key. Result, if supplied, is an adjustable +;;; vector with a fill pointer. We compute the output in this vector. If the +;;; key ends in the prefix of a translation, we just return that part +;;; untranslated and return the second value true. +;;; +(defun translate-key (key &optional (result (make-array (length key) + :fill-pointer 0 + :adjustable t))) + (let ((key-len (length key)) + (temp *translate-key-temp*) + (start 0) + (try-pos 0) + (prefix 0)) + (setf (fill-pointer temp) 0) + (setf (fill-pointer result) 0) + (loop + (when (= try-pos key-len) (return)) + (let ((key-event (aref key try-pos))) + (vector-push-extend + (hemlock-ext:make-key-event key-event (logior (hemlock-ext:key-event-bits key-event) + prefix)) + temp) + (setf prefix 0)) + (let ((entry (get-table-entry *key-translations* temp))) + (cond ((hash-table-p entry) + (incf try-pos)) + (t + (etypecase entry + (null + (vector-push-extend (aref temp 0) result) + (incf start)) + (simple-vector + (dotimes (i (length entry)) + (vector-push-extend (aref entry i) result)) + (setf start (1+ try-pos))) + (integer + (setf start (1+ try-pos)) + (when (= start key-len) (return)) + (setf prefix (logior entry prefix)))) + (setq try-pos start) + (setf (fill-pointer temp) 0))))) + (dotimes (i (length temp)) + (vector-push-extend (aref temp i) result)) + (values result (not (zerop (length temp)))))) + + +;;; KEY-TRANSLATION -- Public. +;;; +(defun key-translation (key) + "Return the key translation for Key, or NIL if there is none. If Key is a + prefix of a translation, then :Prefix is returned. Whenever Key appears as a + subsequence of a key argument to the binding manipulation functions, that + portion will be replaced with the translation. A key translation may also be + a list (:Bits {Bit-Name}*). In this case, the named bits will be set in the + next character in the key being translated." + (let ((entry (get-table-entry *key-translations* (crunch-key key)))) + (etypecase entry + (hash-table :prefix) + ((or simple-vector null) entry) + (integer + (cons :bits (hemlock-ext:key-event-bits-modifiers entry)))))) + +;;; %SET-KEY-TRANSLATION -- Internal +;;; +(defun %set-key-translation (key new-value) + (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits)) + (apply #'hemlock-ext:make-key-event-bits (cdr new-value))) + (new-value (crunch-key new-value)) + (t new-value)))) + (set-table-entry *key-translations* (crunch-key key) entry) + new-value)) +;;; +(defsetf key-translation %set-key-translation + "Set the key translation for a key. If set to null, deletes any + translation.") + + + + +;;;; Interface Utility Functions: + +(defvar *global-command-table* (make-hash-table) + "The command table for global key bindings.") + +;;; GET-RIGHT-TABLE -- Internal +;;; +;;; Return a hash-table depending on "kind" and checking for errors. +;;; +(defun get-right-table (kind where) + (case kind + (:global + (when where + (error "Where argument ~S is meaningless for :global bindings." + where)) + *global-command-table*) + (:mode (let ((mode (getstring where *mode-names*))) + (unless mode + (error "~S is not a defined mode." where)) + (mode-object-bindings mode))) + (:buffer (unless (bufferp where) + (error "~S is not a buffer." where)) + (buffer-bindings where)) + (t (error "~S is not a valid binding type." kind)))) + + +;;; CRUNCH-KEY -- Internal. +;;; +;;; Take a key in one of the various specifications and turn it into the +;;; standard one: a simple-vector of characters. +;;; +(defun crunch-key (key) + (typecase key + (hemlock-ext:key-event (vector key)) + ((or list vector) ;List thrown in gratuitously. + (when (zerop (length key)) + (error "A zero length key is illegal.")) + (unless (every #'hemlock-ext:key-event-p key) + (error "A Key ~S must contain only key-events." key)) + (coerce key 'simple-vector)) + (t + (error "Key ~S is not a key-event or sequence of key-events." key)))) + + + + +;;;; Exported Primitives: + +(declaim (special *command-names*)) + +;;; BIND-KEY -- Public. +;;; +(defun bind-key (name key &optional (kind :global) where) + "Bind a Hemlock command to some key somewhere. Name is the string name + of a Hemlock command, Key is either a key-event or a vector of key-events. + Kind is one of :Global, :Mode or :Buffer, and where is the mode name or + buffer concerned. Kind defaults to :Global." + ;;(with-simple-restart (continue "Go on, ignoring binding attempt.")) + (handler-bind ((error + #'(lambda (condition) + (format *error-output* + "~&Error while trying to bind key ~A: ~A~%" + key condition) + (return-from bind-key nil)))) + (let ((cmd (getstring name *command-names*)) + (table (get-right-table kind where)) + (key (copy-seq (translate-key (crunch-key key))))) + (cond (cmd + (set-table-entry table key cmd) + (push (list key kind where) (command-%bindings cmd)) + cmd) + (t + (error "~S is not a defined command." name)))))) + + +;;; DELETE-KEY-BINDING -- Public +;;; +;;; Stick NIL in the key table specified. +;;; +(defun delete-key-binding (key &optional (kind :global) where) + "Remove a Hemlock key binding somewhere. Key is either a key-event or a + vector of key-events. Kind is one of :Global, :Mode or :Buffer, andl where + is the mode name or buffer concerned. Kind defaults to :Global." + (set-table-entry (get-right-table kind where) + (translate-key (crunch-key key)) + nil)) + + +;;; GET-CURRENT-BINDING -- Internal +;;; +;;; Look up a key in the current environment. +;;; +(defun get-current-binding (key) + (let ((res (get-table-entry (buffer-bindings *current-buffer*) key))) + (cond + (res (values res nil)) + (t + (do ((mode (buffer-mode-objects *current-buffer*) (cdr mode)) + (t-bindings ())) + ((null mode) + (values (get-table-entry *global-command-table* key) + (nreverse t-bindings))) + (declare (list t-bindings)) + (let ((res (get-table-entry (mode-object-bindings (car mode)) key))) + (when res + (if (mode-object-transparent-p (car mode)) + (push res t-bindings) + (return (values res (nreverse t-bindings))))))))))) + + +;;; GET-COMMAND -- Public. +;;; +(defun get-command (key &optional (kind :global) where) + "Return the command object for the command bound to key somewhere. + If key is not bound, return nil. Key is either a key-event or a vector of + key-events. If key is a prefix of a key-binding, then return :prefix. + Kind is one of :global, :mode or :buffer, and where is the mode name or + buffer concerned. Kind defaults to :Global." + (multiple-value-bind (key prefix-p) + (translate-key (crunch-key key)) + (let ((entry (if (eq kind :current) + (get-current-binding key) + (get-table-entry (get-right-table kind where) key)))) + (etypecase entry + (null (if prefix-p :prefix nil)) + (command entry) + (hash-table :prefix))))) + +(defvar *map-bindings-key* (make-array 5 :adjustable t :fill-pointer 0)) + +;;; MAP-BINDINGS -- Public. +;;; +(defun map-bindings (function kind &optional where) + "Map function over the bindings in some place. The function is passed the + key and the command to which it is bound." + (labels ((mapping-fun (hash-key hash-value) + (vector-push-extend hash-key *map-bindings-key*) + (etypecase hash-value + (command (funcall function *map-bindings-key* hash-value)) + (hash-table (maphash #'mapping-fun hash-value))) + (decf (fill-pointer *map-bindings-key*)))) + (setf (fill-pointer *map-bindings-key*) 0) + (maphash #'mapping-fun (get-right-table kind where)))) + +;;; MAKE-COMMAND -- Public. +;;; +;;; If the command is already defined, then alter the command object; +;;; otherwise, make a new command object and enter it into the *command-names*. +;;; +(defun make-command (name documentation function) + "Create a new Hemlock command with Name and Documentation which is + implemented by calling the function-value of the symbol Function" + (let ((entry (getstring name *command-names*))) + (cond + (entry + (setf (command-name entry) name) + (setf (command-documentation entry) documentation) + (setf (command-function entry) function)) + (t + (setf (getstring name *command-names*) + (internal-make-command name documentation function)))))) + + +;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public. +;;; +(defun command-name (command) + "Returns the string which is the name of Command." + (command-%name command)) +;;; +(defun %set-command-name (command new-name) + (check-type command command) + (check-type new-name string) + (setq new-name (coerce new-name 'simple-string)) + (delete-string (command-%name command) *command-names*) + (setf (getstring new-name *command-names*) command) + (setf (command-%name command) new-name)) + + +;;; COMMAND-BINDINGS -- Public. +;;; +;;; Check that all the supposed bindings really exists. Bindings which +;;; were once made may have been overwritten. It is easier to filter +;;; out bogus bindings here than to catch all the cases that can make a +;;; binding go away. +;;; +(defun command-bindings (command) + "Return a list of lists of the form (key kind where) describing + all the places where Command is bound." + (check-type command command) + (let (result) + (declare (list result)) + (dolist (place (command-%bindings command)) + (let ((table (case (cadr place) + (:global *global-command-table*) + (:mode + (let ((m (getstring (caddr place) *mode-names*))) + (when m (mode-object-bindings m)))) + (t + (when (member (caddr place) *buffer-list*) + (buffer-bindings (caddr place))))))) + (when (and table + (eq (get-table-entry table (car place)) command) + (not (member place result :test #'equalp))) + (push place result)))) + result)) + + +(defvar *last-command-type* () + "The command-type of the last command invoked.") +(defvar *command-type-set* () + "True if the last command set the command-type.") + +;;; LAST-COMMAND-TYPE -- Public +;;; +;;; +(defun last-command-type () + "Return the command-type of the last command invoked. + If no command-type has been set then return NIL. Setting this with + Setf sets the value for the next command." + *last-command-type*) + +;;; %SET-LAST-COMMAND-TYPE -- Internal +;;; +;;; Set the flag so we know not to clear the command-type. +;;; +(defun %set-last-command-type (type) + (setq *last-command-type* type *command-type-set* t)) + + +(defvar *prefix-argument* nil "The prefix argument or NIL.") +(defvar *prefix-argument-supplied* nil + "Should be set by functions which supply a prefix argument.") + +;;; PREFIX-ARGUMENT -- Public +;;; +;;; +(defun prefix-argument () + "Return the current value of prefix argument. This can be set with SETF." + *prefix-argument*) + +;;; %SET-PREFIX-ARGUMENT -- Internal +;;; +(defun %set-prefix-argument (argument) + "Set the prefix argument for the next command to Argument." + (unless (or (null argument) (integerp argument)) + (error "Prefix argument ~S is neither an integer nor Nil." argument)) + (setq *prefix-argument* argument *prefix-argument-supplied* t)) + + +;;;; The Command Loop: + +;;; Buffers we use to read and translate keys. +;;; +(defvar *current-command* (make-array 10 :fill-pointer 0 :adjustable t)) +(defvar *current-translation* (make-array 10 :fill-pointer 0 :adjustable t)) + +(defvar *invoke-hook* #'(lambda (command p) + (funcall (command-function command) p)) + "This function is called by the command interpreter when it wants to invoke a + command. The arguments are the command to invoke and the prefix argument. + The default value just calls the Command-Function with the prefix argument.") + + + +(defvar *self-insert-command* nil) + +(defun self-insert-command () + (or *self-insert-command* + (setq *self-insert-command* (getstring "Self Insert" *command-names*)))) + + +;;; %COMMAND-LOOP -- Internal +;;; +;;; Read commands from the terminal and execute them, forever. +;;; +(defun %command-loop () + (let ((cmd *current-command*) + (trans *current-translation*) + (*last-command-type* nil) + (*command-type-set* nil) + (*prefix-argument* nil) + (*prefix-argument-supplied* nil)) + (declare (special *last-command-type* *command-type-set* + *prefix-argument* *prefix-argument-supplied*)) + (setf (fill-pointer cmd) 0) + (handler-bind + ;; Bind this outside the invocation loop to save consing. + ((editor-error #'(lambda (condx) + (beep) + (let ((string (editor-error-format-string condx))) + (when string + (apply #'message string + (editor-error-format-arguments condx))) + (throw 'command-loop-catcher nil))))) + (loop + (let* ((temporary-object-pool (allocate-temporary-object-pool))) + (unwind-protect + (progn + (unless (eq *current-buffer* *echo-area-buffer*) + (unless (or (zerop (length cmd)) + (not (value hemlock::key-echo-delay))) + (editor-sleep (value hemlock::key-echo-delay)) + (unless (listen-editor-input *editor-input*) + (clear-echo-area) + (dotimes (i (length cmd)) + (hemlock-ext:print-pretty-key (aref cmd i) *echo-area-stream*) + (write-char #\space *echo-area-stream*))))) + (multiple-value-bind (key self-insert) + (get-key-event *editor-input*) + (unless (eq *current-buffer* *echo-area-buffer*) + (when (buffer-modified *echo-area-buffer*) + (clear-echo-area))) + (vector-push-extend key cmd) + (multiple-value-bind (trans-result prefix-p) + (unless self-insert (translate-key cmd trans)) + (multiple-value-bind (res t-bindings) + (if self-insert + (self-insert-command) + (get-current-binding trans-result)) + (etypecase res + (command + (let ((punt t)) + (catch 'command-loop-catcher + (let* ((buffer *current-buffer*) + (*command-key-event-buffer* buffer) + (doc (buffer-document buffer))) + (unwind-protect + (progn + (when doc + (hi::document-begin-editing doc)) + (dolist (c t-bindings) + (funcall *invoke-hook* c *prefix-argument*)) + (funcall *invoke-hook* res *prefix-argument*) + (setf punt nil)) + (when doc + (hi::document-end-editing doc))))) + (when punt (invoke-hook hemlock::command-abort-hook))) + (if *command-type-set* + (setq *command-type-set* nil) + (setq *last-command-type* nil)) + (if *prefix-argument-supplied* + (setq *prefix-argument-supplied* nil) + (setq *prefix-argument* nil)) + (setf (fill-pointer cmd) 0)) + (null + (unless prefix-p + (beep) + (setq *prefix-argument* nil) + (setf (fill-pointer cmd) 0))) + (hash-table))))) + (free-temporary-objects temporary-object-pool)))))))) + + + + + + + + +;;; EXIT-HEMLOCK -- Public +;;; + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/kbdmac.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/kbdmac.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/kbdmac.lisp (revision 8058) @@ -0,0 +1,475 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the implementation of keyboard macros for +;;; Hemlock. In itself it contains nothing particularly gross or +;;; implementation dependant, but it uses some hooks in the stream +;;; system and other stuff. +;;; + +(in-package :hemlock) + +;;; We have "Keyboard Macro Transforms" that help in making a keyboard +;;; macro. What they do is turn the sequence of commands into equivalent +;;; lisp code. They operate under the following principles: +;;; +;;; They are passed two arguments: +;;; 1] The command invoked. +;;; 2] A keyword, either :invoke, :start or :finish +;;; +;;; If the keyword is :invoke, then the transform is expected to +;;; invoke the command and do whatever is necessary to make the same +;;; thing happen again when the macro is invoked. The method does this +;;; by pushing forms on the list *current-kbdmac* and characters to +;;; simulate input of on *kbdmac-input*. *current-kbdmac* is kept +;;; in reverse order. Each form must be a function call, and none +;;; of the arguments are evaluated. If the transform is unwound, +;;; presumably due to an error in the invoked command, then nothing +;;; should be done at invocation time. +;;; +;;; If the keyword is :finish, then nothing need be done. This +;;; is to facilitate compaction of repetitions of the same command +;;; into one call. The transform is called with :finish when a run +;;; is broken. Similarly, the transform is called with :start +;;; before the first occurrence in a run. + +(defvar *kbdmac-transcript* (make-array 100 :fill-pointer 0 :adjustable t) + "The thing we bind *input-transcript* to during keyboard macro definition.") + +(defvar *kbdmac-input* (make-array 100 :fill-pointer 0 :adjustable t) + "Place where we stick input that will need to be simulated during keyboard + macro execution.") + +(defvar *current-kbdmac* () "Body of keyboard macro we are building.") + +(defvar *kbdmac-transforms* (make-hash-table :test #'eq) + "Hashtable of function that know how to do things.") + +(defvar *old-invoke-hook* () "Bound to *invoke-hook* by kbdmac-command-loop.") + +(defmacro define-kbdmac-transform (command function) + `(setf (gethash (getstring ,command *command-names*) + *kbdmac-transforms*) + ,function)) + +(defmacro kbdmac-emit (form) + `(push ,form *current-kbdmac*)) + + +(defun trash-character () + "Throw away a character on *editor-input*." + (get-key-event hi::*editor-input*)) + +;;; Save-Kbdmac-Input -- Internal +;;; +;;; Pushes any input read within the body on *kbdmac-input* so that +;;; it is read again at macro invocation time. It uses the (input-waiting) +;;; function which is a non-standard hook into the stream system. +;;; +(defmacro save-kbdmac-input (&body forms) + (let ((slen (gensym))) + `(let ((,slen (- (length *kbdmac-transcript*) (if (input-waiting) 1 0)))) + (multiple-value-prog1 + (progn ,@forms) + (do ((i ,slen (1+ i)) + (elen (length *kbdmac-transcript*))) + ((= i elen) + (when (input-waiting) + (kbdmac-emit '(trash-character)))) + (vector-push-extend (aref *kbdmac-transcript* i) + *kbdmac-input*)))))) + +;;;; The default transform +;;; +;;; This transform is called when none is defined for a command. +;;; +(defun default-kbdmac-transform (command key) + (case key + (:invoke + (let ((fun (command-function command)) + (arg (prefix-argument)) + (lastc *last-key-event-typed*)) + (save-kbdmac-input + (let ((*invoke-hook* *old-invoke-hook*)) + (funcall fun arg)) + (kbdmac-emit `(set *last-key-event-typed* ,lastc)) + (kbdmac-emit `(,fun ,arg))))))) + + +;;;; Self insert transform: +;;; +;;; For self insert we accumulate the text in a string and then +;;; insert it all at once. +;;; + +(defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t)) + +(defun insert-string-at-point (string) + (insert-string (buffer-point (current-buffer)) string)) +(defun insert-character-at-point (character) + (insert-character (buffer-point (current-buffer)) character)) + +(defun key-vector-to-string (key-vector) + (let ((string (make-array (length key-vector) :element-type 'base-char))) + (dotimes (i (length key-vector) string) + (setf (aref string i) (hemlock-ext:key-event-char (aref key-vector i)))))) + +(defun self-insert-kbdmac-transform (command key) + (case key + (:start + (setf (fill-pointer *kbdmac-text*) 0)) + (:invoke + (let ((p (or (prefix-argument) 1))) + (funcall (command-function command) p) + (dotimes (i p) + (vector-push-extend *last-key-event-typed* *kbdmac-text*)))) + (:finish + (if (> (length *kbdmac-text*) 1) + (kbdmac-emit `(insert-string-at-point + ,(key-vector-to-string *kbdmac-text*))) + (kbdmac-emit `(insert-character-at-point + ,(hemlock-ext:key-event-char (aref *kbdmac-text* 0)))))))) +;;; +(define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform) +(define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform) + +;;;; Do-Nothing transform: +;;; +;;; These are useful for prefix-argument setting commands, since they have +;;; no semantics at macro-time. +;;; +(defun do-nothing-kbdmac-transform (command key) + (case key + (:invoke + (funcall (command-function command) (prefix-argument))))) +;;; +(define-kbdmac-transform "Argument Digit" #'do-nothing-kbdmac-transform) +(define-kbdmac-transform "Negative Argument" #'do-nothing-kbdmac-transform) +(define-kbdmac-transform "Universal Argument" #'do-nothing-kbdmac-transform) + + +;;;; Multiplicative transform +;;; +;;; Repititions of many commands can be turned into a call with an +;;; argument. +;;; +(defvar *kbdmac-count* 0 + "The number of occurrences we have counted of a given command.") + +(defun multiplicative-kbdmac-transform (command key) + (case key + (:start + (setq *kbdmac-count* 0)) + (:invoke + (let ((p (or (prefix-argument) 1))) + (funcall (command-function command) p) + (incf *kbdmac-count* p))) + (:finish + (kbdmac-emit `(,(command-function command) ,*kbdmac-count*))))) +;;; +(define-kbdmac-transform "Forward Character" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Character" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Forward Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Uppercase Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Lowercase Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Capitalize Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Kill Next Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Kill Previous Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Forward Kill Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Kill Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Forward Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Delete Next Character" + #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Delete Previous Character" + #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Delete Previous Character Expanding Tabs" + #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Next Line" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Previous Line" #'multiplicative-kbdmac-transform) + + +;;;; Vanilla transform +;;; +;;; These commands neither read input nor look at random silly variables. +;;; +(defun vanilla-kbdmac-transform (command key) + (case key + (:invoke + (let ((fun (command-function command)) + (p (prefix-argument))) + (funcall fun p) + (kbdmac-emit `(,fun ,p)))))) +;;; +(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "End of Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Indent for Lisp" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Delete Horizontal Space" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Kill Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Backward Kill Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Un-Kill" #'vanilla-kbdmac-transform) + + +;;;; MAKE-KBDMAC, INTERACTIVE, and kbdmac command loop. + +;;; Kbdmac-Command-Loop -- Internal +;;; +;;; Bind *invoke-hook* to call kbdmac transforms. +;;; +(defun kbdmac-command-loop () + (let* ((last-transform nil) + (last-command nil) + (last-ctype nil) + (*old-invoke-hook* *invoke-hook*) + (*invoke-hook* + #'(lambda (res p) + (declare (ignore p)) + (when (and (not (eq last-command res)) last-transform) + (funcall last-transform last-command :finish)) + (if (last-command-type) + (setq last-ctype t) + (when last-ctype + (kbdmac-emit '(clear-command-type)) + (setq last-ctype nil))) + (setq last-transform + (gethash res *kbdmac-transforms* #'default-kbdmac-transform)) + (unless (eq last-command res) + (funcall last-transform res :start)) + (funcall last-transform res :invoke) + (setq last-command res)))) + (declare (special *invoke-hook*)) + (setf (last-command-type) nil) + (recursive-edit nil))) + +(defun clear-command-type () + (setf (last-command-type) nil)) + + +(defvar *defining-a-keyboard-macro* ()) +(defvar *kbdmac-stream* #+later (make-kbdmac-stream)) +(defvar *in-a-keyboard-macro* () + "True if we are currently executing a keyboard macro.") + +;;; Interactive -- Public +;;; +;;; See whether we are in a keyboard macro. +;;; +(defun interactive () + "Return true if we are in a command invoked by the user. + This is primarily useful for commands which want to know + whether do something when an error happens, or just signal + an Editor-Error." + (not *in-a-keyboard-macro*)) + +(defvar *kbdmac-done* () + "Setting this causes the keyboard macro being executed to terminate + after the current iteration.") + +(defvar *kbdmac-dont-ask* () + "Setting this inhibits \"Keyboard Macro Query\"'s querying.") + +;;; Make-Kbdmac -- Internal +;;; +;;; This guy grabs the stuff lying around in *current-kbdmac* and +;;; whatnot and makes a lexical closure that can be used as the +;;; definition of a command. The prefix argument is a repitition +;;; count. +;;; +(defun make-kbdmac () + (let ((code (nreverse *current-kbdmac*)) + (input (copy-seq *kbdmac-input*))) + (if (zerop (length input)) + #'(lambda (p) + (let ((*in-a-keyboard-macro* t) + (*kbdmac-done* nil) + (*kbdmac-dont-ask* nil)) + (setf (last-command-type) nil) + (catch 'exit-kbdmac + (dotimes (i (or p 1)) + (catch 'abort-kbdmac-iteration + (dolist (form code) + (apply (car form) (cdr form)))) + (when *kbdmac-done* (return nil)))))) + #'(lambda (p) + (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream))) + (*kbdmac-stream* nil) + (hi::*editor-input* stream) + (*in-a-keyboard-macro* t) + (*kbdmac-done* nil) + (*kbdmac-dont-ask* nil)) + (setf (last-command-type) nil) + (catch 'exit-kbdmac + (dotimes (i (or p 1)) + (setq stream (modify-kbdmac-stream stream input)) + (catch 'abort-kbdmac-iteration + (dolist (form code) + (apply (car form) (cdr form)))) + (when *kbdmac-done* (return nil))))))))) + + + + +;;;; Commands. + +(defmode "Def" :major-p nil) + +(defcommand "Define Keyboard Macro" (p) + "Define a keyboard macro." + "Define a keyboard macro." + (declare (ignore p)) + (when *defining-a-keyboard-macro* + (editor-error "Already defining a keyboard macro.")) + (define-keyboard-macro)) + +(defhvar "Define Keyboard Macro Key Confirm" + "When set, \"Define Keyboard Macro Key\" asks for confirmation before + clobbering an existing key binding." + :value t) + +(defcommand "Define Keyboard Macro Key" (p) + "Prompts for a key before going into a mode for defining keyboard macros. + The macro definition is bound to the key. IF the key is already bound, + this asks for confirmation before clobbering the binding." + "Prompts for a key before going into a mode for defining keyboard macros. + The macro definition is bound to the key. IF the key is already bound, + this asks for confirmation before clobbering the binding." + (declare (ignore p)) + (when *defining-a-keyboard-macro* + (editor-error "Already defining a keyboard macro.")) + (multiple-value-bind (key kind where) + (get-keyboard-macro-key) + (when key + (setf (buffer-minor-mode (current-buffer) "Def") t) + (let ((name (format nil "Keyboard Macro ~S" (gensym)))) + (make-command name "This is a user-defined keyboard macro." + (define-keyboard-macro)) + (bind-key name key kind where) + (message "~A bound to ~A." + (with-output-to-string (s) (hemlock-ext:print-pretty-key key s)) + name))))) + +;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it +;;; if it is already bound to a command, or it is a :prefix. This returns nil +;;; if the user "aborts", otherwise it returns the key and location (kind +;;; where) of the binding. +;;; +(defun get-keyboard-macro-key () + (let* ((key (prompt-for-key :prompt "Bind keyboard macro to key: " + :must-exist nil))) + (multiple-value-bind (kind where) + (prompt-for-place "Kind of binding: " + "The kind of binding to make.") + (let* ((cmd (get-command key kind where))) + (cond ((not cmd) (values key kind where)) + ((commandp cmd) + (if (prompt-for-y-or-n + :prompt `("~A is bound to ~A. Rebind it? " + ,(with-output-to-string (s) + (hemlock-ext:print-pretty-key key s)) + ,(command-name cmd)) + :default nil) + (values key kind where) + nil)) + ((eq cmd :prefix) + (if (prompt-for-y-or-n + :prompt `("~A is a prefix for more than one command. ~ + Clobber it? " + ,(with-output-to-string (s) + (hemlock-ext:print-pretty-key key s))) + :default nil) + (values key kind where) + nil))))))) + +;;; DEFINE-KEYBOARD-MACRO gets input from the user and clobbers the function +;;; for the "Last Keyboard Macro" command. This returns the new function. +;;; +(defun define-keyboard-macro () + (setf (buffer-minor-mode (current-buffer) "Def") t) + (unwind-protect + (let* ((in *kbdmac-transcript*) + (*input-transcript* in) + (*defining-a-keyboard-macro* t)) + (setf (fill-pointer in) 0) + (setf (fill-pointer *kbdmac-input*) 0) + (setq *current-kbdmac* ()) + (catch 'punt-kbdmac + (kbdmac-command-loop)) + (setf (command-function (getstring "Last Keyboard Macro" *command-names*)) + (make-kbdmac))) + (setf (buffer-minor-mode (current-buffer) "Def") nil))) + + +(defcommand "End Keyboard Macro" (p) + "End the definition of a keyboard macro." + "End the definition of a keyboard macro." + (declare (ignore p)) + (unless *defining-a-keyboard-macro* + (editor-error "Not defining a keyboard macro.")) + (throw 'punt-kbdmac ())) +;;; +(define-kbdmac-transform "End Keyboard Macro" #'do-nothing-kbdmac-transform) + + +(defcommand "Last Keyboard Macro" (p) + "Execute the last keyboard macro defined. + With prefix argument execute it that many times." + "Execute the last keyboard macro P times." + (declare (ignore p)) + (editor-error "No keyboard macro defined.")) + +(defcommand "Name Keyboard Macro" (p &optional name) + "Name the \"Last Keyboard Macro\". + The last defined keboard macro is made into a named command." + "Make the \"Last Keyboard Macro\" a named command." + (declare (ignore p)) + (unless name + (setq name (prompt-for-string + :prompt "Macro name: " + :help "String name of command to make from keyboard macro."))) + (make-command + name "This is a named keyboard macro." + (command-function (getstring "Last Keyboard Macro" *command-names*)))) + +(defcommand "Keyboard Macro Query" (p) + "Keyboard macro conditional. + During the execution of a keyboard macro, this command prompts for + a single character command, similar to those of \"Query Replace\"." + "Prompt for action during keyboard macro execution." + (declare (ignore p)) + (unless (or (interactive) *kbdmac-dont-ask*) + (let ((hi::*editor-input* *real-editor-input*)) + (command-case (:prompt "Keyboard Macro Query: " + :help "Type one of these characters to say what to do:" + :change-window nil + :bind key-event) + (:exit + "Exit this keyboard macro immediately." + (throw 'exit-kbdmac nil)) + (:yes + "Proceed with this iteration of the keyboard macro.") + (:no + "Don't do this iteration of the keyboard macro, but continue to the next." + (throw 'abort-kbdmac-iteration nil)) + (:do-all + "Do all remaining repetitions of the keyboard macro without prompting." + (setq *kbdmac-dont-ask* t)) + (:do-once + "Do this iteration of the keyboard macro and then exit." + (setq *kbdmac-done* t)) + (:recursive-edit + "Do a recursive edit, then ask again." + (do-recursive-edit) + (reprompt)) + (t + (unget-key-event key-event hi::*editor-input*) + (throw 'exit-kbdmac nil)))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/key-event.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/key-event.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/key-event.lisp (revision 8058) @@ -0,0 +1,700 @@ +;;; -*- Log: hemlock.log; Package: HEMLOCK-EXT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file implements key-events for representing editor input. It also +;;; provides a couple routines to interface this to X11. +;;; +;;; Written by Blaine Burks and Bill Chiles. +;;; + +;;; The following are the implementation dependent parts of this code (what +;;; you would have to change if you weren't using X11): +;;; *modifier-translations* +;;; DEFINE-CLX-MODIFIER +;;; TRANSLATE-KEY-EVENT +;;; TRANSLATE-MOUSE-KEY-EVENT +;;; DEFINE-KEYSYM +;;; DEFINE-MOUSE-KEYSYM +;;; DO-ALPHA-KEY-EVENTS +;;; If the window system didn't use a keysym mechanism to represent keys, you +;;; would also need to write something that mapped whatever did encode the +;;; keys to the keysyms defined with DEFINE-KEYSYM. +;;; + +(in-package :hemlock-ext) + + + +;;;; Keysym <==> Name translation. + +;;; Keysyms are named by case-insensitive names. However, if the name +;;; consists of a single character, the name is case-sensitive. +;;; + +;;; This table maps a keysym to a list of names. The first name is the +;;; preferred printing name. +;;; +(defvar *keysyms-to-names*) + +;;; This table maps all keysym names to the appropriate keysym. +;;; +(defvar *names-to-keysyms*) + +(declaim (inline name-keysym keysym-names keysym-preferred-name)) + +(defun name-keysym (name) + "This returns the keysym named name. If name is unknown, this returns nil." + (gethash (get-name-case-right name) *names-to-keysyms*)) + +(defun keysym-names (keysym) + "This returns the list of all names for keysym. If keysym is undefined, + this returns nil." + (or (gethash keysym *keysyms-to-names*) + (let* ((name (char-name (code-char keysym)))) + (when name (setf (gethash keysym *keysyms-to-names*) + (list name)))))) + +(defun keysym-preferred-name (keysym) + "This returns the preferred name for keysym, how it is typically printed. + If keysym is undefined, this returns nil." + (car (keysym-names keysym))) + + + + +;;;; Character key-event stuff. + +;;; GET-NAME-CASE-RIGHT -- Internal. +;;; +;;; This returns the canonical string for a keysym name for use with +;;; hash tables. +;;; +(defun get-name-case-right (string) + (if (= (length string) 1) string (string-downcase string))) + +;;; DEFINE-KEYSYM -- Public. +;;; +(defun define-keysym (keysym preferred-name &rest other-names) + "This establishes a mapping from preferred-name to keysym for purposes of + specifying key-events in #k syntax. Other-names also map to keysym, but the + system uses preferred-name when printing key-events. The names are + case-insensitive simple-strings. Redefining a keysym or re-using names has + undefined effects." + (setf (gethash keysym *keysyms-to-names*) (cons preferred-name other-names)) + (dolist (name (cons preferred-name other-names)) + (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym))) + +;;; This is an a-list mapping CLX modifier masks to defined key-event +;;; modifier names. DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT +;;; and TRANSLATE-MOUSE-KEY-EVENT can work. +;;; +(defvar *modifier-translations*) + +;;; This is an ordered a-list mapping defined key-event modifier names to the +;;; appropriate mask for the modifier. Modifier names have a short and a long +;;; version. For each pair of names for the same mask, the names are +;;; contiguous in this list, and the short name appears first. +;;; PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on this. +;;; +(defvar *modifiers-to-internal-masks*) + + + + + +(defvar *mouse-translation-info*) + +;;; MOUSE-TRANSLATION-INFO -- Internal. +;;; +;;; This returns the requested information, :keysym or :shifted-modifier-name, +;;; for the button cross event-key. If the information is undefined, this +;;; signals an error. +;;; +(defun mouse-translation-info (button event-key info) + (let ((event-dispatch (svref *mouse-translation-info* button))) + (unless event-dispatch + (error "No defined mouse translation information for button ~S." button)) + (let ((data (ecase event-key + (:button-press (button-press-info event-dispatch)) + (:button-release (button-release-info event-dispatch))))) + (unless data + (error + "No defined mouse translation information for button ~S and event ~S." + button event-key)) + (ecase info + (:keysym (button-keysym data)) + (:shifted-modifier-name (button-shifted-modifier-name data)))))) + + +(eval-when (:compile-toplevel :execute) + (defmacro button-press-info (event-dispatch) `(car ,event-dispatch)) + (defmacro button-release-info (event-dispatch) `(cdr ,event-dispatch)) + (defmacro button-keysym (info) `(car ,info)) + (defmacro button-shifted-modifier-name (info) `(cdr ,info)) +) + +;;; MOUSE-TRANSLATION-INFO -- Internal. +;;; +;;; This returns the requested information, :keysym or :shifted-modifier-name, +;;; for the button cross event-key. If the information is undefined, this +;;; signals an error. +;;; +(defun mouse-translation-info (button event-key info) + (let ((event-dispatch (svref *mouse-translation-info* button))) + (unless event-dispatch + (error "No defined mouse translation information for button ~S." button)) + (let ((data (ecase event-key + (:button-press (button-press-info event-dispatch)) + (:button-release (button-release-info event-dispatch))))) + (unless data + (error + "No defined mouse translation information for button ~S and event ~S." + button event-key)) + (ecase info + (:keysym (button-keysym data)) + (:shifted-modifier-name (button-shifted-modifier-name data)))))) + +;;; (setf MOUSE-TRANSLATION-INFO) -- Internal. +;;; +;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO +;;; does, filling in the data structure on an as-needed basis, and stores +;;; the value for the indicated info. +;;; +(defun (setf mouse-translation-info) (value button event-key info) + (let ((event-dispatch (svref *mouse-translation-info* button))) + (unless event-dispatch + (setf event-dispatch + (setf (svref *mouse-translation-info* button) (cons nil nil)))) + (let ((data (ecase event-key + (:button-press (button-press-info event-dispatch)) + (:button-release (button-release-info event-dispatch))))) + (unless data + (setf data + (ecase event-key + (:button-press + (setf (button-press-info event-dispatch) (cons nil nil))) + (:button-release + (setf (button-release-info event-dispatch) (cons nil nil)))))) + (ecase info + (:keysym + (setf (button-keysym data) value)) + (:shifted-modifier-name + (setf (button-shifted-modifier-name data) value)))))) + + + +;;; DEFINE-MOUSE-KEYSYM -- Public. +;;; +(defun define-mouse-keysym (button keysym name shifted-bit event-key) + "This defines keysym named name for the X button cross the X event-key. + Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets + in the key-event it returns whenever the X shift bit is on." + (unless (<= 1 button 5) + (error "Buttons are number 1-5, not ~D." button)) + (setf (gethash keysym *keysyms-to-names*) (list name)) + (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym) + (setf (mouse-translation-info button event-key :keysym) keysym) + (setf (mouse-translation-info button event-key :shifted-modifier-name) + shifted-bit)) + + + + +;;;; Stuff for parsing #k syntax. + + + +(defstruct (key-event (:print-function %print-key-event) + (:constructor %make-key-event (keysym bits))) + (bits nil :type fixnum) + (keysym nil :type fixnum)) + +(defun %print-key-event (object stream ignore) + (declare (ignore ignore)) + (write-string "# stream)) + +;;; This maps Common Lisp CHAR-CODE's to character classes for parsing #k +;;; syntax. +;;; +(defvar *key-character-classes* (make-array char-code-limit + :initial-element :other)) + +;;; These characters are special: +;;; #\< .......... :ISO-start - Signals start of an ISO character. +;;; #\> .......... :ISO-end - Signals end of an ISO character. +;;; #\- .......... :modifier-terminator - Indicates last *id-namestring* +;;; was a modifier. +;;; #\" .......... :EOF - Means we have come to the end of the character. +;;; #\{a-z, A-Z} .. :letter - Means the char is a letter. +;;; #\space ....... :event-terminator- Indicates the last *id-namestring* +;;; was a character name. +;;; +;;; Every other character has class :other. +;;; +(hi::do-alpha-chars (char :both) + (setf (svref *key-character-classes* (char-code char)) :letter)) +(setf (svref *key-character-classes* (char-code #\<)) :ISO-start) +(setf (svref *key-character-classes* (char-code #\>)) :ISO-end) +(setf (svref *key-character-classes* (char-code #\-)) :modifier-terminator) +(setf (svref *key-character-classes* (char-code #\space)) :event-terminator) +(setf (svref *key-character-classes* (char-code #\")) :EOF) + +;;; This holds the characters built up while lexing a potential keysym or +;;; modifier identifier. +;;; +(defvar *id-namestring* + (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-char)) + +;;; PARSE-KEY-FUN -- Internal. +;;; +;;; This is the #k dispatch macro character reader. It is a FSM that parses +;;; key specifications. It returns either a VECTOR form or a MAKE-KEY-EVENT +;;; form. Since key-events are unique at runtime, we cannot create them at +;;; readtime, returning the constant object from READ. Wherever a #k appears, +;;; there's a for that at loadtime or runtime will return the unique key-event +;;; or vector of unique key-events. +;;; +(defun parse-key-fun (stream sub-char count) + (declare (ignore sub-char count)) + (setf (fill-pointer *id-namestring*) 0) + (prog ((bits 0) + (key-event-list ()) + char class) + (unless (char= (read-char stream) #\") + (error "Keys must be delimited by ~S." #\")) + ;; Skip any leading spaces in the string. + (skip-whitespace stream) + (multiple-value-setq (char class) (get-key-char stream)) + (ecase class + ((:letter :other :escaped) (go ID)) + (:ISO-start (go ISOCHAR)) + (:ISO-end (error "Angle brackets must be escaped.")) + (:modifier-terminator (error "Dash must be escaped.")) + (:EOF (error "No key to read."))) + ID + (vector-push-extend char *id-namestring*) + (multiple-value-setq (char class) (get-key-char stream)) + (ecase class + ((:letter :other :escaped) (go ID)) + (:event-terminator (go GOT-CHAR)) + (:modifier-terminator (go GOT-MODIFIER)) + ((:ISO-start :ISO-end) (error "Angle brackets must be escaped.")) + (:EOF (go GET-LAST-CHAR))) + GOT-CHAR + (push `(make-key-event ,(copy-seq *id-namestring*) ,bits) + key-event-list) + (setf (fill-pointer *id-namestring*) 0) + (setf bits 0) + ;; Skip any whitespace between characters. + (skip-whitespace stream) + (multiple-value-setq (char class) (get-key-char stream)) + (ecase class + ((:letter :other :escaped) (go ID)) + (:ISO-start (go ISOCHAR)) + (:ISO-end (error "Angle brackets must be escaped.")) + (:modifier-terminator (error "Dash must be escaped.")) + (:EOF (go FINAL))) + GOT-MODIFIER + (let ((modifier-name (car (assoc *id-namestring* + *modifiers-to-internal-masks* + :test #'string-equal)))) + (unless modifier-name + (error "~S is not a defined modifier." *id-namestring*)) + (setf (fill-pointer *id-namestring*) 0) + (setf bits (logior bits (key-event-modifier-mask modifier-name)))) + (multiple-value-setq (char class) (get-key-char stream)) + (ecase class + ((:letter :other :escaped) (go ID)) + (:ISO-start (go ISOCHAR)) + (:ISO-end (error "Angle brackets must be escaped.")) + (:modifier-terminator (error "Dash must be escaped.")) + (:EOF (error "Expected something naming a key-event, got EOF."))) + ISOCHAR + (multiple-value-setq (char class) (get-key-char stream)) + (ecase class + ((:letter :event-terminator :other :escaped) + (vector-push-extend char *id-namestring*) + (go ISOCHAR)) + (:ISO-start (error "Open Angle must be escaped.")) + (:modifier-terminator (error "Dash must be escaped.")) + (:EOF (error "Bad syntax in key specification, hit eof.")) + (:ISO-end (go GOT-CHAR))) + GET-LAST-CHAR + (push `(make-key-event ,(copy-seq *id-namestring*) ,bits) + key-event-list) + FINAL + (return (if (cdr key-event-list) + `(vector ,@(nreverse key-event-list)) + `,(car key-event-list))))) + +(set-dispatch-macro-character #\# #\k #'parse-key-fun) + +(defconstant key-event-escape-char #\\ + "The escape character that #k uses.") + +;;; GET-KEY-CHAR -- Internal. +;;; +;;; This is used by PARSE-KEY-FUN. +;;; +(defun get-key-char (stream) + (let ((char (read-char stream t nil t))) + (cond ((char= char key-event-escape-char) + (let ((char (read-char stream t nil t))) + (values char :escaped))) + (t (values char (svref *key-character-classes* (char-code char))))))) + + + + +;;;; Code to deal with modifiers. + +(defvar *modifier-count* 0 + "The number of modifiers that is currently defined.") + +(eval-when (:compile-toplevel :execute :load-toplevel) + +(defconstant modifier-count-limit 6 + "The maximum number of modifiers supported.") + +); eval-when + +;;; This is purely a list for users. +;;; +(defvar *all-modifier-names* () + "A list of all the names of defined modifiers.") + +;;; DEFINE-KEY-EVENT-MODIFIER -- Public. +;;; +;;; Note that short-name is pushed into *modifiers-to-internal-masks* after +;;; long-name. PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on +;;; this feature. +;;; +(defun define-key-event-modifier (long-name short-name) + "This establishes long-name and short-name as modifier names for purposes + of specifying key-events in #k syntax. The names are case-insensitive and + must be strings. If either name is already defined, this signals an error." + (when (= *modifier-count* modifier-count-limit) + (error "Maximum of ~D modifiers allowed." modifier-count-limit)) + (let ((long-name (string-capitalize long-name)) + (short-name (string-capitalize short-name))) + (flet ((frob (name) + (when (assoc name *modifiers-to-internal-masks* + :test #'string-equal) + (restart-case + (error "Modifier name has already been defined -- ~S" name) + (blow-it-off () + :report "Go on without defining this modifier." + (return-from define-key-event-modifier nil)))))) + (frob long-name) + (frob short-name)) + (unwind-protect + (let ((new-bits (ash 1 *modifier-count*))) + (push (cons long-name new-bits) *modifiers-to-internal-masks*) + (push (cons short-name new-bits) *modifiers-to-internal-masks*) + (pushnew long-name *all-modifier-names* :test #'string-equal) + ;; Sometimes the long-name is the same as the short-name. + (pushnew short-name *all-modifier-names* :test #'string-equal)) + (incf *modifier-count*)))) + +;;; +;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system +;;; default key-event modifiers. +;;; + +;;; DEFINE-CLX-MODIFIER -- Public. +;;; +(defun define-clx-modifier (clx-mask modifier-name) + "This establishes a mapping from clx-mask to a define key-event modifier-name. + TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events + with bits defined by this routine." + (let ((map (assoc modifier-name *modifiers-to-internal-masks* + :test #'string-equal))) + (unless map (error "~S an undefined modifier name." modifier-name)) + (push (cons clx-mask (car map)) *modifier-translations*))) + +;;; +;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system +;;; default clx modifiers, mapping them to some system default key-event +;;; modifiers. +;;; + +;;; MAKE-KEY-EVENT-BITS -- Public. +;;; +(defun make-key-event-bits (&rest modifier-names) + "This returns bits suitable for MAKE-KEY-EVENT from the supplied modifier + names. If any name is undefined, this signals an error." + (let ((mask 0)) + (dolist (mod modifier-names mask) + (let ((this-mask (cdr (assoc mod *modifiers-to-internal-masks* + :test #'string-equal)))) + (unless this-mask (error "~S is an undefined modifier name." mod)) + (setf mask (logior mask this-mask)))))) + +;;; KEY-EVENT-BITS-MODIFIERS -- Public. +;;; +(defun key-event-bits-modifiers (bits) + "This returns a list of key-event modifier names, one for each modifier + set in bits." + (let ((res nil)) + (do ((map (cdr *modifiers-to-internal-masks*) (cddr map))) + ((null map) res) + (when (logtest bits (cdar map)) + (push (caar map) res))))) + +;;; KEY-EVENT-MODIFIER-MASK -- Public. +;;; +(defun key-event-modifier-mask (modifier-name) + "This function returns a mask for modifier-name. This mask is suitable + for use with KEY-EVENT-BITS. If modifier-name is undefined, this signals + an error." + (let ((res (cdr (assoc modifier-name *modifiers-to-internal-masks* + :test #'string-equal)))) + (unless res (error "Undefined key-event modifier -- ~S." modifier-name)) + res)) + + + + +;;;; Key event lookup -- GET-KEY-EVENT and MAKE-KEY-EVENT. + +(defvar *keysym-high-bytes*) + +(defconstant modifier-bits-limit (ash 1 modifier-count-limit)) + +;;; GET-KEY-EVENT -- Internal. +;;; +;;; This finds the key-event specified by keysym and bits. If the key-event +;;; does not already exist, this creates it. This assumes keysym is defined, +;;; and if it isn't, this will make a key-event anyway that will cause an +;;; error when the system tries to print it. +;;; +(defun get-key-event* (keysym bits) + (let* ((char (code-char keysym))) + (when (and char (standard-char-p char)) + (let* ((mask (key-event-modifier-mask "Shift"))) + (when (logtest bits mask) + (setq bits (logandc2 bits mask) + keysym (char-code (char-upcase char))))))) + (let* ((high-byte (ash keysym -8)) + (low-byte-vector (svref *keysym-high-bytes* high-byte))) + (unless low-byte-vector + (let ((new-vector (make-array 256 :initial-element nil))) + (setf (svref *keysym-high-bytes* high-byte) new-vector) + (setf low-byte-vector new-vector))) + (let* ((low-byte (ldb (byte 8 0) keysym)) + (bit-vector (svref low-byte-vector low-byte))) + (unless bit-vector + (let ((new-vector (make-array modifier-bits-limit + :initial-element nil))) + (setf (svref low-byte-vector low-byte) new-vector) + (setf bit-vector new-vector))) + (let ((key-event (svref bit-vector bits))) + (if key-event + key-event + (setf (svref bit-vector bits) (%make-key-event keysym bits))))))) + +;;; MAKE-KEY-EVENT -- Public. +;;; +(defun make-key-event (object &optional (bits 0)) + "This returns a key-event described by object with bits. Object is one of + keysym, string, or key-event. When object is a key-event, this uses + KEY-EVENT-KEYSYM. You can form bits with MAKE-KEY-EVENT-BITS or + KEY-EVENT-MODIFIER-MASK." + (etypecase object + (integer + (unless (keysym-names object) + (error "~S is an undefined keysym." object)) + (get-key-event* object bits)) + #|(character + (let* ((name (char-name object)) + (keysym (name-keysym (or name (string object))))) + (unless keysym + (error "~S is an undefined keysym." object)) + (get-key-event* keysym bits)))|# + (string + (let ((keysym (name-keysym object))) + (unless keysym + (error "~S is an undefined keysym." object)) + (get-key-event* keysym bits))) + (key-event + (get-key-event* (key-event-keysym object) bits)))) + +;;; KEY-EVENT-BIT-P -- Public. +;;; +(defun key-event-bit-p (key-event bit-name) + "This returns whether key-event has the bit set named by bit-name. This + signals an error if bit-name is undefined." + (let ((mask (cdr (assoc bit-name *modifiers-to-internal-masks* + :test #'string-equal)))) + (unless mask + (error "~S is not a defined modifier." bit-name)) + (not (zerop (logand (key-event-bits key-event) mask))))) + + + + +;;;; KEY-EVENT-CHAR and CHAR-KEY-EVENT. + +;;; This maps key-events to characters. Users modify this by SETF'ing +;;; KEY-EVENT-CHAR. +;;; +(defvar *key-event-characters*) + +(defun key-event-char (key-event) + "Returns the character associated with key-event. This is SETF'able." + (check-type key-event key-event) + (or (gethash key-event *key-event-characters*) + (code-char (key-event-keysym key-event)))) + +(defun %set-key-event-char (key-event character) + (check-type character character) + (check-type key-event key-event) + (setf (gethash key-event *key-event-characters*) character)) +;;; +(defsetf key-event-char %set-key-event-char) + + +;;; This maps characters to key-events. Users modify this by SETF'ing +;;; CHAR-KEY-EVENT. +;;; +(defvar *character-key-events*) + +(defun char-key-event (char) + "Returns the key-event associated with char. This is SETF'able." + (check-type char character) + (svref *character-key-events* (char-code char))) + +(defun %set-char-key-event (char key-event) + (check-type char character) + (check-type key-event key-event) + (setf (svref *character-key-events* (char-code char)) key-event)) +;;; +(defsetf char-key-event %set-char-key-event) + + + + +;;;; DO-ALPHA-KEY-EVENTS. + +(defmacro alpha-key-events-loop (var start-keysym end-keysym result body) + (let ((n (gensym))) + `(do ((,n ,start-keysym (1+ ,n))) + ((> ,n ,end-keysym) ,result) + (let ((,var (make-key-event ,n 0))) + (when (alpha-char-p (key-event-char ,var)) + ,@body))))) + +(defmacro do-alpha-key-events ((var kind &optional result) &rest forms) + "(DO-ALPHA-KEY-EVENTS (var kind [result]) {form}*) + This macro evaluates each form with var bound to a key-event representing an + alphabetic character. Kind is one of :lower, :upper, or :both, and this + binds var to each key-event in order as specified in the X11 protocol + specification. When :both is specified, this processes lowercase letters + first." + (case kind + (:both + `(progn (alpha-key-events-loop ,var 97 122 nil ,forms) + (alpha-key-events-loop ,var 65 90 ,result ,forms))) + (:lower + `(alpha-key-events-loop ,var 97 122 ,result ,forms)) + (:upper + `(alpha-key-events-loop ,var 65 90 ,result ,forms)) + (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." + kind)))) + + + + +;;;; PRINT-PRETTY-KEY and PRINT-PRETTY-KEY-EVENT. + +;;; PRINT-PRETTY-KEY -- Public. +;;; +(defun print-pretty-key (key &optional (stream *standard-output*) long-names-p) + "This prints key, a key-event or vector of key-events, to stream in a + user-expected fashion. Long-names-p indicates whether modifiers should + print with their long or short name." + (declare (type (or vector key-event) key) (type stream stream)) + (etypecase key + (key-event (print-pretty-key-event key stream long-names-p)) + (vector + (let ((length-1 (1- (length key)))) + (dotimes (i (length key)) + (let ((key-event (aref key i))) + (print-pretty-key-event key-event stream long-names-p) + (unless (= i length-1) (write-char #\space stream)))))))) + +;;; PRINT-PRETTY-KEY-EVENT -- Public. +;;; +;;; Note, this makes use of the ordering in the a-list +;;; *modifiers-to-internal-masks* by CDDR'ing down it by starting on a short +;;; name or a long name. +;;; +(defun print-pretty-key-event (key-event &optional (stream *standard-output*) + long-names-p) + "This prints key-event to stream. Long-names-p indicates whether modifier + names should appear using the long name or short name." + (do ((map (if long-names-p + (cdr *modifiers-to-internal-masks*) + *modifiers-to-internal-masks*) + (cddr map))) + ((null map)) + (when (not (zerop (logand (cdar map) (key-event-bits key-event)))) + (write-string (caar map) stream) + (write-char #\- stream))) + (let* ((name (keysym-preferred-name (key-event-keysym key-event))) + (spacep (position #\space (the simple-string name)))) + (when spacep (write-char #\< stream)) + (write-string name stream) + (when spacep (write-char #\> stream)))) + + + + +;;;; Re-initialization. + +;;; RE-INITIALIZE-KEY-EVENTS -- Internal. +;;; +(defun re-initialize-key-events () + "This blows away all data associated with keysyms, modifiers, mouse + translations, and key-event/characters mapping. Then it re-establishes + the system defined key-event modifiers and the system defined CLX + modifier mappings to some of those key-event modifiers. + + When recompiling this file, you should load it and call this function + before using any part of the key-event interface, especially before + defining all your keysyms and using #k syntax." + (setf *keysyms-to-names* (make-hash-table :test #'eql)) + (setf *names-to-keysyms* (make-hash-table :test #'equal)) + (setf *modifier-translations* ()) + (setf *modifiers-to-internal-masks* ()) + (setf *mouse-translation-info* (make-array 6 :initial-element nil)) + (setf *modifier-count* 0) + (setf *all-modifier-names* ()) + (setf *keysym-high-bytes* (make-array 256 :initial-element nil)) + (setf *key-event-characters* (make-hash-table)) + (setf *character-key-events* + (make-array char-code-limit :initial-element nil)) + + (define-key-event-modifier "Hyper" "H") + (define-key-event-modifier "Super" "S") + (define-key-event-modifier "Meta" "M") + (define-key-event-modifier "Control" "C") + (define-key-event-modifier "Shift" "Shift") + (define-key-event-modifier "Lock" "Lock") + +) + +;;; Initialize stuff if not already initialized. +;;; +(unless (boundp '*keysyms-to-names*) + (re-initialize-key-events)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/keysym-defs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/keysym-defs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/keysym-defs.lisp (revision 8058) @@ -0,0 +1,216 @@ +;;; -*- Log: hemlock.log; Mode: Lisp; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file defines all the definitions of keysyms (see key-event.lisp). +;;; These keysyms match those for X11. +;;; +;;; Written by Bill Chiles +;;; Modified by Blaine Burks. +;;; + +(in-package :hemlock-internals) + + + + +;;; Function keys for the RT. +;;; + +;;; This isn't the RT. +(eval-when (:compile-toplevel :execute) + (ccl::use-interface-dir :cocoa)) + +(hemlock-ext:define-keysym #$NSF1FunctionKey "F1") +(hemlock-ext:define-keysym #$NSF2FunctionKey "F2") +(hemlock-ext:define-keysym #$NSF3FunctionKey "F3") +(hemlock-ext:define-keysym #$NSF4FunctionKey "F4") +(hemlock-ext:define-keysym #$NSF5FunctionKey "F5") +(hemlock-ext:define-keysym #$NSF6FunctionKey "F6") +(hemlock-ext:define-keysym #$NSF7FunctionKey "F7") +(hemlock-ext:define-keysym #$NSF8FunctionKey "F8") +(hemlock-ext:define-keysym #$NSF9FunctionKey "F9") +(hemlock-ext:define-keysym #$NSF10FunctionKey "F10") +(hemlock-ext:define-keysym #$NSF11FunctionKey "F11") +(hemlock-ext:define-keysym #$NSF12FunctionKey "F12") +(hemlock-ext:define-keysym #$NSF13FunctionKey "F13") +(hemlock-ext:define-keysym #$NSF14FunctionKey "F14") +(hemlock-ext:define-keysym #$NSF15FunctionKey "F15") +(hemlock-ext:define-keysym #$NSF16FunctionKey "F16") +(hemlock-ext:define-keysym #$NSF17FunctionKey "F17") +(hemlock-ext:define-keysym #$NSF18FunctionKey "F18") +(hemlock-ext:define-keysym #$NSF19FunctionKey "F19") +(hemlock-ext:define-keysym #$NSF20FunctionKey "F20") +(hemlock-ext:define-keysym #$NSF21FunctionKey "F21") +(hemlock-ext:define-keysym #$NSF22FunctionKey "F22") +(hemlock-ext:define-keysym #$NSF23FunctionKey "F23") +(hemlock-ext:define-keysym #$NSF24FunctionKey "F24") +(hemlock-ext:define-keysym #$NSF25FunctionKey "F25") +(hemlock-ext:define-keysym #$NSF26FunctionKey "F26") +(hemlock-ext:define-keysym #$NSF27FunctionKey "F27") +(hemlock-ext:define-keysym #$NSF28FunctionKey "F28") +(hemlock-ext:define-keysym #$NSF29FunctionKey "F29") +(hemlock-ext:define-keysym #$NSF30FunctionKey "F30") +(hemlock-ext:define-keysym #$NSF31FunctionKey "F31") +(hemlock-ext:define-keysym #$NSF32FunctionKey "F32") +(hemlock-ext:define-keysym #$NSF33FunctionKey "F33") +(hemlock-ext:define-keysym #$NSF34FunctionKey "F34") +(hemlock-ext:define-keysym #$NSF35FunctionKey "F35") + + +;;; Upper right key bank. +;;; +(hemlock-ext:define-keysym #$NSPrintScreenFunctionKey "Printscreen") +;; Couldn't type scroll lock. +(hemlock-ext:define-keysym #$NSPauseFunctionKey "Pause") + +;;; Middle right key bank. +;;; +(hemlock-ext:define-keysym #$NSInsertFunctionKey "Insert") +(hemlock-ext:define-keysym #$NSDeleteFunctionKey "Del" "Rubout" (string (code-char 127))) +(hemlock-ext:define-keysym #$NSHomeFunctionKey "Home") +(hemlock-ext:define-keysym #$NSPageUpFunctionKey "Pageup") +(hemlock-ext:define-keysym #$NSEndFunctionKey "End") +(hemlock-ext:define-keysym #$NSPageDownFunctionKey "Pagedown") + +;;; Arrows. +;;; +(hemlock-ext:define-keysym #$NSLeftArrowFunctionKey "Leftarrow") +(hemlock-ext:define-keysym #$NSUpArrowFunctionKey "Uparrow") +(hemlock-ext:define-keysym #$NSDownArrowFunctionKey "Downarrow") +(hemlock-ext:define-keysym #$NSRightArrowFunctionKey "Rightarrow") + + +;;; "Named" keys. +;;; +(hemlock-ext:define-keysym 9 "Tab") +(hemlock-ext:define-keysym 27 "Escape" "Altmode" "Alt") ;escape +(hemlock-ext:define-keysym 127 "Delete" "Backspace") ;backspace +(hemlock-ext:define-keysym 13 "Return" "Newline") +(hemlock-ext:define-keysym 10 "LineFeed") +(hemlock-ext:define-keysym 3 "Enter") +(hemlock-ext:define-keysym 32 "Space" " ") + +;;; Letters. +;;; +(hemlock-ext:define-keysym 97 "a") (hemlock-ext:define-keysym 65 "A") +(hemlock-ext:define-keysym 98 "b") (hemlock-ext:define-keysym 66 "B") +(hemlock-ext:define-keysym 99 "c") (hemlock-ext:define-keysym 67 "C") +(hemlock-ext:define-keysym 100 "d") (hemlock-ext:define-keysym 68 "D") +(hemlock-ext:define-keysym 101 "e") (hemlock-ext:define-keysym 69 "E") +(hemlock-ext:define-keysym 102 "f") (hemlock-ext:define-keysym 70 "F") +(hemlock-ext:define-keysym 103 "g") (hemlock-ext:define-keysym 71 "G") +(hemlock-ext:define-keysym 104 "h") (hemlock-ext:define-keysym 72 "H") +(hemlock-ext:define-keysym 105 "i") (hemlock-ext:define-keysym 73 "I") +(hemlock-ext:define-keysym 106 "j") (hemlock-ext:define-keysym 74 "J") +(hemlock-ext:define-keysym 107 "k") (hemlock-ext:define-keysym 75 "K") +(hemlock-ext:define-keysym 108 "l") (hemlock-ext:define-keysym 76 "L") +(hemlock-ext:define-keysym 109 "m") (hemlock-ext:define-keysym 77 "M") +(hemlock-ext:define-keysym 110 "n") (hemlock-ext:define-keysym 78 "N") +(hemlock-ext:define-keysym 111 "o") (hemlock-ext:define-keysym 79 "O") +(hemlock-ext:define-keysym 112 "p") (hemlock-ext:define-keysym 80 "P") +(hemlock-ext:define-keysym 113 "q") (hemlock-ext:define-keysym 81 "Q") +(hemlock-ext:define-keysym 114 "r") (hemlock-ext:define-keysym 82 "R") +(hemlock-ext:define-keysym 115 "s") (hemlock-ext:define-keysym 83 "S") +(hemlock-ext:define-keysym 116 "t") (hemlock-ext:define-keysym 84 "T") +(hemlock-ext:define-keysym 117 "u") (hemlock-ext:define-keysym 85 "U") +(hemlock-ext:define-keysym 118 "v") (hemlock-ext:define-keysym 86 "V") +(hemlock-ext:define-keysym 119 "w") (hemlock-ext:define-keysym 87 "W") +(hemlock-ext:define-keysym 120 "x") (hemlock-ext:define-keysym 88 "X") +(hemlock-ext:define-keysym 121 "y") (hemlock-ext:define-keysym 89 "Y") +(hemlock-ext:define-keysym 122 "z") (hemlock-ext:define-keysym 90 "Z") + +;;; Standard number keys. +;;; +(hemlock-ext:define-keysym 49 "1") (hemlock-ext:define-keysym 33 "!") +(hemlock-ext:define-keysym 50 "2") (hemlock-ext:define-keysym 64 "@") +(hemlock-ext:define-keysym 51 "3") (hemlock-ext:define-keysym 35 "#") +(hemlock-ext:define-keysym 52 "4") (hemlock-ext:define-keysym 36 "$") +(hemlock-ext:define-keysym 53 "5") (hemlock-ext:define-keysym 37 "%") +(hemlock-ext:define-keysym 54 "6") (hemlock-ext:define-keysym 94 "^") +(hemlock-ext:define-keysym 55 "7") (hemlock-ext:define-keysym 38 "&") +(hemlock-ext:define-keysym 56 "8") (hemlock-ext:define-keysym 42 "*") +(hemlock-ext:define-keysym 57 "9") (hemlock-ext:define-keysym 40 "(") +(hemlock-ext:define-keysym 48 "0") (hemlock-ext:define-keysym 41 ")") + +;;; "Standard" symbol keys. +;;; +(hemlock-ext:define-keysym 96 "`") (hemlock-ext:define-keysym 126 "~") +(hemlock-ext:define-keysym 45 "-") (hemlock-ext:define-keysym 95 "_") +(hemlock-ext:define-keysym 61 "=") (hemlock-ext:define-keysym 43 "+") +(hemlock-ext:define-keysym 91 "[") (hemlock-ext:define-keysym 123 "{") +(hemlock-ext:define-keysym 93 "]") (hemlock-ext:define-keysym 125 "}") +(hemlock-ext:define-keysym 92 "\\") (hemlock-ext:define-keysym 124 "|") +(hemlock-ext:define-keysym 59 ";") (hemlock-ext:define-keysym 58 ":") +(hemlock-ext:define-keysym 39 "'") (hemlock-ext:define-keysym 34 "\"") +(hemlock-ext:define-keysym 44 ",") (hemlock-ext:define-keysym 60 "<") +(hemlock-ext:define-keysym 46 ".") (hemlock-ext:define-keysym 62 ">") +(hemlock-ext:define-keysym 47 "/") (hemlock-ext:define-keysym 63 "?") + + +(hemlock-ext::define-mouse-keysym 1 #xe000 "Leftdown" "Super" :button-press) + +;;; + +;(hemlock-ext:define-keysym 65290 "linefeed") + + + + +;;;; SETFs of KEY-EVENT-CHAR and CHAR-KEY-EVENT. + +;;; Converting ASCII control characters to Common Lisp control characters: +;;; ASCII control character codes are separated from the codes of the +;;; "non-controlified" characters by the code of atsign. The ASCII control +;;; character codes range from ^@ (0) through ^_ (one less than the code of +;;; space). We iterate over this range adding the ASCII code of atsign to +;;; get the "non-controlified" character code. With each of these, we turn +;;; the code into a Common Lisp character and set its :control bit. Certain +;;; ASCII control characters have to be translated to special Common Lisp +;;; characters outside of the loop. +;;; With the advent of Hemlock running under X, and all the key bindings +;;; changing, we also downcase each Common Lisp character (where normally +;;; control characters come in upcased) in an effort to obtain normal command +;;; bindings. Commands bound to uppercase modified characters will not be +;;; accessible to terminal interaction. +;;; +(let ((@-code (char-code #\@))) + (dotimes (i (char-code #\space)) + (setf (hemlock-ext:char-key-event (code-char i)) + (hemlock-ext::make-key-event (string (char-downcase (code-char (+ i @-code)))) + (hemlock-ext:key-event-modifier-mask "control"))))) +(setf (hemlock-ext:char-key-event (code-char 9)) (hemlock-ext::make-key-event #k"Tab")) +(setf (hemlock-ext:char-key-event (code-char 10)) (hemlock-ext::make-key-event #k"Linefeed")) +(setf (hemlock-ext:char-key-event (code-char 13)) (hemlock-ext::make-key-event #k"Return")) +(setf (hemlock-ext:char-key-event (code-char 27)) (hemlock-ext::make-key-event #k"Alt")) +(setf (hemlock-ext:char-key-event (code-char 8)) (hemlock-ext::make-key-event #k"Backspace")) +;;; +;;; Other ASCII codes are exactly the same as the Common Lisp codes. +;;; +(do ((i (char-code #\space) (1+ i))) + ((= i 128)) + (setf (hemlock-ext:char-key-event (code-char i)) + (hemlock-ext::make-key-event (string (code-char i))))) + +;;; This makes KEY-EVENT-CHAR the inverse of CHAR-KEY-EVENT from the start. +;;; It need not be this way, but it is. +;;; +(dotimes (i 128) + (let ((character (code-char i))) + (setf (hemlock-ext::key-event-char (hemlock-ext:char-key-event character)) character))) + +;;; Since we treated these characters specially above when setting +;;; HEMLOCK-EXT:CHAR-KEY-EVENT above, we must set these HEMLOCK-EXT:KEY-EVENT-CHAR's specially +;;; to make quoting characters into Hemlock buffers more obvious for users. +;;; +(setf (hemlock-ext:key-event-char #k"C-h") #\backspace) +(setf (hemlock-ext:key-event-char #k"C-i") #\tab) +(setf (hemlock-ext:key-event-char #k"C-j") #\linefeed) +(setf (hemlock-ext:key-event-char #k"C-m") #\return) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/killcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/killcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/killcoms.lisp (revision 8058) @@ -0,0 +1,503 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Killing and unkilling things. +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; + +(in-package :hemlock) + +(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.") + + + + +;;;; Active Regions. + +(defhvar "Active Regions Enabled" + "When set, some commands that affect the current region only work when the + region is active." + :value t) + +(defhvar "Highlight Active Region" + "When set, the active region will be highlighted on the display if possible." + :value t) + + +(defvar *ephemerally-active-command-types* (list :ephemerally-active) + "This is a list of command types that permit the current region to be active + for the immediately following command.") + +(declaim (inline activate-region deactivate-region region-active-p)) + +(defun %buffer-activate-region (buffer) + (setf (hi::buffer-region-active buffer) (buffer-signature buffer))) + +(defun activate-region () + "Make the current region active." + (%buffer-activate-region (current-buffer))) + +(defun %buffer-deactivate-region (buffer) + (setf (hi::buffer-region-active buffer) nil)) + +(defun deactivate-region () + "Make the current region not active, in the current buffer." + (%buffer-deactivate-region (current-buffer))) + +(defun %buffer-region-active-p (b) + (eql (buffer-signature b) + (hi::buffer-region-active b))) + +(defun region-active-p () + "Returns t or nil, depending on whether the current region is active." + (%buffer-region-active-p (current-buffer))) + +(defun check-region-active () + "Signals an error when active regions are enabled and the current region + is not active." + (when (and (value active-regions-enabled) (not (region-active-p))) + (editor-error "The current region is not active."))) + +(defun current-region (&optional (error-if-not-active t) + (deactivate-region t)) + "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally + signalling an editor error if the current region is not active. A new + region is cons'ed on each call. This optionally deactivates the region." + (when error-if-not-active (check-region-active)) + (when deactivate-region (deactivate-region)) + (let ((point (current-point)) + (mark (current-mark))) + (if (mark< mark point) (region mark point) (region point mark)))) + + + + +(defcommand "Activate Region" (p) + "Make the current region active. ^G deactivates the region." + "Make the current region active." + (declare (ignore p)) + (activate-region)) + + + +(defun control-g-deactivate-region () + (deactivate-region)) +;;; +(add-hook abort-hook 'control-g-deactivate-region) + + + + +;;;; Buffer-Mark primitives and commands. + +;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the +;;; stack for each buffer. + +(defun current-mark () + "Returns the top of the current buffer's mark stack." + (buffer-mark (current-buffer))) + +(defun buffer-mark (buffer) + "Returns the top of buffer's mark stack." + (hi::buffer-%mark buffer)) + +(defun pop-buffer-mark () + "Pops the current buffer's mark stack, returning the mark. If the stack + becomes empty, a mark is push on the stack pointing to the buffer's start. + This always makes the current region not active." + (let* ((ring (value buffer-mark-ring)) + (buffer (current-buffer)) + (mark (buffer-mark buffer))) + (deactivate-region) + (setf (hi::buffer-%mark buffer) + (if (zerop (ring-length ring)) + (copy-mark + (buffer-start-mark (current-buffer)) :right-inserting) + (ring-pop ring))) + mark)) + + +(defun %buffer-push-buffer-mark (b mark activate-region) + (cond ((eq (line-buffer (mark-line mark)) b) + (setf (mark-kind mark) :right-inserting) + (let* ((old-mark (hi::buffer-%mark b))) + (when old-mark + (ring-push old-mark (variable-value 'buffer-mark-ring :buffer b)))) + (setf (hi::buffer-%mark b) mark)) + (t (error "Mark not in the current buffer."))) + (when activate-region (%buffer-activate-region b)) + mark) + + +(defun push-buffer-mark (mark &optional (activate-region nil)) + "Pushes mark into buffer's mark ring, ensuring that the mark is in the right + buffer and :right-inserting. Optionally, the current region is made active. + This never deactivates the current region. Mark is returned." + (%buffer-push-buffer-mark (current-buffer) mark activate-region)) + + +(defcommand "Set/Pop Mark" (p) + "Set or Pop the mark ring. + With no C-U's, pushes point as the mark, activating the current region. + With one C-U's, pops the mark into point, de-activating the current region. + With two C-U's, pops the mark and throws it away, de-activating the current + region." + "Set or Pop the mark ring." + (cond ((not p) + (push-buffer-mark (copy-mark (current-point)) t) + (when (interactive) + (message "Mark pushed."))) + ((= p (value universal-argument-default)) + (pop-and-goto-mark-command nil)) + ((= p (expt (value universal-argument-default) 2)) + (delete-mark (pop-buffer-mark))) + (t (editor-error)))) + +(defcommand "Pop and Goto Mark" (p) + "Pop mark into point, de-activating the current region." + "Pop mark into point." + (declare (ignore p)) + (let ((mark (pop-buffer-mark))) + (move-mark (current-point) mark) + (delete-mark mark))) + +(defcommand "Pop Mark" (p) + "Pop mark and throw it away, de-activating the current region." + "Pop mark and throw it away." + (declare (ignore p)) + (delete-mark (pop-buffer-mark))) + +(defcommand "Exchange Point and Mark" (p) + "Swap the positions of the point and the mark, activating region" + "Swap the positions of the point and the mark." + (declare (ignore p)) + (let ((point (current-point)) + (mark (current-mark))) + (with-mark ((temp point)) + (move-mark point mark) + (move-mark mark temp))) + (activate-region)) + +(defcommand "Mark Whole Buffer" (p) + "Set the region around the whole buffer, activating the region. + Pushes the point on the mark ring first, so two pops get it back. + With prefix argument, put mark at beginning and point at end." + "Put point at beginning and part at end of current buffer. + If P, do it the other way around." + (let* ((region (buffer-region (current-buffer))) + (start (region-start region)) + (end (region-end region)) + (point (current-point))) + (push-buffer-mark (copy-mark point)) + (cond (p (push-buffer-mark (copy-mark start) t) + (move-mark point end)) + (t (push-buffer-mark (copy-mark end) t) + (move-mark point start))))) + + + + +;;;; KILL-REGION and KILL-CHARACTERS primitives. + +(declaim (special *delete-char-region*)) + +;;; KILL-REGION first checks for any characters that may need to be added to +;;; the region. If there are some, we possibly push a region onto *kill-ring*, +;;; and we use the top of *kill-ring*. If there are no characters to deal +;;; with, then we make sure the ring isn't empty; if it is, just push our +;;; region. If there is some region in *kill-ring*, then see if the last +;;; command type was a region kill. Otherwise, just push the region. +;;; +(defun kill-region (region current-type) + "Kills the region saving it in *kill-ring*. Current-type is either + :kill-forward or :kill-backward. When LAST-COMMAND-TYPE is one of these, + region is appended or prepended, respectively, to the top of *kill-ring*. + The killing of the region is undo-able with \"Undo\". LAST-COMMAND-TYPE + is set to current-type. This interacts with KILL-CHARACTERS." + (let ((last-type (last-command-type)) + (insert-mark (copy-mark (region-start region) :left-inserting))) + (cond ((or (eq last-type :char-kill-forward) + (eq last-type :char-kill-backward)) + (when *delete-char-region* + (kill-ring-push *delete-char-region*) + (setf *delete-char-region* nil)) + (setf region (kill-region-top-of-ring region current-type))) + ((zerop (ring-length *kill-ring*)) + (setf region (delete-and-save-region region)) + (kill-ring-push region)) + ((or (eq last-type :kill-forward) (eq last-type :kill-backward)) + (setf region (kill-region-top-of-ring region current-type))) + (t + (setf region (delete-and-save-region region)) + (kill-ring-push region))) + (make-region-undo :insert "kill" (copy-region region) insert-mark) + (setf (last-command-type) current-type))) + +(defun kill-region-top-of-ring (region current-type) + (let ((r (ring-ref *kill-ring* 0))) + (ninsert-region (if (eq current-type :kill-forward) + (region-end r) + (region-start r)) + (delete-and-save-region region)) + r)) + +(defhvar "Character Deletion Threshold" + "When this many characters are deleted contiguously via KILL-CHARACTERS, + they are saved on the kill ring -- for example, \"Delete Next Character\", + \"Delete Previous Character\", or \"Delete Previous Character Expanding + Tabs\"." + :value 5) + +(defvar *delete-char-region* nil) +(defvar *delete-char-count* 0) + +;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET. +;;; If the last command type was a region kill, we just use the top region +;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is +;;; over the threshold. We don't call KILL-REGION in this case to save making +;;; undo's -- no good reason. If we were just called, then increment our +;;; global counter. Otherwise, make an empty region to keep KILL-CHAR-REGION +;;; happy and increment the global counter. +;;; +(defun kill-characters (mark count) + "Kills count characters after mark if positive, before mark if negative. + If called multiple times contiguously such that the sum of the count values + equals \"Character Deletion Threshold\", then the characters are saved on + *kill-ring*. This relies on setting LAST-COMMAND-TYPE, and it interacts + with KILL-REGION. If there are not count characters in the appropriate + direction, no characters are deleted, and nil is returned; otherwise, mark + is returned." + (if (zerop count) + mark + (with-mark ((temp mark :left-inserting)) + (if (character-offset temp count) + (let ((current-type (if (plusp count) + :char-kill-forward + :char-kill-backward)) + (last-type (last-command-type)) + (del-region (if (mark< temp mark) + (region temp mark) + (region mark temp)))) + (cond ((or (eq last-type :kill-forward) + (eq last-type :kill-backward)) + (setf *delete-char-count* + (value character-deletion-threshold)) + (setf *delete-char-region* nil)) + ((or (eq last-type :char-kill-backward) + (eq last-type :char-kill-forward)) + (incf *delete-char-count* (abs count))) + (t + (setf *delete-char-region* (make-empty-region)) + (setf *delete-char-count* (abs count)))) + (kill-char-region del-region current-type) + mark) + nil)))) + +(defun kill-char-region (region current-type) + (let ((deleted-region (delete-and-save-region region))) + (cond ((< *delete-char-count* (value character-deletion-threshold)) + (ninsert-region (if (eq current-type :char-kill-forward) + (region-end *delete-char-region*) + (region-start *delete-char-region*)) + deleted-region) + (setf (last-command-type) current-type)) + (t + (when *delete-char-region* + (kill-ring-push *delete-char-region*) + (setf *delete-char-region* nil)) + (let ((r (ring-ref *kill-ring* 0))) + (ninsert-region (if (eq current-type :char-kill-forward) + (region-end r) + (region-start r)) + deleted-region)) + (setf (last-command-type) + (if (eq current-type :char-kill-forward) + :kill-forward + :kill-backward)))))) + +(defun kill-ring-push (region) + (hi::region-to-clipboard region) + (ring-push region *kill-ring*)) + + + + + + +;;;; Commands. + +(defcommand "Kill Region" (p) + "Kill the region, pushing on the kill ring. + If the region is not active nor the last command a yank, signal an error." + "Kill the region, pushing on the kill ring." + (declare (ignore p)) + (kill-region (current-region) + (if (mark< (current-mark) (current-point)) + :kill-backward + :kill-forward))) + +(defcommand "Save Region" (p) + "Insert the region into the kill ring. + If the region is not active nor the last command a yank, signal an error." + "Insert the region into the kill ring." + (declare (ignore p)) + (kill-ring-push (copy-region (current-region)))) + +(defcommand "Kill Next Word" (p) + "Kill a word at the point. + With prefix argument delete that many words. The text killed is + appended to the text currently at the top of the kill ring if it was + next to the text being killed." + "Kill p words at the point" + (let ((point (current-point-for-deletion))) + (when point + (let* ((num (or p 1))) + (with-mark ((mark point :temporary)) + (if (word-offset mark num) + (if (minusp num) + (kill-region (region mark point) :kill-backward) + (kill-region (region point mark) :kill-forward)) + (editor-error))))))) + +(defcommand "Kill Previous Word" (p) + "Kill a word before the point. + With prefix argument kill that many words before the point. The text + being killed is appended to the text currently at the top of the kill + ring if it was next to the text being killed." + "Kill p words before the point" + (kill-next-word-command (- (or p 1)))) + + +(defcommand "Kill Line" (p) + "Kills the characters to the end of the current line. + If the line is empty then the line is deleted. With prefix argument, + deletes that many lines past the point (or before if the prefix is negative)." + "Kills p lines after the point." + (let* ((point (current-point-for-deletion))) + (when point + (let* ((line (mark-line point))) + (with-mark ((mark point)) + (cond + (p + (when (and (/= (mark-charpos point) 0) (minusp p)) + (incf p)) + (unless (line-offset mark p 0) + (if (plusp p) + (kill-region (region point (buffer-end mark)) :kill-forward) + (kill-region (region (buffer-start mark) point) :kill-backward)) + (editor-error)) + (if (plusp p) + (kill-region (region point mark) :kill-forward) + (kill-region (region mark point) :kill-backward))) + (t + (cond ((not (blank-after-p mark)) + (line-end mark)) + ((line-next line) + (line-start mark (line-next line))) + ((not (end-line-p mark)) + (line-end mark)) + (t + (editor-error))) + (kill-region (region point mark) :kill-forward)))))))) + +(defcommand "Backward Kill Line" (p) + "Kill from the point to the beginning of the line. + If at the beginning of the line, kill the newline and any trailing space + on the previous line. With prefix argument, call \"Kill Line\" with + the argument negated." + "Kills p lines before the point." + (if p + (kill-line-command (- p)) + (let* ((point (current-point-for-deletion))) + (when point + (with-mark ((m point)) + (cond ((zerop (mark-charpos m)) + (mark-before m) + (unless (reverse-find-attribute m :space #'zerop) + (buffer-start m))) + (t + (line-start m))) + (kill-region (region m (current-point)) :kill-backward)))))) + + +(defcommand "Delete Blank Lines" (p) + "On a blank line, deletes all surrounding blank lines, leaving just + one. On an isolated blank line, deletes that one. On a non-blank line, + deletes all blank following that one." + "Kill blank lines around the point" + (declare (ignore p)) + (let ((point (current-point-for-deletion))) + (when point + (with-mark ((beg-mark point :left-inserting) + (end-mark point :right-inserting)) + ;; handle case when the current line is blank + (when (blank-line-p (mark-line point)) + ;; back up to last non-whitespace character + (reverse-find-attribute beg-mark :whitespace #'zerop) + (when (previous-character beg-mark) + ;; that is, we didn't back up to the beginning of the buffer + (unless (same-line-p beg-mark end-mark) + (line-offset beg-mark 1 0))) + ;; if isolated, zap the line else zap the blank ones above + (cond ((same-line-p beg-mark end-mark) + (line-offset end-mark 1 0)) + (t + (line-start end-mark))) + (delete-region (region beg-mark end-mark))) + ;; always delete all blank lines after the current line + (move-mark beg-mark point) + (when (line-offset beg-mark 1 0) + (move-mark end-mark beg-mark) + (find-attribute end-mark :whitespace #'zerop) + (when (next-character end-mark) + ;; that is, we didn't go all the way to the end of the buffer + (line-start end-mark)) + (delete-region (region beg-mark end-mark))))))) + + +(defcommand "Un-Kill" (p) + "Inserts the top item in the kill-ring at the point. + The mark is left mark before the insertion and the point after. With prefix + argument inserts the prefix'th most recent item." + "Inserts the item with index p in the kill ring at the point, leaving + the mark before and the point after." + (let ((idx (1- (or p 1)))) + (cond ((> (ring-length *kill-ring*) idx -1) + (let* ((region (ring-ref *kill-ring* idx)) + (point (current-point-for-insertion)) + (mark (copy-mark point))) + (push-buffer-mark mark) + (insert-region point region) + (make-region-undo :delete "Un-Kill" + (region (copy-mark mark) (copy-mark point)))) + (setf (last-command-type) :unkill)) + (t (editor-error))))) +;;; +(push :unkill *ephemerally-active-command-types*) + +(defcommand "Rotate Kill Ring" (p) + "Replace un-killed text with previously killed text. + Kills the current region, rotates the kill ring, and inserts the new top + item. With prefix argument rotates the kill ring that many times." + "This function will not behave in any reasonable fashion when + called as a lisp function." + (let ((point (current-point)) + (mark (current-mark))) + (cond ((or (not (eq (last-command-type) :unkill)) + (zerop (ring-length *kill-ring*))) + (editor-error)) + (t (delete-region (region mark point)) + (rotate-ring *kill-ring* (or p 1)) + (insert-region point (ring-ref *kill-ring* 0)) + (make-region-undo :delete "Un-Kill" + (region (copy-mark mark) (copy-mark point))) + (setf (last-command-type) :unkill))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/line.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/line.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/line.lisp (revision 8058) @@ -0,0 +1,167 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains definitions for the Line structure, and some +;;; functions and macros to manipulate them. +;;; +;;; This stuff was allowed to become implementation dependant because +;;; you make thousands of lines, so speed is real important. In some +;;; implementations (the Perq for example) it may be desirable to +;;; not actually cons the strings in the line objects until someone +;;; touches them, and just keep a pointer in the line to where the file +;;; is mapped in memory. Such lines are called "buffered". This stuff +;;; links up with the file-reading stuff and the line-image building stuff. +;;; +(in-package :hemlock-internals) + +(setf (documentation 'linep 'function) + "Returns true if its argument is a Hemlock line object, Nil otherwise.") +(setf (documentation 'line-previous 'function) + "Return the Hemlock line that precedes this one, or Nil if there is no + previous line.") +(setf (documentation 'line-next 'function) + "Return the Hemlock line that follows this one, or Nil if there is no + next line.") +(setf (documentation 'line-plist 'function) + "Return a line's property list. This may be manipulated with Setf and Getf.") + + +;;;; The line object: + +(declaim (inline %make-line)) +(defstruct (line (:print-function %print-hline) + (:constructor %make-line) + (:predicate linep)) + "A Hemlock line object. See Hemlock design document for details." + ;; + ;; Something that represents the contents of the line. This is + ;; guaranteed to change (as compared by EQL) whenver the contents of the + ;; line changes, but might at arbitarary other times. There are + ;; currently about three different cases: + ;; + ;; Normal: + ;; A simple string holding the contents of the line. + ;; + ;; A cached line: + ;; The line is eq to Open-Line, and the actual contents are in the + ;; line cache. The %Chars may be either the original contents or a + ;; negative fixnum. + ;; + ;; A buffered line: + ;; The line hasn't been touched since it was read from a file, and the + ;; actual contents are in some system I/O area. This is indicated by + ;; the Line-Buffered-P slot being true. In buffered lines on the RT, + ;; the %Chars slot contains the system-area-pointer to the beginning + ;; of the characters. + (%chars "") + ;; + ;; Pointers to the next and previous lines in the doubly linked list of + ;; line structures. + previous + next + ;; + ;; A list of all the permanent marks pointing into this line. + (marks ()) + ;; + ;; The buffer to which this line belongs, or a *disembodied-buffer-count* + ;; if the line is not in any buffer. + %buffer + ;; + ;; A non-negative integer (fixnum) that represents the ordering of lines + ;; within continguous range of lines (a buffer or disembuffered region). + ;; The number of the Line-Next is guaranteed to be strictly greater than + ;; our number, and the Line-Previous is guaranteed to be strictly less. + (number 0) + ;; + ;; The line property list, used by user code to annotate the text. + plist + ;; + ;; The (logical) origin within a buffer or disembodied region, or NIL + ;; if we aren't sure. + origin) + + + + +;;; If buffered lines are supported, then we create the string +;;; representation for the characters when someone uses Line-Chars. People +;;; who are prepared to handle buffered lines or who just want a signature +;;; for the contents can use Line-%chars directly. +;;; +(defmacro line-chars (line) + `(the simple-string (line-%chars ,line))) +;;; +(defsetf line-chars %set-line-chars) +;;; +(defmacro %set-line-chars (line chars) + `(setf (line-%chars ,line) ,chars)) + + +;;; Line-Signature -- Public +;;; +;;; We can just return the Line-%Chars. +;;; +(declaim (inline line-signature)) +(defun line-signature (line) + "This function returns an object which serves as a signature for a line's + contents. It is guaranteed that any modification of text on the line will + result in the signature changing so that it is not EQL to any previous value. + Note that the signature may change even when the text hasn't been modified, but + this probably won't happen often." + (line-%chars line)) + + +;;; Return a copy of Line in buffer Buffer with the same chars. We use +;;; this macro where we want to copy a line because it takes care of +;;; the case where the line is buffered. +;;; +(defmacro %copy-line (line &key previous number %buffer) + `(make-line :chars (line-%chars ,line) + :previous ,previous + :number ,number + :%buffer ,%buffer )) + +;;; Hide the fact that the slot isn't really called CHARS. +;;; +(defmacro make-line (&rest keys) + `(%make-line ,@(substitute :%chars :chars keys))) + +(defmacro line-length* (line) + "Returns the number of characters on the line, but it's a macro!" + `(cond ((current-open-line-p ,line) + (+ (current-left-open-pos) (- (current-line-cache-length) (current-right-open-pos)))) + (t + (length (the simple-string (line-%chars ,line)))))) + + + +(defun get-line-origin (line) + (or (line-origin line) + (do* ((prev (line-previous line) (line-previous prev)) + (this line)) + ((or (null prev) (line-origin this)) + (let* ((start (or (line-origin this) + (setf (line-origin this) 0)))) + (do* ((next (line-next this) (line-next next))) + ((null next) 0) + (incf start (1+ (line-length this))) + (setq this next) + (setf (line-origin this) start) + (when (eq this line) (return start))))) + (setq this prev)))) + +(defun adjust-line-origins-forward (line) + (let* ((start (get-line-origin line))) + (do* ((next (line-next line) (line-next next))) + ((null next)) + (incf start (1+ (line-length* line))) + (setf (line-origin next) start) + (setq line next)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/linimage.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/linimage.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/linimage.lisp (revision 8058) @@ -0,0 +1,478 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file contains functions related to building line images. +;;; +(in-package :hemlock-internals) + +;;; The code in here is factored out in this way because it is more +;;; or less implementation dependant. The reason this code is +;;; implementation dependant is not because it is not written in +;;; Common Lisp per se, but because it uses this thing called +;;; %SP-Find-Character-With-Attribute to find any characters that +;;; are to be displayed on the line which do not print as themselves. +;;; This permits us to have an arbitrary string or even string-valued +;;; function to as the representation for such a "Funny" character +;;; with minimal penalty for the normal case. This function can be written +;;; in lisp, and is included commented-out below, but if this function +;;; is not real fast then redisplay performance will suffer. +;;; +;;; Theres also code in here that special-cases "Buffered" lines, +;;; which is not exactly Common Lisp, but if you aren't on a perq, +;;; you won't have to worry about it. +;;; +;(defun %sp-find-character-with-attribute (string start end table mask) +; (declare (type (simple-array (mod 256) char-code-max) table)) +; (declare (simple-string string)) +; (declare (fixnum start end)) +; "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask +; The codes of the characters of String from Start to End are used as indices +; into the Table, which is a U-Vector of 8-bit bytes. When the number picked +; up from the table bitwise ANDed with Mask is non-zero, the current +; index into the String is returned. The corresponds to SCANC on the Vax." +; (do ((index start (1+ index))) +; ((= index end) nil) +; (declare (fixnum index)) +; (if (/= (logand (aref table (char-code (elt string index))) mask) 0) +; (return index)))) +; +;(defun %sp-reverse-find-character-with-attribute (string start end table +; mask) +; (declare (type (simple-array (mod 256) char-code-max) table)) +; (declare (simple-string string)) +; (declare (fixnum start end)) +; "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." +; (do ((index (1- end) (1- index))) +; ((< index start) nil) +; (declare (fixnum index)) +; (if (/= (logand (aref table (char-code (elt string index))) mask) 0) +; (return index)))) + + +(defconstant winning-char #b01 "Bit for a char that prints normally") +(defconstant losing-char #b10 "Bit for char with funny representation.") +(defvar *losing-character-mask* + (make-array char-code-limit :element-type '(mod 256) + :initial-element winning-char) + "This is a character set used by redisplay to find funny chars.") +(defvar *print-representation-vector* nil + "Redisplay's handle on the :print-representation attribute") + +;;; Do a find-character-with-attribute on the *losing-character-mask*. +(defmacro %fcwa (str start end mask) + `(%sp-find-character-with-attribute + ,str ,start ,end *losing-character-mask* ,mask)) + +;;; Get the print-representation of a character. +(defmacro get-rep (ch) + `(svref *print-representation-vector* (char-code ,ch))) + + + + +(declaim (special *character-attributes*)) + +;;; %init-line-image -- Internal +;;; +;;; Set up the print-representations for funny chars. We make the +;;; attribute vector by hand and do funny stuff so that chars > 127 +;;; will have a losing print-representation, so redisplay will not +;;; die if you visit a binary file or do something stupid like that. +;;; +(defun %init-line-image () + (defattribute "Print Representation" + "The value of this attribute determines how a character is displayed + on the screen. If the value is a string this string is literally + displayed. If it is a function, then that function is called with + the current X position to get the string to display.") + (setq *print-representation-vector* + (make-array char-code-limit :initial-element nil)) + (setf (attribute-descriptor-vector + (gethash :print-representation *character-attributes*)) + *print-representation-vector*) + (do ((code 128 (1+ code)) + (str (make-string 4) (make-string 4))) + ((= code char-code-limit)) + (setf (aref *losing-character-mask* code) losing-char) + (setf (aref *print-representation-vector* code) str) + (setf (schar str 0) #\<) + (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16))) + (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16))) + (setf (schar str 3) #\>)) + + (add-hook hemlock::character-attribute-hook + #'redis-set-char-attribute-hook-fun) + (do ((i (1- (char-code #\space)) (1- i)) str) + ((minusp i)) + (setq str (make-string 2)) + (setf (elt (the simple-string str) 0) #\^) + (setf (elt (the simple-string str) 1) + (code-char (+ i (char-code #\@)))) + (setf (character-attribute :print-representation (code-char i)) str)) + (setf (character-attribute :print-representation (code-char #o177)) "^?") + (setf (character-attribute :print-representation #\tab) + #'redis-tab-display-fun)) + + +;;; redis-set-char-attribute-hook-fun +;;; +;;; Keep track of which characters have funny representations. +;;; +(defun redis-set-char-attribute-hook-fun (attribute char new-value) + (when (eq attribute :print-representation) + (cond + ((simple-string-p new-value) + (if (and (= (length (the simple-string new-value)) 1) + (char= char (elt (the simple-string new-value) 0))) + (setf (aref *losing-character-mask* (char-code char)) winning-char) + (setf (aref *losing-character-mask* (char-code char)) + losing-char))) + ((functionp new-value) + (setf (aref *losing-character-mask* (char-code char)) losing-char)) + (t (error "Bad print representation: ~S" new-value))))) + +;;; redis-tab-display-fun +;;; +;;; This function is initially the :print-representation for tab. +;;; +(defun redis-tab-display-fun (xpos) + (svref '#(" " + " " + " " + " " + " " + " " + " " + " ") + (logand xpos 7))) + + + +;;;; The actual line image computing functions. +;;;; + +(eval-when (:compile-toplevel :execute) +;;; display-some-chars -- internal +;;; +;;; Put some characters into a window. Characters from src-start +;;; to src-end in src are are put in the window's dis-line's. Lines +;;; are wrapped as necessary. dst is the dis-line-chars of the dis-line +;;; currently being written. Dis-lines is the window's vector of dis-lines. +;;; dis-line is the dis-line currently being written. Line is the index +;;; into dis-lines of the current dis-line. dst-start is the index to +;;; start writing chars at. Height and width are the height and width of the +;;; window. src-start, dst, dst-start, line and dis-line are updated. +;;; Done-P indicates whether there are more characters after this sequence. +;;; +(defmacro display-some-chars (src src-start src-end dst dst-start width done-p) + `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start)))) + (declare (fixnum dst-end)) + (cond + ((>= dst-end ,width) + (cond + ((and ,done-p (= dst-end ,width)) + (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end) + (setq ,dst-start dst-end ,src-start ,src-end)) + (t + (let ((1-width (1- ,width))) + (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width) + (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*) + (setq ,src-start (+ ,src-start (- 1-width ,dst-start))) + (setq ,dst-start nil))))) + (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end) + (setq ,dst-start dst-end ,src-start ,src-end))))) + +;;; These macros are given as args to display-losing-chars to get the +;;; print representation of whatever is in the data vector. +(defmacro string-get-rep (string index) + `(get-rep (schar ,string ,index))) + +(defmacro u-vec-get-rep (u-vec index) + `(svref *print-representation-vector* + (hemlock-ext:sap-ref-8 ,u-vec ,index))) + +;;; display-losing-chars -- Internal +;;; +;;; This macro is called by the compute-line-image functions to +;;; display a group of losing characters. +;;; +(defmacro display-losing-chars (line-chars index end dest xpos width + string underhang access-fun + &optional (done-p `(= ,index ,end))) + `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end)) + (len 0) + (zero 0) + str) + (()) + (declare (fixnum last len zero)) + (setq str (,access-fun ,line-chars ,index)) + (unless (simple-string-p str) (setq str (funcall str ,xpos))) + (setq len (strlen str) zero 0) + (incf ,index) + (display-some-chars str zero len ,dest ,xpos ,width ,done-p) + (cond ((not ,xpos) + ;; We wrapped in the middle of a losing char. + (setq ,underhang zero ,string str) + (return nil)) + ((= ,index last) + ;; No more losing chars in this bunch. + (return nil))))) + +(defmacro update-and-punt (dis-line length string underhang end) + `(progn (setf (dis-line-length ,dis-line) ,length) + (return (values ,string ,underhang + (setf (dis-line-end ,dis-line) ,end))))) + +); eval-when + + +;;; compute-normal-line-image -- Internal +;;; +;;; Compute the screen representation of Line starting at Start +;;; putting it in Dis-Line beginning at Xpos. Width is the width of the +;;; window we are displaying in. If the line will wrap then we display +;;; as many chars as we can then put in *line-wrap-char*. The values +;;; returned are described in Compute-Line-Image, which tail-recursively +;;; returns them. The length slot in Dis-Line is updated. +;;; +;;; We use the *losing-character-mask* to break the line to be displayed +;;; up into chunks of characters with normal print representation and +;;; those with funny representations. +;;; +(defun compute-normal-line-image (line start dis-line xpos width) + (declare (fixnum start width) (type (or fixnum null) xpos)) + (do* ((index start) + (line-chars (line-%chars line)) + (end (strlen line-chars)) + (dest (dis-line-chars dis-line)) + (losing 0) + underhang string) + (()) + (declare (fixnum index end) + (type (or fixnum null) losing) + (simple-string line-chars dest)) + (cond + (underhang + (update-and-punt dis-line width string underhang index)) + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ((= index end) + (update-and-punt dis-line xpos nil nil index))) + (setq losing (%fcwa line-chars index end losing-char)) + (when (null losing) + (display-some-chars line-chars index end dest xpos width t) + (if (or xpos (= index end)) + (update-and-punt dis-line xpos nil nil index) + (update-and-punt dis-line width nil 0 index))) + (display-some-chars line-chars index losing dest xpos width nil) + (cond + ;; Did we wrap? + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ;; Are we about to cause the line to wrap? If so, wrap before + ;; it's too late. + ((= xpos width) + (setf (char dest (1- width)) *line-wrap-char*) + (update-and-punt dis-line width nil 0 index)) + (t + (display-losing-chars line-chars index end dest xpos width string + underhang string-get-rep))))) + + + +;;; compute-cached-line-image -- Internal +;;; +;;; Like compute-normal-line-image, only works on the cached line. +;;; +(defun compute-cached-line-image (index dis-line xpos width) + (declare (fixnum index width) (type (or fixnum null) xpos)) + (prog ((gap (- (current-right-open-pos) (current-left-open-pos))) + (dest (dis-line-chars dis-line)) + (done-p (= (current-right-open-pos) (current-line-cache-length))) + (losing 0) + string underhang) + (declare (fixnum gap) (simple-string dest) + (type (or fixnum null) losing)) + LEFT-LOOP + (cond + (underhang + (update-and-punt dis-line width string underhang index)) + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ((>= index (current-left-open-pos)) + (go RIGHT-START))) + (setq losing (%fcwa (current-open-chars) index (current-left-open-pos) losing-char)) + (cond + (losing + (display-some-chars (current-open-chars) index losing dest xpos width nil) + ;; If we we didn't wrap then display some losers... + (if xpos + (display-losing-chars (current-open-chars) index (current-left-open-pos) dest xpos + width string underhang string-get-rep + (and done-p (= index (current-left-open-pos)))) + (update-and-punt dis-line width nil 0 index))) + (t + (display-some-chars (current-open-chars) index (current-left-open-pos) dest xpos width done-p))) + (go LEFT-LOOP) + + RIGHT-START + (setq index (+ index gap)) + RIGHT-LOOP + (cond + (underhang + (update-and-punt dis-line width string underhang (- index gap))) + ((null xpos) + (update-and-punt dis-line width nil 0 (- index gap))) + ((= index (current-line-cache-length)) + (update-and-punt dis-line xpos nil nil (- index gap)))) + (setq losing (%fcwa (current-open-chars) index (current-line-cache-length) losing-char)) + (cond + (losing + (display-some-chars (current-open-chars) index losing dest xpos width nil) + (cond + ;; Did we wrap? + ((null xpos) + (update-and-punt dis-line width nil 0 (- index gap))) + (t + (display-losing-chars (current-open-chars) index (current-line-cache-length) dest xpos + width string underhang string-get-rep)))) + (t + (display-some-chars (current-open-chars) index (current-line-cache-length) dest xpos width t))) + (go RIGHT-LOOP))) + + +(defun make-some-font-changes () + (do ((res nil (make-font-change res)) + (i 42 (1- i))) + ((zerop i) res))) + +(defvar *free-font-changes* (make-some-font-changes) + "Font-Change structures that nobody's using at the moment.") + +(defmacro alloc-font-change (x font mark) + `(progn + (unless *free-font-changes* + (setq *free-font-changes* (make-some-font-changes))) + (let ((new-fc *free-font-changes*)) + (setq *free-font-changes* (font-change-next new-fc)) + (setf (font-change-x new-fc) ,x + (font-change-font new-fc) ,font + (font-change-next new-fc) nil + (font-change-mark new-fc) ,mark) + new-fc))) + +;;; +;;; compute-line-image -- Internal +;;; +;;; This function builds a full line image from some characters in +;;; a line and from some characters which may be left over from the previous +;;; line. +;;; +;;; Parameters: +;;; String - This is the string which contains the characters left over +;;; from the previous line. This is NIL if there are none. +;;; Underhang - Characters from here to the end of String are put at the +;;; beginning of the line image. +;;; Line - This is the line to display characters from. +;;; Offset - This is the index of the first character to display in Line. +;;; Dis-Line - This is the dis-line to put the line-image in. The only +;;; slots affected are the chars and the length. +;;; Width - This is the width of the field to display in. +;;; +;;; Three values are returned: +;;; 1) The new overhang string, if none this is NIL. +;;; 2) The new underhang, if this is NIL then the entire line was +;;; displayed. If the entire line was not displayed, but there was no +;;; underhang, then this is 0. +;;; 3) The index in line after the last character displayed. +;;; +(defun compute-line-image (string underhang line offset dis-line width) + ;; + ;; Release any old font-changes. + (let ((changes (dis-line-font-changes dis-line))) + (when changes + (do ((prev changes current) + (current (font-change-next changes) + (font-change-next current))) + ((null current) + (setf (dis-line-font-changes dis-line) nil) + (shiftf (font-change-next prev) *free-font-changes* changes)) + (setf (font-change-mark current) nil)))) + ;; + ;; If the line has any Font-Marks, add Font-Changes for them. + (let ((marks (line-marks line))) + (when (dolist (m marks nil) + (when (fast-font-mark-p m) (return t))) + (let ((prev nil)) + ;; + ;; Find the last Font-Mark with charpos less than Offset. If there is + ;; such a Font-Mark, then there is a font-change to this font at X = 0. + (let ((max -1) + (max-mark nil)) + (dolist (m marks) + (when (fast-font-mark-p m) + (let ((charpos (mark-charpos m))) + (when (and (< charpos offset) (> charpos max)) + (setq max charpos max-mark m))))) + (when max-mark + (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark)) + (setf (dis-line-font-changes dis-line) prev))) + ;; + ;; Repeatedly scan through marks, adding a font-change for the + ;; smallest Font-Mark with a charpos greater than Bound, until + ;; we find no such mark. + (do ((bound (1- offset) min) + (min most-positive-fixnum most-positive-fixnum) + (min-mark nil nil)) + (()) + (dolist (m marks) + (when (fast-font-mark-p m) + (let ((charpos (mark-charpos m))) + (when (and (> charpos bound) (< charpos min)) + (setq min charpos min-mark m))))) + (unless min-mark (return nil)) + (let ((len (if (current-open-line-p line) + (cached-real-line-length line 10000 offset min) + (real-line-length line 10000 offset min)))) + (when (< len width) + (let ((new (alloc-font-change + (+ len + (if string + (- (length (the simple-string string)) underhang) + 0)) + (font-mark-font min-mark) + min-mark))) + (if prev + (setf (font-change-next prev) new) + (setf (dis-line-font-changes dis-line) new)) + (setq prev new)))))))) + ;; + ;; Recompute the line image. + (cond + (string + (let ((len (strlen string)) + (chars (dis-line-chars dis-line)) + (xpos 0)) + (declare (type (or fixnum null) xpos) (simple-string chars)) + (display-some-chars string underhang len chars xpos width nil) + (cond + ((null xpos) + (values string underhang offset)) + ((current-open-line-p line) + (compute-cached-line-image offset dis-line xpos width)) + (t + (compute-normal-line-image line offset dis-line xpos width))))) + ((current-open-line-p line) + (compute-cached-line-image offset dis-line 0 width)) + (t + (compute-normal-line-image line offset dis-line 0 width)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/lispdep.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/lispdep.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/lispdep.lisp (revision 8058) @@ -0,0 +1,71 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: HEMLOCK-EXT; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Lisp Implementation Dependent Stuff for Hemlock +;;; Created: 2002-11-07 +;;; Author: Gilbert Baumann +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2002 by Gilbert Baumann + +(in-package :hemlock-ext) + +#+CLISP +(progn + (setf custom:*FLOATING-POINT-CONTAGION-ANSI* t) + (setf custom:*WARN-ON-FLOATING-POINT-CONTAGION* nil)) + +(defun getenv (name) + #.(or + #+EXCL '(sys:getenv name) + #+CLISP '(ext:getenv name) + #+CMU '(cdr (assoc name ext:*environment-list* :test #'string=)) + #+scl '(cdr (assoc name ext:*environment-list* :test #'string-equal)) + #+sbcl '(sb-ext:posix-getenv name) + #+openmcl '(ccl::getenv name) + (error "Find an implementation of getenv for your Lisp."))) + +(defmacro without-interrupts (&body body) + `(#+EXCL excl:without-interrupts + #+CMU sys:without-interrupts + #+sbcl sb-sys:without-interrupts + #+openmcl ccl:without-interrupts + #-(or EXCL CMU sbcl openmcl) progn + ,@body)) + +(defmacro fixnump (object) + #+CMU `(ext:fixnump ,object) + #+scl `(ext:fixnump ,object) + #+EXCL `(excl:fixnump ,object) + #+CLISP `(sys::fixnump ,object) + #-(or CMU EXCL CLISP scl) `(typep ,object 'fixnum)) + +(defun file-writable (pathname) + "File-writable accepts a pathname and returns T if the current + process can write it, and NIL otherwise. Also if the file does + not exist return T." + #+(or CMU scl) + (ext:file-writable pathname) + #-(or cmu scl) + (handler-case (let ((io (open pathname + :direction :output + :if-exists :append + :if-does-not-exist nil))) + (if io + (close io :abort t) + ;; more complicate situation: + ;; we want test if we can create the file. + (let ((io (open pathname + :direction :output + :if-exists nil + :if-does-not-exist :create))) + (if io + (progn + (close io) + (delete-file io)) + t)))) + (file-error (err) + (declare (ignore err)) + nil)) ) + + +(defmacro without-gcing (&body body) + `(progn ,@body)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/lispmode.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/lispmode.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/lispmode.lisp (revision 8058) @@ -0,0 +1,2005 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock LISP Mode commands +;;; +;;; Written by Ivan Vazquez and Bill Maddox. +;;; + +(in-package :hemlock) + +;; (declaim (optimize (speed 2))); turn off byte compilation. + + + +;;;; Variables and lisp-info structure. + +;;; These routines are used to define, for standard LISP mode, the start and end +;;; of a block to parse. If these need to be changed for a minor mode that sits +;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the +;;; name of the function to use instead of START-OF-PARSE-BLOCK and +;;; END-OF-PARSE-BLOCK. +;;; + +(defhvar "Parse Start Function" + "Take a mark and move it to the top of a block for paren parsing." + :value 'start-of-parse-block) + +(defhvar "Parse End Function" + "Take a mark and move it to the bottom of a block for paren parsing." + :value 'end-of-parse-block) + + +;;; LISP-INFO is the structure used to store the data about the line in its +;;; Plist. +;;; +;;; -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether +;;; or not a line's begining and/or ending are quoted. +;;; +;;; -> RANGES-TO-IGNORE is a list of cons cells, each having the form +;;; ( [begining-charpos] [end-charpos] ) each of these cells indicating +;;; a range to ignore. End is exclusive. +;;; +;;; -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of +;;; unmatched opening and closing parens that there are on a line. +;;; +;;; -> SIGNATURE-SLOT ... +;;; + +(defstruct (lisp-info (:constructor make-lisp-info ())) + (begins-quoted nil) ; (or t nil) + (ending-quoted nil) ; (or t nil) + (ranges-to-ignore nil) ; (or t nil) + (net-open-parens 0 :type fixnum) + (net-close-parens 0 :type fixnum) + (signature-slot)) + + + + +;;;; Macros. + +;;; The following Macros exist to make it easy to acces the Syntax primitives +;;; without uglifying the code. They were originally written by Maddox. +;;; + +(defmacro scan-char (mark attribute values) + `(find-attribute ,mark ',attribute ,(attr-predicate values))) + +(defmacro rev-scan-char (mark attribute values) + `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values))) + +(defmacro test-char (char attribute values) + `(let ((x (character-attribute ',attribute ,char))) + ,(attr-predicate-aux values))) + +(eval-when (:compile-toplevel :execute :load-toplevel) +(defun attr-predicate (values) + (cond ((eq values 't) + '#'plusp) + ((eq values 'nil) + '#'zerop) + (t `#'(lambda (x) ,(attr-predicate-aux values))))) + +(defun attr-predicate-aux (values) + (cond ((eq values t) + '(plusp x)) + ((eq values nil) + '(zerop x)) + ((symbolp values) + `(eq x ',values)) + ((and (listp values) (member (car values) '(and or not))) + (cons (car values) (mapcar #'attr-predicate-aux (cdr values)))) + (t (error "Illegal form in attribute pattern - ~S" values)))) + +); Eval-When + +;;; +;;; FIND-LISP-CHAR + +(defmacro find-lisp-char (mark) + "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL." + `(find-attribute ,mark :lisp-syntax + #'(lambda (x) + (member x '(:open-paren :close-paren :newline :comment + :char-quote :string-quote))))) +;;; +;;; PUSH-RANGE + +(defmacro push-range (new-range info-struct) + "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT." + `(when ,new-range + (setf (lisp-info-ranges-to-ignore ,info-struct) + (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct))))) +;;; +;;; SCAN-DIRECTION + +(defmacro scan-direction (mark forwardp &rest forms) + "Expand to a form that scans either backward or forward according to Forwardp." + (if forwardp + `(scan-char ,mark ,@forms) + `(rev-scan-char ,mark ,@forms))) +;;; +;;; DIRECTION-CHAR + +(defmacro direction-char (mark forwardp) + "Expand to a form that returns either the previous or next character according + to Forwardp." + (if forwardp + `(next-character ,mark) + `(previous-character ,mark))) + +;;; +;;; NEIGHBOR-MARK + +(defmacro neighbor-mark (mark forwardp) + "Expand to a form that moves MARK either backward or forward one character, + depending on FORWARDP." + (if forwardp + `(mark-after ,mark) + `(mark-before ,mark))) + +;;; +;;; NEIGHBOR-LINE + +(defmacro neighbor-line (line forwardp) + "Expand to return the next or previous line, according to Forwardp." + (if forwardp + `(line-next ,line) + `(line-previous ,line))) + + + +;;;; Parsing functions. + +;;; PRE-COMMAND-PARSE-CHECK -- Public. +;;; +(defun pre-command-parse-check (mark &optional (fer-sure-parse nil)) + "Parse the area before the command is actually executed." + (with-mark ((top mark) + (bottom mark)) + (funcall (value parse-start-function) top) + (funcall (value parse-end-function) bottom) + (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse))) + +;;; PARSE-OVER-BLOCK +;;; +(defun parse-over-block (start-line end-line &optional (fer-sure-parse nil)) + "Parse over an area indicated from END-LINE to START-LINE." + (let ((test-line start-line) + prev-line-info) + + (with-mark ((mark (mark test-line 0))) + + ; Set the pre-begining and post-ending lines to delimit the range + ; of action any command will take. This means set the lisp-info of the + ; lines immediately before and after the block to Nil. + + (when (line-previous start-line) + (setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil)) + (when (line-next end-line) + (setf (getf (line-plist (line-next end-line)) 'lisp-info) nil)) + + (loop + (let ((line-info (getf (line-plist test-line) 'lisp-info))) + + ;; Reparse the line when any of the following are true: + ;; + ;; FER-SURE-PARSE is T + ;; + ;; LINE-INFO or PREV-LINE-INFO are Nil. + ;; + ;; If the line begins quoted and the previous one wasn't + ;; ended quoted. + ;; + ;; The Line's signature slot is invalid (the line has changed). + ;; + + (when (or fer-sure-parse + (not line-info) + (not prev-line-info) + + (not (eq (lisp-info-begins-quoted line-info) + (lisp-info-ending-quoted prev-line-info))) + + (not (eql (line-signature test-line) + (lisp-info-signature-slot line-info)))) + + (move-to-position mark 0 test-line) + + (unless line-info + (setf line-info (make-lisp-info)) + (setf (getf (line-plist test-line) 'lisp-info) line-info)) + + (parse-lisp-line-info mark line-info prev-line-info)) + + (when (eq end-line test-line) + (return nil)) + + (setq prev-line-info line-info) + + (setq test-line (line-next test-line))))))) + + + +;;;; Parse block finders. + +(defhvar "Minimum Lines Parsed" + "The minimum number of lines before and after the point parsed by Lisp mode." + :value 50) +(defhvar "Maximum Lines Parsed" + "The maximum number of lines before and after the point parsed by Lisp mode." + :value 500) +(defhvar "Defun Parse Goal" + "Lisp mode parses the region obtained by skipping this many defuns forward + and backward from the point unless this falls outside of the range specified + by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"." + :value 2) + + +(macrolet ((frob (step end) + `(let ((min (value minimum-lines-parsed)) + (max (value maximum-lines-parsed)) + (goal (value defun-parse-goal)) + (last-defun nil)) + (declare (fixnum min max goal)) + (do ((line (mark-line mark) (,step line)) + (count 0 (1+ count))) + ((null line) + (,end mark)) + (declare (fixnum count)) + (when (char= (line-character line 0) #\() + (setq last-defun line) + (decf goal) + (when (and (<= goal 0) (>= count min)) + (line-start mark line) + (return))) + (when (> count max) + (line-start mark (or last-defun line)) + (return)))))) + + (defun start-of-parse-block (mark) + (frob line-previous buffer-start)) + + (defun end-of-parse-block (mark) + (frob line-next buffer-end))) + +;;; +;;; START-OF-SEARCH-LINE + +(defun start-of-search-line (line) + "Set LINE to the begining line of the block of text to parse." + (with-mark ((mark (mark line 0))) + (funcall (value 'Parse-Start-Function) mark) + (setq line (mark-line mark)))) + +;;; +;;; END-OF-SEACH-LINE + +(defun end-of-search-line (line) + "Set LINE to the ending line of the block of text to parse." + (with-mark ((mark (mark line 0))) + (funcall (value 'Parse-End-Function) mark) + (setq line (mark-line mark)))) + + + +;;;; PARSE-LISP-LINE-INFO. + +;;; PARSE-LISP-LINE-INFO -- Internal. +;;; +;;; This parses through the line doing the following things: +;;; +;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS. +;;; +;;; Making all areas of the line that should be invalid (comments, +;;; char-quotes, and the inside of strings) and such be in +;;; RANGES-TO-IGNORE. +;;; +;;; Set BEGINS-QUOTED and ENDING-QUOTED +;;; +(defun parse-lisp-line-info (mark line-info prev-line-info) + "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS, + RANGES-TO-INGORE, and ENDING-QUOTED." + (let ((net-open-parens 0) + (net-close-parens 0)) + (declare (fixnum net-open-parens net-close-parens)) + + ;; Re-set the slots necessary + + (setf (lisp-info-ranges-to-ignore line-info) nil) + + ;; The only way the current line begins quoted is when there + ;; is a previous line and it's ending was quoted. + + (setf (lisp-info-begins-quoted line-info) + (and prev-line-info + (lisp-info-ending-quoted prev-line-info))) + + (if (lisp-info-begins-quoted line-info) + (deal-with-string-quote mark line-info) + (setf (lisp-info-ending-quoted line-info) nil)) + + (unless (lisp-info-ending-quoted line-info) + (loop + (find-lisp-char mark) + (ecase (character-attribute :lisp-syntax (next-character mark)) + + (:open-paren + (setq net-open-parens (1+ net-open-parens)) + (mark-after mark)) + + (:close-paren + (if (zerop net-open-parens) + (setq net-close-parens (1+ net-close-parens)) + (setq net-open-parens (1- net-open-parens))) + (mark-after mark)) + + (:newline + (setf (lisp-info-ending-quoted line-info) nil) + (return t)) + + (:comment + (push-range (cons (mark-charpos mark) (line-length (mark-line mark))) + line-info) + (setf (lisp-info-ending-quoted line-info) nil) + (return t)) + + (:char-quote + (mark-after mark) + (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark))) + line-info) + (mark-after mark)) + + (:string-quote + (mark-after mark) + (unless (deal-with-string-quote mark line-info) + (setf (lisp-info-ending-quoted line-info) t) + (return t)))))) + + (setf (lisp-info-net-open-parens line-info) net-open-parens) + (setf (lisp-info-net-close-parens line-info) net-close-parens) + (setf (lisp-info-signature-slot line-info) + (line-signature (mark-line mark))))) + + + + +;;;; String quote utilities. + +;;; VALID-STRING-QUOTE-P +;;; +(defmacro valid-string-quote-p (mark forwardp) + "Return T if the string-quote indicated by MARK is valid." + (let ((test-mark (gensym))) + `(with-mark ((,test-mark ,mark)) + ,(unless forwardp + ;; TEST-MARK should always be right before the String-quote to be + ;; checked. + `(mark-before ,test-mark)) + (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote) + (let ((slash-count 0)) + (loop + (mark-before ,test-mark) + (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote) + (incf slash-count) + (return t))) + (not (oddp slash-count))))))) + +;;; +;;; FIND-VALID-STRING-QUOTE + +(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil)) + "Expand to a form that will leave MARK before a valid string-quote character, + in either a forward or backward direction, according to FORWARDP. If + CEASE-AT-EOL is T then it will return nil if encountering the EOL before a + valid string-quote." + (let ((e-mark (gensym))) + `(with-mark ((,e-mark ,mark)) + + (loop + (unless (scan-direction ,e-mark ,forwardp :lisp-syntax + ,(if cease-at-eol + `(or :newline :string-quote) + `:string-quote)) + (return nil)) + + ,@(if cease-at-eol + `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax + :newline) + (return nil)))) + + (when (valid-string-quote-p ,e-mark ,forwardp) + (move-mark ,mark ,e-mark) + (return t)) + + (neighbor-mark ,e-mark ,forwardp))))) + + +;;;; DEAL-WITH-STRING-QUOTE. + +;;; DEAL-WITH-STRING-QUOTE +;;; +;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a +;;; matching quote on the line that MARK points to, and puts the appropriate +;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area. +;;; The "appropriate area" is from MARK to the end of the line or the matching +;;; string-quote, whichever comes first. +;;; +(defun deal-with-string-quote (mark info-struct) + "Alter the current line's info struct as necessary as due to encountering a + string quote character." + (with-mark ((e-mark mark)) + (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t) + ;; If matching quote is on this line then mark the area between the + ;; first quote (MARK) and the matching quote as invalid by pushing + ;; its begining and ending into the IGNORE-RANGE. + (push-range (cons (mark-charpos mark) (mark-charpos e-mark)) + info-struct) + (setf (lisp-info-ending-quoted info-struct) nil) + (mark-after e-mark) + (move-mark mark e-mark)) + ;; If the EOL has been hit before the matching quote then mark the + ;; area from MARK to the EOL as invalid. + (t + (push-range (cons (mark-charpos mark) + (1+ (line-length (mark-line mark)))) + info-struct) + ;; The Ending is marked as still being quoted. + (setf (lisp-info-ending-quoted info-struct) t) + (line-end mark) + nil)))) + + + + +;;;; Character validity checking: + +;;; Find-Ignore-Region -- Internal +;;; +;;; If the character in the specified direction from Mark is in an ignore +;;; region, then return the region and the line that the region is in as +;;; values. If there is no ignore region, then return NIL and the Mark-Line. +;;; If the line is not parsed, or there is no character (because of being at +;;; the buffer beginning or end), then return both values NIL. +;;; +(defun find-ignore-region (mark forwardp) + (flet ((scan (line pos) + (declare (fixnum pos)) + (let ((info (getf (line-plist line) 'lisp-info))) + (if info + (dolist (range (lisp-info-ranges-to-ignore info) + (values nil line)) + (let ((start (car range)) + (end (cdr range))) + (declare (fixnum start end)) + (when (and (>= pos start) (< pos end)) + (return (values range line))))) + (values nil nil))))) + (let ((pos (mark-charpos mark)) + (line (mark-line mark))) + (declare (fixnum pos)) + (cond (forwardp (scan line pos)) + ((> pos 0) (scan line (1- pos))) + (t + (let ((prev (line-previous line))) + (if prev + (scan prev (line-length prev)) + (values nil nil)))))))) + + +;;; Valid-Spot -- Public +;;; +(defun valid-spot (mark forwardp) + "Return true if the character pointed to by Mark is not in a quoted context, + false otherwise. If Forwardp is true, we use the next character, otherwise + we use the previous." + (multiple-value-bind (region line) + (find-ignore-region mark forwardp) + (and line (not region)))) + + +;;; Scan-Direction-Valid -- Internal +;;; +;;; Like scan-direction, but only stop on valid characters. +;;; +(defmacro scan-direction-valid (mark forwardp &rest forms) + (let ((n-mark (gensym)) + (n-line (gensym)) + (n-region (gensym)) + (n-won (gensym))) + `(let ((,n-mark ,mark) (,n-won nil)) + (loop + (multiple-value-bind (,n-region ,n-line) + (find-ignore-region ,n-mark ,forwardp) + (unless ,n-line (return nil)) + (if ,n-region + (move-to-position ,n-mark + ,(if forwardp + `(cdr ,n-region) + `(car ,n-region)) + ,n-line) + (when ,n-won (return t))) + ;; + ;; Peculiar condition when a quoting character terminates a line. + ;; The ignore region is off the end of the line causing %FORM-OFFSET + ;; to infinitely loop. + (when (> (mark-charpos ,n-mark) (line-length ,n-line)) + (line-offset ,n-mark 1 0)) + (unless (scan-direction ,n-mark ,forwardp ,@forms) + (return nil)) + (setq ,n-won t)))))) + + + +;;;; List offseting. + +;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built +;;; with the same existing structure, with the altering of one variable. +;;; This one variable being FORWARDP. +;;; +(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) ) + "Expand to code that will go forward one list either backward or forward, + according to the FORWARDP flag." + (let ((mark (gensym))) + `(let ((paren-count ,extra-parens)) + (declare (fixnum paren-count)) + (with-mark ((,mark ,actual-mark)) + (loop + (scan-direction ,mark ,forwardp :lisp-syntax + (or :close-paren :open-paren :newline)) + (let ((ch (direction-char ,mark ,forwardp))) + (unless ch (return nil)) + (when (valid-spot ,mark ,forwardp) + (case (character-attribute :lisp-syntax ch) + (:close-paren + (decf paren-count) + ,(when forwardp + ;; When going forward, an unmatching close-paren means the + ;; end of list. + `(when (<= paren-count 0) + (neighbor-mark ,mark ,forwardp) + (move-mark ,actual-mark ,mark) + (return t)))) + (:open-paren + (incf paren-count) + ,(unless forwardp ; Same as above only end of list + `(when (>= paren-count 0) ; is opening parens. + (neighbor-mark ,mark ,forwardp) + (move-mark ,actual-mark ,mark) + (return t)))) + + (:newline + ;; When a #\Newline is hit, then the matching paren must lie + ;; on some other line so drop down into the multiple line + ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren + ;; seen yet, keep going. + (cond ((zerop paren-count)) + ((quest-for-balancing-paren ,mark paren-count ,forwardp) + (move-mark ,actual-mark ,mark) + (return t)) + (t + (return nil))))))) + + (neighbor-mark ,mark ,forwardp)))))) + +;;; +;;; QUEST-FOR-BALANCING-PAREN + +(defmacro quest-for-balancing-paren (mark paren-count forwardp) + "Expand to a form that finds the the balancing paren for however many opens or + closes are registered by Paren-Count." + `(let* ((line (mark-line ,mark))) + (loop + (setq line (neighbor-line line ,forwardp)) + (unless line (return nil)) + (let ((line-info (getf (line-plist line) 'lisp-info)) + (unbal-paren ,paren-count)) + (unless line-info (return nil)) + + ,(if forwardp + `(decf ,paren-count (lisp-info-net-close-parens line-info)) + `(incf ,paren-count (lisp-info-net-open-parens line-info))) + + (when ,(if forwardp + `(<= ,paren-count 0) + `(>= ,paren-count 0)) + ,(if forwardp + `(line-start ,mark line) + `(line-end ,mark line)) + (return (goto-correct-paren-char ,mark unbal-paren ,forwardp))) + + ,(if forwardp + `(incf ,paren-count (lisp-info-net-open-parens line-info)) + `(decf ,paren-count (lisp-info-net-close-parens line-info))))))) + + +;;; +;;; GOTO-CORRECT-PAREN-CHAR + +(defmacro goto-correct-paren-char (mark paren-count forwardp) + "Expand to a form that will leave MARK on the correct balancing paren matching + however many are indicated by COUNT." + `(with-mark ((m ,mark)) + (let ((count ,paren-count)) + (loop + (scan-direction m ,forwardp :lisp-syntax + (or :close-paren :open-paren :newline)) + (when (valid-spot m ,forwardp) + (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp)) + (:close-paren + (decf count) + ,(when forwardp + `(when (zerop count) + (neighbor-mark m ,forwardp) + (move-mark ,mark m) + (return t)))) + + (:open-paren + (incf count) + ,(unless forwardp + `(when (zerop count) + (neighbor-mark m ,forwardp) + (move-mark ,mark m) + (return t)))))) + (neighbor-mark m ,forwardp))))) + + +(defun list-offset (mark offset) + (if (plusp offset) + (dotimes (i offset t) + (unless (%list-offset mark t) (return nil))) + (dotimes (i (- offset) t) + (unless (%list-offset mark nil) (return nil))))) + +(defun forward-up-list (mark) + "Moves mark just past the closing paren of the immediately containing list." + (%list-offset mark t :extra-parens 1)) + +(defun backward-up-list (mark) + "Moves mark just before the opening paren of the immediately containing list." + (%list-offset mark nil :extra-parens -1)) + + + + +;;;; Top level form location hacks (open parens beginning lines). + +;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro neighbor-top-level (line forwardp) + `(loop + (when (test-char (line-character ,line 0) :lisp-syntax :open-paren) + (return t)) + (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line))) + (unless ,line (return nil)))) +) ;eval-when + +(defun top-level-offset (mark offset) + "Go forward or backward offset number of top level forms. Mark is + returned if offset forms exists, otherwise nil." + (declare (fixnum offset)) + (let* ((line (mark-line mark)) + (at-start (test-char (line-character line 0) :lisp-syntax :open-paren))) + (cond ((zerop offset) mark) + ((plusp offset) + (do ((offset (if at-start offset (1- offset)) + (1- offset))) + (nil) + (declare (fixnum offset)) + (unless (neighbor-top-level line t) (return nil)) + (when (zerop offset) (return (line-start mark line))) + (unless (setf line (line-next line)) (return nil)))) + (t + (do ((offset (if (and at-start (start-line-p mark)) + offset + (1+ offset)) + (1+ offset))) + (nil) + (declare (fixnum offset)) + (unless (neighbor-top-level line nil) (return nil)) + (when (zerop offset) (return (line-start mark line))) + (unless (setf line (line-previous line)) (return nil))))))) + + +(defun mark-top-level-form (mark1 mark2) + "Moves mark1 and mark2 to the beginning and end of the current or next defun. + Mark1 one is used as a reference. The marks may be altered even if + unsuccessful. if successful, return mark2, else nil." + (let ((winp (cond ((inside-defun-p mark1) + (cond ((not (top-level-offset mark1 -1)) nil) + ((not (form-offset (move-mark mark2 mark1) 1)) nil) + (t mark2))) + ((start-defun-p mark1) + (form-offset (move-mark mark2 mark1) 1)) + ((and (top-level-offset (move-mark mark2 mark1) -1) + (start-defun-p mark2) + (form-offset mark2 1) + (same-line-p mark1 mark2)) + (form-offset (move-mark mark1 mark2) -1) + mark2) + ((top-level-offset mark1 1) + (form-offset (move-mark mark2 mark1) 1))))) + (when winp + (when (blank-after-p mark2) (line-offset mark2 1 0)) + mark2))) + +(defun inside-defun-p (mark) + "T if the current point is (supposedly) in a top level form." + (with-mark ((m mark)) + (when (top-level-offset m -1) + (form-offset m 1) + (mark> m mark)))) + +(defun start-defun-p (mark) + "Returns t if mark is sitting before an :open-paren at the beginning of a + line." + (and (start-line-p mark) + (test-char (next-character mark) :lisp-syntax :open-paren))) + + + + +;;;; Form offseting. + +(defmacro %form-offset (mark forwardp) + `(with-mark ((m ,mark)) + (when (scan-direction-valid m ,forwardp :lisp-syntax + (or :open-paren :close-paren + :char-quote :string-quote + :constituent)) + (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp)) + (:open-paren + (when ,(if forwardp `(list-offset m 1) `(mark-before m)) + ,(unless forwardp + '(scan-direction m nil :lisp-syntax (not :prefix))) + (move-mark ,mark m) + t)) + (:close-paren + (when ,(if forwardp `(mark-after m) `(list-offset m -1)) + ,(unless forwardp + '(scan-direction m nil :lisp-syntax (not :prefix))) + (move-mark ,mark m) + t)) + ((:constituent :char-quote) + (scan-direction-valid m ,forwardp :lisp-syntax + (not (or :constituent :char-quote))) + ,(if forwardp + `(scan-direction-valid m t :lisp-syntax + (not (or :constituent :char-quote))) + `(scan-direction-valid m nil :lisp-syntax + (not (or :constituent :char-quote + :prefix)))) + (move-mark ,mark m) + t) + (:string-quote + (cond ((valid-spot m ,(not forwardp)) + (neighbor-mark m ,forwardp) + (when (scan-direction-valid m ,forwardp :lisp-syntax + :string-quote) + (neighbor-mark m ,forwardp) + (move-mark ,mark m) + t)) + (t (neighbor-mark m ,forwardp) + (move-mark ,mark m) + t))))))) + + +(defun form-offset (mark offset) + "Move mark offset number of forms, after if positive, before if negative. + Mark is always moved. If there weren't enough forms, returns nil instead of + mark." + (if (plusp offset) + (dotimes (i offset t) + (unless (%form-offset mark t) (return nil))) + (dotimes (i (- offset) t) + (unless (%form-offset mark nil) (return nil))))) + + + + +;;;; Table of special forms with special indenting requirements. + +(defhvar "Indent Defanything" + "This is the number of special arguments implicitly assumed to be supplied + in calls to functions whose names begin with \"DEF\". If set to NIL, this + feature is disabled." + :value 2) + +(defvar *special-forms* (make-hash-table :test #'equal)) + +(defun defindent (fname args) + "Define Fname to have Args special arguments. If args is null then remove + any special arguments information." + (check-type fname string) + (let ((fname (string-upcase fname))) + (cond ((null args) (remhash fname *special-forms*)) + (t + (check-type args integer) + (setf (gethash fname *special-forms*) args))))) + + +;;; Hemlock forms. +;;; +(defindent "with-mark" 1) +(defindent "with-random-typeout" 1) +(defindent "with-pop-up-display" 1) +(defindent "defhvar" 1) +(defindent "hlet" 1) +(defindent "defcommand" 2) +(defindent "defattribute" 1) +(defindent "command-case" 1) +(defindent "with-input-from-region" 1) +(defindent "with-output-to-mark" 1) +(defindent "with-output-to-window" 1) +(defindent "do-strings" 1) +(defindent "save-for-undo" 1) +(defindent "do-alpha-chars" 1) +(defindent "do-headers-buffers" 1) +(defindent "do-headers-lines" 1) +(defindent "with-headers-mark" 1) +(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill. +(defindent "with-writable-buffer" 1) + +;;; Common Lisp forms. +;;; +(defindent "block" 1) +(defindent "case" 1) +(defindent "catch" 1) +(defindent "ccase" 1) +(defindent "compiler-let" 1) +(defindent "ctypecase" 1) +(defindent "defconstant" 1) +(defindent "define-compiler-macro" 2) +(defindent "define-setf-method" 2) +(defindent "destructuring-bind" 2) +(defindent "defmacro" 2) +(defindent "defpackage" 1) +(defindent "defparameter" 1) +(defindent "defstruct" 1) +(defindent "deftype" 2) +(defindent "defun" 2) +(defindent "defvar" 1) +(defindent "do" 2) +(defindent "do*" 2) +(defindent "do-all-symbols" 1) +(defindent "do-external-symbols" 1) +(defindent "do-symbols" 1) +(defindent "dolist" 1) +(defindent "dotimes" 1) +(defindent "ecase" 1) +(defindent "etypecase" 1) +(defindent "eval-when" 1) +(defindent "flet" 1) +(defindent "if" 1) +(defindent "labels" 1) +(defindent "lambda" 1) +(defindent "let" 1) +(defindent "let*" 1) +(defindent "locally" 0) +(defindent "loop" 0) +(defindent "macrolet" 1) +(defindent "multiple-value-bind" 2) +(defindent "multiple-value-call" 1) +(defindent "multiple-value-prog1" 1) +(defindent "multiple-value-setq" 1) +(defindent "prog1" 1) +(defindent "progv" 2) +(defindent "progn" 0) +(defindent "typecase" 1) +(defindent "unless" 1) +(defindent "unwind-protect" 1) +(defindent "when" 1) +(defindent "with-input-from-string" 1) +(defindent "with-open-file" 1) +(defindent "with-open-stream" 1) +(defindent "with-output-to-string" 1) +(defindent "with-package-iterator" 1) + +;;; Error/condition system forms. +;;; +(defindent "define-condition" 2) +(defindent "handler-bind" 1) +(defindent "handler-case" 1) +(defindent "restart-bind" 1) +(defindent "restart-case" 1) +(defindent "with-simple-restart" 1) +;;; These are for RESTART-CASE branch formatting. +(defindent "store-value" 1) +(defindent "use-value" 1) +(defindent "muffle-warning" 1) +(defindent "abort" 1) +(defindent "continue" 1) + +;;; Debug-internals forms. +;;; +(defindent "do-debug-function-blocks" 1) +(defindent "di:do-debug-function-blocks" 1) +(defindent "do-debug-function-variables" 1) +(defindent "di:do-debug-function-variables" 1) +(defindent "do-debug-block-locations" 1) +(defindent "di:do-debug-block-locations" 1) +;;; +;;; Debug-internals conditions +;;; (define these to make uses of HANDLER-CASE indent branches correctly.) +;;; +(defindent "debug-condition" 1) +(defindent "di:debug-condition" 1) +(defindent "no-debug-info" 1) +(defindent "di:no-debug-info" 1) +(defindent "no-debug-function-returns" 1) +(defindent "di:no-debug-function-returns" 1) +(defindent "no-debug-blocks" 1) +(defindent "di:no-debug-blocks" 1) +(defindent "lambda-list-unavailable" 1) +(defindent "di:lambda-list-unavailable" 1) +(defindent "no-debug-variables" 1) +(defindent "di:no-debug-variables" 1) +(defindent "invalid-value" 1) +(defindent "di:invalid-value" 1) +(defindent "ambiguous-variable-name" 1) +(defindent "di:ambiguous-variable-name" 1) +(defindent "debug-error" 1) +(defindent "di:debug-error" 1) +(defindent "unhandled-condition" 1) +(defindent "di:unhandled-condition" 1) +(defindent "unknown-code-location" 1) +(defindent "di:unknown-code-location" 1) +(defindent "unknown-debug-variable" 1) +(defindent "di:unknown-debug-variable" 1) +(defindent "invalid-control-stack-pointer" 1) +(defindent "di:invalid-control-stack-pointer" 1) +(defindent "frame-function-mismatch" 1) +(defindent "di:frame-function-mismatch" 1) + + +;;; CLOS forms. +;;; +(defindent "with-slots" 1) +(defindent "with-accessors" 2) +(defindent "defclass" 2) +(defindent "print-unreadable-object" 1) +(defindent "defmethod" 2) +(defindent "make-instance" 1) + +;;; System forms. +;;; +(defindent "rlet" 1) + +;;; Multiprocessing forms. +(defindent "with-lock-grabbed" 1) +(defindent "process-wait" 1) + + + + +;;;; Indentation. + +;;; LISP-INDENTATION -- Internal Interface. + +(defun strip-package-prefix (string) + (let* ((p (position #\: string :from-end t))) + (if p + (subseq string (1+ p)) + string))) +;;; +(defun lisp-indentation (mark) + "Compute number of spaces which mark should be indented according to + local context and lisp grinding conventions. This assumes mark is at the + beginning of the line to be indented." + (with-mark ((m mark) + (temp mark)) + ;; See if we are in a quoted context. + (unless (valid-spot m nil) + (return-from lisp-indentation (lisp-generic-indentation m))) + ;; Look for the paren that opens the containing form. + (unless (backward-up-list m) + (return-from lisp-indentation 0)) + ;; Move after the paren, save the start, and find the form name. + (mark-after m) + (with-mark ((start m)) + (unless (and (scan-char m :lisp-syntax + (not (or :space :prefix :char-quote))) + (test-char (next-character m) :lisp-syntax :constituent)) + (return-from lisp-indentation (mark-column start))) + (with-mark ((fstart m)) + (scan-char m :lisp-syntax (not :constituent)) + (let* ((fname (nstring-upcase + (strip-package-prefix (region-to-string (region fstart m))))) + (special-args (or (gethash fname *special-forms*) + (and (> (length fname) 2) + (string= fname "DEF" :end1 3) + (value indent-defanything))))) + (declare (simple-string fname)) + ;; Now that we have the form name, did it have special syntax? + (cond (special-args + (with-mark ((spec m)) + (cond ((and (form-offset spec special-args) + (mark<= spec mark)) + (1+ (mark-column start))) + ((skip-valid-space m) + (mark-column m)) + (t + (+ (mark-column start) 3))))) + ;; See if the user seems to have altered the editor's + ;; indentation, and if so, try to adhere to it. This usually + ;; happens when you type in a quoted list constant that line + ;; wraps. You want all the items on successive lines to fall + ;; under the first character after the opening paren, not as if + ;; you are calling a function. + ((and (form-offset temp -1) + (or (blank-before-p temp) (not (same-line-p temp fstart))) + (not (same-line-p temp mark))) + (unless (blank-before-p temp) + (line-start temp) + (find-attribute temp :space #'zerop)) + (mark-column temp)) + ;; Appears to be a normal form. Is the first arg on the same + ;; line as the form name? + ((skip-valid-space m) + (or (lisp-indentation-check-for-local-def + mark temp fstart start t) + (mark-column m))) + ;; Okay, fall under the first character after the opening paren. + (t + (or (lisp-indentation-check-for-local-def + mark temp fstart start nil) + (mark-column start))))))))) + +(defhvar "Lisp Indentation Local Definers" + "Forms with syntax like LABELS, MACROLET, etc." + :value '("LABELS" "MACROLET" "FLET")) + +;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal. +;;; +;;; This is a temporary hack to see how it performs. When we are indenting +;;; what appears to be a function call, let's look for FLET or MACROLET to see +;;; if we really are indenting a local definition. If we are, return the +;;; indentation for a DEFUN; otherwise, nil +;;; +;;; Mark is the argument to LISP-INDENTATION. Start is just inside the paren +;;; of what looks like a function call. If we are in an FLET, arg-list +;;; indicates whether the local function's arg-list has been entered, that is, +;;; whether we need to normally indent for a DEFUN body or indent specially for +;;; the arg-list. +;;; +(defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list) + ;; We know this succeeds from LISP-INDENTATION. + (backward-up-list (move-mark temp1 mark)) ;Paren for local definition. + (cond ((and (backward-up-list temp1) ;Paren opening the list of defs + (form-offset (move-mark temp2 temp1) -1) + (mark-before temp2) + (backward-up-list temp1) ;Paren for FLET or MACROLET. + (mark= temp1 temp2)) ;Must be in first arg form. + ;; See if the containing form is named FLET or MACROLET. + (mark-after temp1) + (unless (and (scan-char temp1 :lisp-syntax + (not (or :space :prefix :char-quote))) + (test-char (next-character temp1) :lisp-syntax + :constituent)) + (return-from lisp-indentation-check-for-local-def nil)) + (move-mark temp2 temp1) + (scan-char temp2 :lisp-syntax (not :constituent)) + (let ((fname (nstring-upcase (region-to-string (region temp1 temp2))))) + (cond ((not (member fname (value lisp-indentation-local-definers) + :test #'string=)) + nil) + (arg-list + (1+ (mark-column start))) + (t + (+ (mark-column start) 3))))))) + +;;; LISP-GENERIC-INDENTATION -- Internal. +;;; +;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted +;;; context. If we are inside a string, we return the column one greater +;;; than the opening double quote. Otherwise, we just use the indentation +;;; of the first preceding non-blank line. +;;; +(defun lisp-generic-indentation (mark) + (with-mark ((m mark)) + (form-offset m -1) + (cond ((eq (character-attribute :lisp-syntax (next-character m)) + :string-quote) + (1+ (mark-column m))) + (t + (let* ((line (mark-line mark)) + (prev (do ((line (line-previous line) (line-previous line))) + ((not (and line (blank-line-p line))) line)))) + (cond (prev + (line-start mark prev) + (find-attribute mark :space #'zerop) + (mark-column mark)) + (t 0))))))) + +;;; Skip-Valid-Space -- Internal +;;; +;;; Skip over any space on the line Mark is on, stopping at the first valid +;;; non-space character. If there is none on the line, return nil. +;;; +(defun skip-valid-space (mark) + (loop + (scan-char mark :lisp-syntax (not :space)) + (let ((val (character-attribute :lisp-syntax + (next-character mark)))) + (cond ((eq val :newline) (return nil)) + ((valid-spot mark t) (return mark)))) + (mark-after mark))) + +;; (declaim (optimize (speed 0))); byte compile again + + + +;;;; Indentation commands and hook functions. + +(defcommand "Defindent" (p) + "Define the Lisp indentation for the current function. + The indentation is a non-negative integer which is the number + of special arguments for the form. Examples: 2 for Do, 1 for Dolist. + If a prefix argument is supplied, then delete the indentation information." + "Do a defindent, man!" + (with-mark ((m (current-point))) + (pre-command-parse-check m) + (unless (backward-up-list m) (editor-error)) + (mark-after m) + (with-mark ((n m)) + (scan-char n :lisp-syntax (not :constituent)) + (let ((s (region-to-string (region m n)))) + (declare (simple-string s)) + (when (zerop (length s)) (editor-error)) + (if p + (defindent s nil) + (let ((i (prompt-for-integer + :prompt (format nil "Indentation for ~A: " s) + :help "Number of special arguments."))) + (when (minusp i) + (editor-error "Indentation must be non-negative.")) + (defindent s i)))))) + (indent-command nil)) + +(defcommand "Indent Form" (p) + "Indent Lisp code in the next form." + "Indent Lisp code in the next form." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((m point)) + (unless (form-offset m 1) (editor-error)) + (lisp-indent-region (region point m) "Indent Form")))) + +;;; LISP-INDENT-REGION -- Internal. +;;; +;;; This indents a region of Lisp code without doing excessive redundant +;;; computation. We parse the entire region once, then scan through doing +;;; indentation on each line. We forcibly reparse each line that we indent so +;;; that the list operations done to determine indentation of subsequent lines +;;; will work. This is done undoably with save1, save2, buf-region, and +;;; undo-region. +;;; +(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting")) (let* ((start (region-start region)) + (end (region-end region)) + (buffer (hi::line-%buffer (mark-line start)))) + (with-mark ((m1 start) + (m2 end)) + (funcall (value parse-start-function) m1) + (funcall (value parse-end-function) m2) + (parse-over-block (mark-line m1) (mark-line m2))) + (hi::check-buffer-modification buffer start) + (hi::check-buffer-modification buffer end) + (let* ((first-line (mark-line start)) + (last-line (mark-line end)) + (prev (line-previous first-line)) + (prev-line-info + (and prev (getf (line-plist prev) 'lisp-info))) + (save1 (line-start (copy-mark start :right-inserting))) + (save2 (line-end (copy-mark end :left-inserting))) + (buf-region (region save1 save2)) + (undo-region (copy-region buf-region))) + (with-mark ((bol start :left-inserting)) + (do ((line first-line (line-next line))) + (nil) + (line-start bol line) + (ensure-lisp-indentation bol) + (let ((line-info (getf (line-plist line) 'lisp-info))) + (parse-lisp-line-info bol line-info prev-line-info) + (setq prev-line-info line-info)) + (when (eq line last-line) (return nil)))) + (make-region-undo :twiddle undo-text buf-region undo-region)))) + +;;; INDENT-FOR-LISP -- Internal. +;;; +;;; This is the value of "Indent Function" for "Lisp" mode. +;;; +(defun indent-for-lisp (mark) + (line-start mark) + (pre-command-parse-check mark) + (ensure-lisp-indentation mark)) + +(defun count-leading-whitespace (mark) + (with-mark ((m mark)) + (line-start m) + (do* ((p 0) + (q 0 (1+ q)) + (tab-width (value spaces-per-tab))) + () + (case (next-character m) + (#\space (incf p)) + (#\tab (setq p (* tab-width (ceiling (1+ p) tab-width)))) + (t (return (values p q)))) + (character-offset m 1)))) + +;;; Don't do anything if M's line is already correctly indented. +(defun ensure-lisp-indentation (m) + (let* ((col (lisp-indentation m))) + (multiple-value-bind (curcol curpos) (count-leading-whitespace m) + (cond ((= curcol col) (setf (mark-charpos m) curpos)) + (t + (delete-horizontal-space m) + (funcall (value indent-with-tabs) m col)))))) + + + + + +;;;; Most "Lisp" mode commands. + +(defcommand "Beginning of Defun" (p) + "Move the point to the beginning of a top-level form, collapsing the selection. + with an argument, skips the previous p top-level forms." + "Move the point to the beginning of a top-level form, collapsing the selection." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (end-of-defun-command (- count)) + (unless (top-level-offset point (- count)) + (editor-error))))) + +(defcommand "Select to Beginning of Defun" (p) + "Move the point to the beginning of a top-level form, extending the selection. + with an argument, skips the previous p top-level forms." + "Move the point to the beginning of a top-level form, extending the selection." + (let ((point (current-point-extending-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (end-of-defun-command (- count)) + (unless (top-level-offset point (- count)) + (editor-error))))) + +;;; "End of Defun", with a positive p (the normal case), does something weird. +;;; Get a mark at the beginning of the defun, and then offset it forward one +;;; less top level form than we want. This sets us up to use FORM-OFFSET which +;;; allows us to leave the point immediately after the defun. If we used +;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current +;;; defun, point would be left at the beginning of the p+1'st form instead of +;;; at the end of the p'th form. +;;; +(defcommand "End of Defun" (p) + "Move the point to the end of a top-level form, collapsing the selection. + With an argument, skips the next p top-level forms." + "Move the point to the end of a top-level form, collapsing the selection." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (beginning-of-defun-command (- count)) + (with-mark ((m point) + (dummy point)) + (cond ((not (mark-top-level-form m dummy)) + (editor-error "No current or next top level form.")) + (t + (unless (top-level-offset m (1- count)) + (editor-error "Not enough top level forms.")) + ;; We might be one unparsed for away. + (pre-command-parse-check m) + (unless (form-offset m 1) + (editor-error "Not enough top level forms.")) + (when (blank-after-p m) (line-offset m 1 0)) + (move-mark point m))))))) + +(defcommand "Select to End of Defun" (p) + "Move the point to the end of a top-level form, extending the selection. + With an argument, skips the next p top-level forms." + "Move the point to the end of a top-level form, extending the selection." + (let ((point (current-point-extending-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (beginning-of-defun-command (- count)) + (with-mark ((m point) + (dummy point)) + (cond ((not (mark-top-level-form m dummy)) + (editor-error "No current or next top level form.")) + (t + (unless (top-level-offset m (1- count)) + (editor-error "Not enough top level forms.")) + ;; We might be one unparsed for away. + (pre-command-parse-check m) + (unless (form-offset m 1) + (editor-error "Not enough top level forms.")) + (when (blank-after-p m) (line-offset m 1 0)) + (move-mark point m))))))) + +(defcommand "Forward List" (p) + "Skip over the next Lisp list, collapsing the selection. + With argument, skips the next p lists." + "Skip over the next Lisp list, collapsing the selection." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (unless (list-offset point count) (editor-error)))) + +(defcommand "Select Forward List" (p) + "Skip over the next Lisp list, extending the selection. + With argument, skips the next p lists." + "Skip over the next Lisp list, extending the selection." + (let ((point (current-point-extending-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (unless (list-offset point count) (editor-error)))) + +(defcommand "Backward List" (p) + "Skip over the previous Lisp list, collapsing the selection. + With argument, skips the previous p lists." + "Skip over the previous Lisp list, collapsing the selection." + (let ((point (current-point-collapsing-selection)) + (count (- (or p 1)))) + (pre-command-parse-check point) + (unless (list-offset point count) (editor-error)))) + +(defcommand "Select Backward List" (p) + "Skip over the previous Lisp list, extending the selection. + With argument, skips the previous p lists." + "Skip over the previous Lisp list, extending the selection." + (let ((point (current-point-extending-selection)) + (count (- (or p 1)))) + (pre-command-parse-check point) + (unless (list-offset point count) (editor-error)))) + +(defcommand "Forward Form" (p) + "Skip over the next Form, collapsing the selection. + With argument, skips the next p Forms." + "Skip over the next Form, collapsing the selection." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (unless (form-offset point count) (editor-error)))) + +(defcommand "Select Forward Form" (p) + "Skip over the next Form, extending the selection. + With argument, skips the next p Forms." + "Skip over the next Form, extending the selection." + (let ((point (current-point-extending-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (unless (form-offset point count) (editor-error)))) + +(defcommand "Backward Form" (p) + "Skip over the previous Form, collapsing the selection. + With argument, skips the previous p Forms." + "Skip over the previous Form, collaspsing the selection." + (let ((point (current-point-collapsing-selection)) + (count (- (or p 1)))) + (pre-command-parse-check point) + (unless (form-offset point count) (editor-error)))) + +(defcommand "Select Backward Form" (p) + "Skip over the previous Form, extending the selection. + With argument, skips the previous p Forms." + "Skip over the previous Form, extending the selection." + (let ((point (current-point-extending-selection)) + (count (- (or p 1)))) + (pre-command-parse-check point) + (unless (form-offset point count) (editor-error)))) + +(defcommand "Mark Form" (p) + "Set the mark at the end of the next Form. + With a positive argument, set the mark after the following p + Forms. With a negative argument, set the mark before + the preceding -p Forms." + "Set the mark at the end of the next Form." + (with-mark ((m (current-point))) + (pre-command-parse-check m) + (let ((count (or p 1)) + (mark (push-buffer-mark (copy-mark m) t))) + (if (form-offset m count) + (move-mark mark m) + (editor-error))))) + +(defcommand "Mark Defun" (p) + "Puts the region around the next or containing top-level form. + The point is left before the form and the mark is placed immediately + after it." + "Puts the region around the next or containing top-level form." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((start point) + (end point)) + (cond ((not (mark-top-level-form start end)) + (editor-error "No current or next top level form.")) + (t + (move-mark point start) + (move-mark (push-buffer-mark (copy-mark point) t) end)))))) + +(defcommand "Forward Kill Form" (p) + "Kill the next Form. + With a positive argument, kills the next p Forms. + Kills backward with a negative argument." + "Kill the next Form." + (with-mark ((m1 (current-point)) + (m2 (current-point))) + (pre-command-parse-check m1) + (let ((count (or p 1))) + (unless (form-offset m1 count) (editor-error)) + (if (minusp count) + (kill-region (region m1 m2) :kill-backward) + (kill-region (region m2 m1) :kill-forward))))) + +(defcommand "Backward Kill Form" (p) + "Kill the previous Form. + With a positive argument, kills the previous p Forms. + Kills forward with a negative argument." + "Kill the previous Form." + (forward-kill-form-command (- (or p 1)))) + +(defcommand "Extract Form" (p) + "Replace the current containing list with the next form. The entire affected + area is pushed onto the kill ring. If an argument is supplied, that many + upward levels of list nesting is replaced by the next form." + "Replace the current containing list with the next form. The entire affected + area is pushed onto the kill ring. If an argument is supplied, that many + upward levels of list nesting is replaced by the next form." + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((form-start point :right-inserting) + (form-end point)) + (unless (form-offset form-end 1) (editor-error)) + (form-offset (move-mark form-start form-end) -1) + (with-mark ((containing-start form-start :left-inserting) + (containing-end form-end :left-inserting)) + (dotimes (i (or p 1)) + (unless (and (forward-up-list containing-end) + (backward-up-list containing-start)) + (editor-error))) + (let ((r (copy-region (region form-start form-end)))) + (ring-push (delete-and-save-region + (region containing-start containing-end)) + *kill-ring*) + (ninsert-region point r) + (move-mark point form-start)))))) + +(defcommand "Extract List" (p) + "Extract the current list. + The current list replaces the surrounding list. The entire affected + area is pushed on the kill-ring. With prefix argument, remove that + many surrounding lists." + "Replace the P containing lists with the current one." + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((lstart point :right-inserting) + (lend point)) + (if (eq (character-attribute :lisp-syntax (next-character lstart)) + :open-paren) + (mark-after lend) + (unless (backward-up-list lstart) (editor-error))) + (unless (forward-up-list lend) (editor-error)) + (with-mark ((rstart lstart) + (rend lend)) + (dotimes (i (or p 1)) + (unless (and (forward-up-list rend) (backward-up-list rstart)) + (editor-error))) + (let ((r (copy-region (region lstart lend)))) + (ring-push (delete-and-save-region (region rstart rend)) + *kill-ring*) + (ninsert-region point r) + (move-mark point lstart)))))) + +(defcommand "Transpose Forms" (p) + "Transpose Forms immediately preceding and following the point. + With a zero argument, tranposes the Forms at the point and the mark. + With a positive argument, transposes the Form preceding the point + with the p-th one following it. With a negative argument, transposes the + Form following the point with the p-th one preceding it." + "Transpose Forms immediately preceding and following the point." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (if (zerop count) + (let ((mark (current-mark))) + (with-mark ((s1 mark :left-inserting) + (s2 point :left-inserting)) + (scan-char s1 :whitespace nil) + (scan-char s2 :whitespace nil) + (with-mark ((e1 s1 :right-inserting) + (e2 s2 :right-inserting)) + (unless (form-offset e1 1) (editor-error)) + (unless (form-offset e2 1) (editor-error)) + (ninsert-region s1 (delete-and-save-region (region s2 e2))) + (ninsert-region s2 (delete-and-save-region (region s1 e1)))))) + (let ((fcount (if (plusp count) count 1)) + (bcount (if (plusp count) 1 count))) + (with-mark ((s1 point :left-inserting) + (e2 point :right-inserting)) + (dotimes (i bcount) + (unless (form-offset s1 -1) (editor-error))) + (dotimes (i fcount) + (unless (form-offset e2 1) (editor-error))) + (with-mark ((e1 s1 :right-inserting) + (s2 e2 :left-inserting)) + (unless (form-offset e1 1) (editor-error)) + (unless (form-offset s2 -1) (editor-error)) + (ninsert-region s1 (delete-and-save-region (region s2 e2))) + (ninsert-region s2 (delete-and-save-region (region s1 e1))) + (move-mark point s2))))))) + + +(defcommand "Insert ()" (count) + "Insert a pair of parentheses (). With positive argument, puts + parentheses around the next COUNT Forms, or previous COUNT forms, if + COUNT is negative. The point is positioned after the open parenthesis." + "Insert a pair of parentheses ()." + ;; TODO Form navigation is broken, so this is broken too -- it is + ;; possible to put parens around more forms than there are in current + ;; expression. It works by moving past as many forms as there is, and + ;; then each delimiting paren also counts as a form. + (let ((point (current-point))) + (pre-command-parse-check point) + (cond (count + (when (minusp count) + (form-offset point count) + (setq count (- count))) + (insert-character point #\() + (with-mark ((m point)) + (unless (form-offset m count) + (editor-error "Could not find that many forms.")) + (insert-character m #\)))) + ;; The simple case with no prefix argument + (t + (insert-character point #\() + (insert-character point #\)) + (mark-before point))))) + + +(defcommand "Move Over )" (p) + "Move past the next close parenthesis, and start a new line. Any + indentation preceding the preceding the parenthesis is deleted, and the + new line is indented. If there is only whitespace preceding the close + paren, the paren is moved to the end of the previous line. With prefix + argument, this command moves past next closing paren and inserts space." + "Move past the next close parenthesis, and start a new line." + ;; TODO This is still not complete, because SCAN-CHAR finds the next + ;; close-paren, but we need to find the next paren that closes current + ;; expression. This will have to be updated when form navigation is + ;; fixed. + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((m point :right-inserting)) + (cond ((scan-char m :lisp-syntax :close-paren) + (cond ((same-line-p point m) + (delete-horizontal-space m)) + (t + (move-mark point m) + (reverse-find-attribute point :whitespace #'zerop) + (delete-region (region point m)))) + (cond ((not p) + ;; Move to the previous line if current is empty + (when (zerop (mark-charpos m)) + (delete-characters m -1)) + (mark-after m) + (move-mark point m) + (indent-new-line-command 1)) + (t + (mark-after m) + (move-mark point m) + (insert-character m #\space)))) + (t + (editor-error "Could not find closing paren.")))))) + + +(defcommand "Forward Up List" (p) + "Move forward past a one containing )." + "Move forward past a one containing )." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (backward-up-list-command (- count)) + (with-mark ((m point)) + (dotimes (i count (move-mark point m)) + (unless (forward-up-list m) (editor-error))))))) + + +(defcommand "Backward Up List" (p) + "Move backward past a one containing (." + "Move backward past a one containing (." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (forward-up-list-command (- count)) + (with-mark ((m point)) + (dotimes (i count (move-mark point m)) + (unless (backward-up-list m) (editor-error))))))) + + +(defcommand "Down List" (p) + "Move down a level in list structure. With positive argument, moves down + p levels. With negative argument, moves down backward, but only one + level." + "Move down a level in list structure." + (let ((point (current-point-collapsing-selection)) + (count (or p 1))) + (pre-command-parse-check point) + (with-mark ((m point)) + (cond ((plusp count) + (loop repeat count + do (unless (and (scan-char m :lisp-syntax :open-paren) + (mark-after m)) + (editor-error)))) + (t + (unless (and (rev-scan-char m :lisp-syntax :close-paren) + (mark-before m)) + (editor-error)))) + (move-mark point m)))) + + + + +;;;; Filling Lisp comments, strings, and indented text. + +(defhvar "Fill Lisp Comment Paragraph Confirm" + "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for + confirmation to fill contiguous lines with the same initial whitespace when + it is invoked outside of a comment or string." + :value t) + +(defcommand "Fill Lisp Comment Paragraph" (p) + "This fills a flushleft or indented Lisp comment. + This also fills Lisp string literals using the proper indentation as a + filling prefix. When invoked outside of a comment or string, this tries + to fill all contiguous lines beginning with the same initial, non-empty + blankspace. When filling a comment, the current line is used to determine a + fill prefix by taking all the initial whitespace on the line, the semicolons, + and any whitespace following the semicolons." + "Fills a flushleft or indented Lisp comment." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((start point) + (end point) + (m point)) + (let ((commentp (fill-lisp-comment-paragraph-prefix start end))) + (cond (commentp + (fill-lisp-comment-or-indented-text start end)) + ((and (not (valid-spot m nil)) + (form-offset m -1) + (eq (character-attribute :lisp-syntax (next-character m)) + :string-quote)) + (fill-lisp-string m)) + ((or (not (value fill-lisp-comment-paragraph-confirm)) + (prompt-for-y-or-n + :prompt '("Not in a comment or string. Fill contiguous ~ + lines with the same initial whitespace? "))) + (fill-lisp-comment-or-indented-text start end))))))) + +;;; FILL-LISP-STRING -- Internal. +;;; +;;; This fills the Lisp string containing mark as if it had been entered using +;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode. This +;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed, +;;; and it ensures the string ends before doing any filling. This function +;;; is undo'able. +;;; +(defun fill-lisp-string (mark) + (with-mark ((end mark)) + (unless (form-offset end 1) + (editor-error "Attempted to fill Lisp string, but it doesn't end?")) + (let* ((mark (copy-mark mark :left-inserting)) + (end (copy-mark end :left-inserting)) + (string-region (region mark end)) + (undo-region (copy-region string-region)) + (hack (make-empty-region))) + ;; Generate prefix. + (funcall (value indent-with-tabs) + (region-end hack) (1+ (mark-column mark))) + ;; Skip opening double quote and fill string starting on its own line. + (mark-after mark) + (insert-character mark #\newline) + (line-start mark) + (setf (mark-kind mark) :right-inserting) + (fill-region string-region (region-to-string hack)) + ;; Clean up inserted prefix on first line, delete inserted newline, and + ;; move before the double quote for undo. + (with-mark ((text mark :left-inserting)) + (find-attribute text :whitespace #'zerop) + (delete-region (region mark text))) + (delete-characters mark -1) + (mark-before mark) + ;; Save undo. + (make-region-undo :twiddle "Fill Lisp Comment Paragraph" + string-region undo-region)))) + +;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal. +;;; +;;; This fills all contiguous lines around start and end containing fill prefix +;;; designated by the region between start and end. These marks can only be +;;; equal when there is no comment and no initial whitespace. This is a bad +;;; situation since this function in that situation would fill the entire +;;; buffer into one paragraph. This function is undo'able. +;;; +(defun fill-lisp-comment-or-indented-text (start end) + (when (mark= start end) + (editor-error "This command only fills Lisp comments, strings, or ~ + indented text, but this line is flushleft.")) + ;; + ;; Find comment block. + (let* ((prefix (region-to-string (region start end))) + (length (length prefix))) + (declare (simple-string prefix)) + (flet ((frob (mark direction) + (loop + (let* ((line (line-string (mark-line mark))) + (line-len (length line))) + (declare (simple-string line)) + (unless (string= line prefix :end1 (min line-len length)) + (when (= direction -1) + (unless (same-line-p mark end) (line-offset mark 1 0))) + (return))) + (unless (line-offset mark direction 0) + (when (= direction 1) (line-end mark)) + (return))))) + (frob start -1) + (frob end 1)) + ;; + ;; Do it undoable. + (let* ((start1 (copy-mark start :right-inserting)) + (end2 (copy-mark end :left-inserting)) + (region (region start1 end2)) + (undo-region (copy-region region))) + (fill-region region prefix) + (make-region-undo :twiddle "Fill Lisp Comment Paragraph" + region undo-region)))) + +;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal. +;;; +;;; This sets start and end around the prefix to be used for filling. We +;;; assume we are dealing with a comment. If there is no ";", then we try to +;;; find some initial whitespace. If there is a ";", we make sure the line is +;;; blank before it to eliminate ";"'s in the middle of a line of text. +;;; Finally, if we really have a comment instead of some indented text, we skip +;;; the ";"'s and any immediately following whitespace. We allow initial +;;; whitespace, so we can fill strings with the same command. +;;; +(defun fill-lisp-comment-paragraph-prefix (start end) + (line-start start) + (let ((commentp t)) ; Assumes there's a comment. + (unless (to-line-comment (line-start end) ";") + (find-attribute end :whitespace #'zerop) + #|(when (start-line-p end) + (editor-error "No comment on line, and no initial whitespace."))|# + (setf commentp nil)) + (when commentp + (unless (blank-before-p end) + (find-attribute (line-start end) :whitespace #'zerop) + #|(when (start-line-p end) + (editor-error "Semicolon preceded by unindented text."))|# + (setf commentp nil))) + (when commentp + (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment)))) + (find-attribute end :whitespace #'zerop)) + commentp)) + + + + +;;;; "Lisp" mode. + +(defcommand "LISP Mode" (p) + "Put current buffer in LISP mode." + "Put current buffer in LISP mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "LISP")) + + +(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode) + + +(defun buffer-first-in-package-form (buffer) + "Returns the package name referenced in the first apparent IN-PACKAGE + form in buffer, or NIL if it can't find an IN-PACKAGE." + (let* ((pattern (new-search-pattern :string-insensitive :forward "in-package" nil)) + (mark (copy-mark (buffer-start-mark buffer)))) + (with-mark ((start mark) + (end mark)) + (loop + (unless (find-pattern mark pattern) + (return)) + (pre-command-parse-check mark) + (when (valid-spot mark t) + (move-mark end mark) + (when (form-offset end 1) + (move-mark start end) + (when (backward-up-list start) + (when (scan-char start :lisp-syntax :constituent) + (let* ((s (nstring-upcase (region-to-string (region start end)))) + (*package* (find-package "CL-USER"))) + (unless (eq (ignore-errors (values (read-from-string s))) + 'in-package) + (return))) + (unless (form-offset end 1) (return)) + (move-mark start end) + (form-offset start -1) + (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end))))))) + (return + (if pkgname + (values (ignore-errors (string pkgname)))))))))))))) + +(defparameter *previous-in-package-search-pattern* + (new-search-pattern :string-insensitive :backward "in-package" nil)) + +(defun package-at-mark (start-mark) + (let* ((pattern *previous-in-package-search-pattern*) + (mark (copy-mark start-mark :temporary))) + (with-mark ((start mark) + (end mark) + (list-end mark)) + (loop + (unless (find-pattern mark pattern) + (return)) + (pre-command-parse-check mark) + (when (valid-spot mark t) + (move-mark end mark) + (when (form-offset end 1) + (move-mark start end) + (when (backward-up-list start) + (move-mark list-end start) + (unless (and (list-offset list-end 1) + (mark<= list-end start-mark)) + (return)) + (when (scan-char start :lisp-syntax :constituent) + (unless (or (mark= mark start) + (let* ((s (nstring-upcase (region-to-string (region start end)))) + (*package* (find-package "CL-USER"))) + (eq (ignore-errors (values (read-from-string s))) + 'in-package))) + (return)) + (unless (form-offset end 1) (format t "~& worse") (return 4)) + (move-mark start end) + (form-offset start -1) + (return + (if (eql (next-character start) #\") + (progn + (character-offset start 1) + (character-offset end -1) + (region-to-string (region start end))) + (let* ((pkgname (ignore-errors (values (read-from-string (region-to-string (region start end))))))) + (if pkgname + (values (ignore-errors (string pkgname))))))))))))))) + +(defun ensure-buffer-package (buffer) + (or (variable-value 'current-package :buffer buffer) + (setf (variable-value 'current-package :buffer buffer) + (buffer-first-in-package-form buffer)))) + +(defun buffer-package (buffer) + (when (hemlock-bound-p 'current-package :buffer buffer) + (let ((package-name (variable-value 'current-package :buffer buffer))) + (find-package package-name)))) + +(defun setup-lisp-mode (buffer) + (unless (hemlock-bound-p 'current-package :buffer buffer) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value "CL-USER" + :hooks (list 'package-name-change-hook)))) + + + + + + +;;;; Some mode variables to coordinate with other stuff. + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\"." + :mode "Lisp" :value t) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :mode "Lisp" :value ";") + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :mode "Lisp" :value "; ") + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It must take one argument that is the prefix argument." + :value 'indent-for-lisp + :mode "Lisp") + +(defun string-to-arglist (string buffer &optional quiet-if-unknown) + (multiple-value-bind (name error) + (let* ((*package* (or + (find-package + (variable-value 'current-package :buffer buffer)) + *package*))) + (ignore-errors (values (read-from-string string)))) + (unless error + (when (typep name 'symbol) + (multiple-value-bind (arglist win) + (ccl::arglist-string name) + (if (or win (not quiet-if-unknown)) + (format nil "~S : ~A" name (if win (or arglist "()") "(unknown)")))))))) + +(defcommand "Current Function Arglist" (p) + "Show arglist of function whose name precedes point." + "Show arglist of function whose name precedes point." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((mark1 point) + (mark2 point)) + (when (backward-up-list mark1) + (when (form-offset (move-mark mark2 (mark-after mark1)) 1) + (let* ((fun-name (region-to-string (region mark1 mark2))) + (arglist-string (string-to-arglist fun-name (current-buffer)))) + (when arglist-string + (message arglist-string)))))))) + +(defcommand "Arglist On Space" (p) + "Insert a space, then show the current function's arglist." + "Insert a space, then show the current function's arglist." + (declare (ignore p)) + (let ((point (current-point))) + (insert-character point #\Space) + (pre-command-parse-check point) + (with-mark ((mark1 point) + (mark2 point)) + (when (backward-up-list mark1) + (when (form-offset (move-mark mark2 (mark-after mark1)) 1) + (with-mark ((mark3 mark2)) + (do* () + ((mark= mark3 point) + (let* ((fun-name (region-to-string (region mark1 mark2))) + (arglist-string + (string-to-arglist fun-name (current-buffer) t))) + (when arglist-string + (message arglist-string)))) + (if (ccl::whitespacep (next-character mark3)) + (mark-after mark3) + (return nil))))))))) + +(hi:defcommand "Show Callers" (p) + "Display a scrolling list of the callers of the symbol at point. + Double-click a row to go to the caller's definition." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-input-from-region (s (region mark1 mark2)) + (let* ((symbol (read s))) + (make-instance 'ccl::sequence-window-controller + :sequence (ccl::callers symbol) + :title (format nil "Callers of ~a" symbol) + :result-callback #'(lambda (item) + (get-def-info-and-go-to-it (symbol-name item) + (symbol-package item)))))))) + +#|| +(defcommand "Set Package Name" (p) + (variable-value 'current-package :buffer buffer) +||# Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/listener.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/listener.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/listener.lisp (revision 8058) @@ -0,0 +1,763 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +;;; +;;; ********************************************************************** +;;; +;;; Listener mode, dervived (sort of) from Hemlock's "Eval" mode. +;;; + +(in-package :hemlock) + + +(defmacro in-lisp (&body body) + "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package + named by \"Current Package\" if it is non-nil." + (let ((name (gensym)) (package (gensym))) + `(handle-lisp-errors + (let* ((,name (variable-value 'current-package :buffer (current-buffer))) + (,package (and ,name (find-package ,name)))) + (progv (if ,package '(*package*)) (if ,package (list ,package)) + ,@body))))) + + +(defun package-name-change-hook (name kind where new-value) + (declare (ignore name new-value)) + (if (eq kind :buffer) + (hi::queue-buffer-change where))) + +(define-file-option "Package" (buffer value) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value + (let* ((eof (list nil)) + (thing (read-from-string value nil eof))) + (when (eq thing eof) (error "Bad package file option value.")) + (cond + ((stringp thing) + thing) + ((symbolp thing) + (symbol-name thing)) + ((characterp thing) + (string thing)) + (t + (message + "Ignoring \"package\" file option -- cannot convert to a string.")))) + :hooks (list 'package-name-change-hook))) + + + +;;;; Listener Mode Interaction. + + + +(defun setup-listener-mode (buffer) + (let ((point (buffer-point buffer))) + (setf (buffer-minor-mode buffer "Listener") t) + (setf (buffer-minor-mode buffer "Editor") t) + (setf (buffer-major-mode buffer) "Lisp") + (buffer-end point) + (defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil + :buffer buffer) + (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer) + (defhvar "Buffer Input Mark" + "Mark used for Listener Mode input." + :buffer buffer + :value (copy-mark point :right-inserting)) + (defhvar "Buffer Output Mark" + "Mark used for Listener Mode output." + :buffer buffer + :value (copy-mark point :left-inserting)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Input Regions" + "Input region history list." + :buffer buffer + :value nil) + (defhvar "Current Input Font Region" + "Current font region, for listener input" + :buffer buffer + :value nil) + (defhvar "Current Output Font Region" + "Current font region, for listener output" + :buffer buffer + :value nil) + ) + (let* ((input-mark (variable-value 'buffer-input-mark :buffer buffer))) + (when gui::*read-only-listener* + (setf (hi::buffer-protected-region buffer) + (region (buffer-start-mark buffer) input-mark))) + (move-mark input-mark point) + (append-font-regions buffer)))) + +(defmode "Listener" :major-p nil :setup-function #'setup-listener-mode) + +(declaim (special hi::*listener-input-style* hi::*listener-output-style*)) + +(defun append-font-regions (buffer) + (let* ((end (region-end (buffer-region buffer)))) + (setf (variable-value 'current-output-font-region :buffer buffer) + (hi::new-font-region buffer end end hi::*listener-output-style*)) + (let* ((input (hi::new-font-region buffer end end hi::*listener-input-style*))) + (hi::activate-buffer-font-region buffer input) + (setf (variable-value 'current-input-font-region :buffer buffer) input)))) + +(defun append-buffer-output (buffer string) + (let* ((output-region (variable-value 'current-output-font-region + :buffer buffer)) + (output-end (region-end output-region))) + (hi::with-active-font-region (buffer output-region) + (with-mark ((output-mark output-end :left-inserting)) + ;(setf (mark-charpos output-mark) 0) + (insert-string output-mark string)) + (move-mark (variable-value 'buffer-input-mark :buffer buffer) + output-end)))) + + + +(defparameter *listener-modeline-fields* + (list (modeline-field :package) + (modeline-field :modes) + (modeline-field :process-info))) + +(defun listener-mode-lisp-mode-hook (buffer on) + "Turn on Lisp mode when we go into Listener Mode." + (when on + (setf (buffer-major-mode buffer) "Lisp"))) +;;; +(add-hook listener-mode-hook 'listener-mode-lisp-mode-hook) + + + + + +(defvar lispbuf-eof '(nil)) + +(defun balanced-expressions-in-region (region) + "Return true if there's at least one syntactically well-formed S-expression +between the region's start and end, and if there are no ill-formed expressions in that region." + ;; It helps to know that END-MARK immediately follows a #\newline. + (let* ((start-mark (region-start region)) + (end-mark (region-end region)) + (end-line (mark-line end-mark)) + (end-charpos (mark-charpos end-mark))) + (with-mark ((m start-mark)) + (pre-command-parse-check m) + (when (form-offset m 1) + (let* ((skip-whitespace t)) + (loop + (let* ((current-line (mark-line m)) + (current-charpos (mark-charpos m))) + (when (and (eq current-line end-line) + (eql current-charpos end-charpos)) + (return t)) + (if skip-whitespace + (progn + (scan-char m :whitespace nil) + (setq skip-whitespace nil)) + (progn + (pre-command-parse-check m) + (unless (form-offset m 1) + (return nil)) + (setq skip-whitespace t)))))))))) + + + +(defcommand "Confirm Listener Input" (p) + "Evaluate Listener Mode input between point and last prompt." + "Evaluate Listener Mode input between point and last prompt." + (declare (ignore p)) + (let* ((input-region (get-interactive-input)) + (r (if input-region + (region (copy-mark (region-start input-region)) + (copy-mark (region-end input-region) :right-inserting))))) + + (when input-region + (insert-character (current-point) #\NewLine) + (when (balanced-expressions-in-region input-region) + (let* ((string (region-to-string input-region)) ) + (push (cons r nil) (value input-regions)) + (move-mark (value buffer-input-mark) (current-point)) + (append-font-regions (current-buffer)) + (hi::send-string-to-listener-process (hi::buffer-process (current-buffer)) + string)))))) + +(defparameter *pop-string* ":POP +" "what you have to type to exit a break loop") + +(defcommand "POP or Delete Forward" (p) + "Send :POP if input-mark is at buffer's end, else delete forward character." + "Send :POP if input-mark is at buffer's end, else delete forward character." + (let* ((input-mark (value buffer-input-mark)) + (point (current-point-for-deletion))) + (when point + (if (and (null (next-character point)) + (null (next-character input-mark))) + (listener-document-send-string (hi::buffer-document (current-buffer)) *pop-string*) + (delete-next-character-command p))))) + + + + + + + + +;;;; General interactive commands used in eval and typescript buffers. + +(defhvar "Interactive History Length" + "This is the length used for the history ring in interactive buffers. + It must be set before turning on the mode." + :value 10) + +(defun input-region-containing-mark (m history-list) + (dolist (pair history-list) + (let* ((actual (car pair)) + (start (region-start actual)) + (end (region-end actual))) + (when (and (mark>= m start) + (mark<= m end)) ; sic: inclusive + (return (or (cdr pair) (setf (cdr pair) (copy-region actual)))))))) + + +(defun get-interactive-input () + "Tries to return a region. When the point is not past the input mark, and + the user has \"Unwedge Interactive Input Confirm\" set, the buffer is + optionally fixed up, and nil is returned. Otherwise, an editor error is + signalled. When a region is returned, the start is the current buffer's + input mark, and the end is the current point moved to the end of the buffer." + (let ((point (current-point)) + (mark (value buffer-input-mark))) + (cond + ((mark>= point mark) + (buffer-end point) + (let* ((input-region (region mark point)) + (string (region-to-string input-region)) + (ring (value interactive-history))) + (when (and (or (zerop (ring-length ring)) + (string/= string (region-to-string (ring-ref ring 0)))) + (> (length string) (value minimum-interactive-input-length))) + (ring-push (copy-region input-region) ring)) + input-region)) + (t + (let* ((region (input-region-containing-mark point (value input-regions )))) + (buffer-end point) + (if region + (progn + (delete-region (region mark point)) + (insert-region point region)) + (beep)) + nil))))) + + +(defhvar "Minimum Interactive Input Length" + "When the number of characters in an interactive buffer exceeds this value, + it is pushed onto the interactive history, otherwise it is lost forever." + :value 2) + + +(defvar *previous-input-search-string* "ignore") + +(defvar *previous-input-search-pattern* + ;; Give it a bogus string since you can't give it the empty string. + (new-search-pattern :string-insensitive :forward "ignore")) + +(defun get-previous-input-search-pattern (string) + (if (string= *previous-input-search-string* string) + *previous-input-search-pattern* + (new-search-pattern :string-insensitive :forward + (setf *previous-input-search-string* string) + *previous-input-search-pattern*))) + +(defcommand "Search Previous Interactive Input" (p) + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + (declare (ignore p)) + (let* ((mark (value buffer-input-mark)) + (ring (value interactive-history)) + (point (current-point)) + (just-invoked (eq (last-command-type) :searching-interactive-input))) + (when (mark<= point mark) + (editor-error "Point not past input mark.")) + (when (zerop (ring-length ring)) + (editor-error "No previous input in this buffer.")) + (unless just-invoked + (get-previous-input-search-pattern (region-to-string (region mark point)))) + (let ((found-it (find-previous-input ring just-invoked))) + (unless found-it + (editor-error "Couldn't find ~a." *previous-input-search-string*)) + (delete-region (region mark point)) + (insert-region point (ring-ref ring found-it)) + (setf (value searching-interactive-pointer) found-it)) + (setf (last-command-type) :searching-interactive-input))) + +(defun find-previous-input (ring againp) + (let ((ring-length (ring-length ring)) + (base (if againp + (+ (value searching-interactive-pointer) 1) + 0))) + (loop + (when (= base ring-length) + (if againp + (setf base 0) + (return nil))) + (with-mark ((m (region-start (ring-ref ring base)))) + (when (find-pattern m *previous-input-search-pattern*) + (return base))) + (incf base)))) + +(defcommand "Previous Interactive Input" (p) + "Insert the previous input in an interactive mode (Listener or Typescript). + If repeated, keep rotating the history. With prefix argument, rotate + that many times." + "Pop the *interactive-history* at the point." + (let* ((point (current-point)) + (mark (value buffer-input-mark)) + (ring (value interactive-history)) + (length (ring-length ring)) + (p (or p 1))) + (when (or (mark< point mark) (zerop length)) (editor-error "Can't get command history")) + (cond + ((eq (last-command-type) :interactive-history) + (let ((base (mod (+ (value interactive-pointer) p) length))) + (delete-region (region mark point)) + (insert-region point (ring-ref ring base)) + (setf (value interactive-pointer) base))) + (t + (let ((base (mod (if (minusp p) p (1- p)) length)) + (region (delete-and-save-region (region mark point)))) + (insert-region point (ring-ref ring base)) + (when (mark/= (region-start region) (region-end region)) + (ring-push region ring) + (incf base)) + (setf (value interactive-pointer) base))))) + (setf (last-command-type) :interactive-history)) + +(defcommand "Next Interactive Input" (p) + "Rotate the interactive history backwards. The region is left around the + inserted text. With prefix argument, rotate that many times." + "Call previous-interactive-input-command with negated arg." + (previous-interactive-input-command (- (or p 1)))) + +(defcommand "Kill Interactive Input" (p) + "Kill any input to an interactive mode (Listener or Typescript)." + "Kill any input to an interactive mode (Listener or Typescript)." + (declare (ignore p)) + (let ((point (buffer-point (current-buffer))) + (mark (value buffer-input-mark))) + (when (mark< point mark) (editor-error)) + (kill-region (region mark point) :kill-backward))) + +(defcommand "Interactive Beginning of Line" (p) + "If on line with current prompt, go to after it, otherwise do what + \"Beginning of Line\" always does." + "Go to after prompt when on prompt line." + (let ((mark (value buffer-input-mark)) + (point (current-point))) + (if (and (same-line-p point mark) (or (not p) (= p 1))) + (move-mark point mark) + (beginning-of-line-command p)))) + +(defcommand "Reenter Interactive Input" (p) + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + (declare (ignore p)) + (unless (hemlock-bound-p 'buffer-input-mark) + (editor-error "Not in an interactive buffer.")) + (let ((point (current-point))) + (let ((region (if (region-active-p) + ;; Copy this, so moving point doesn't affect the region. + (copy-region (current-region)) + (with-mark ((start point) + (end point)) + (pre-command-parse-check start) + (unless (form-offset start -1) + (editor-error "Not after complete form.")) + (region (copy-mark start) (copy-mark end)))))) + (buffer-end point) + (push-buffer-mark (copy-mark point)) + (insert-region point region) + (setf (last-command-type) :ephemerally-active)))) + + + + +;;; Other stuff. + +(defmode "Editor" :hidden t) + +(defcommand "Editor Mode" (p) + "Turn on \"Editor\" mode in the current buffer. If it is already on, turn it + off. When in editor mode, most lisp compilation and evaluation commands + manipulate the editor process instead of the current eval server." + "Toggle \"Editor\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Editor") + (not (buffer-minor-mode (current-buffer) "Editor")))) + +(define-file-option "Editor" (buffer value) + (declare (ignore value)) + (setf (buffer-minor-mode buffer "Editor") t)) + + + +(defcommand "Editor Compile Defun" (p) + "Compiles the current or next top-level form in the editor Lisp. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, this + compiles the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-compile-region (current-region)) + (editor-compile-region (defun-region (current-point)) t))) + +(defcommand "Editor Compile Region" (p) + "Compiles lisp forms between the point and the mark in the editor Lisp." + "Compiles lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (editor-compile-region (current-region))) + +(defun defun-region (mark) + "This returns a region around the current or next defun with respect to mark. + Mark is not used to form the region. If there is no appropriate top level + form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK." + (with-mark ((start mark) + (end mark)) + (pre-command-parse-check start) + (cond ((not (mark-top-level-form start end)) + (editor-error "No current or next top level form.")) + (t (region start end))))) + +(defun eval-region (region + &key + (package (variable-value 'current-package :buffer (current-buffer))) + (path (buffer-pathname (current-buffer)))) + (evaluate-input-selection + (list package path (region-to-string region)))) + + + +(defun editor-compile-region (region &optional quiet) + (unless quiet (message "Compiling region ...")) + (eval-region region)) + + +(defcommand "Editor Evaluate Defun" (p) + "Evaluates the current or next top-level form in the editor Lisp. + If the current region is active, this evaluates the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-evaluate-region-command nil) + (eval-region (defun-region (current-point))))) + +(defcommand "Editor Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark in the editor Lisp." + "Evaluates lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (eval-region (current-region)) + (let* ((point (current-point))) + (pre-command-parse-check point) + (when (valid-spot point nil) ; not in the middle of a comment + (cond ((eql (next-character point) #\() + (with-mark ((m point)) + (if (list-offset m 1) + (eval-region (region point m))))) + ((eql (previous-character point) #\)) + (with-mark ((m point)) + (if (list-offset m -1) + (eval-region (region m point)))))))))) + +(defcommand "Editor Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (let ((form (read stream))) + (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR.")) + (makunbound (cadr form)) + (message "Evaluation returned ~S" (eval form)))))) + +(defun macroexpand-expression (expander) + (let* ((out (hi::top-listener-output-stream))) + (when out + (let* ((point (buffer-point (current-buffer))) + (region (if (region-active-p) + (current-region) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (region start end))))) + (expr (with-input-from-region (s region) + (read s)))) + (let* ((*print-pretty* t)) + (format out "~&~s~&" (funcall expander expr))))))) + +(defcommand "Editor Macroexpand-1 Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (macroexpand-expression (if p 'macroexpand 'macroexpand-1))) + +(defcommand "Editor Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND-1 instead of MACROEXPAND." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND-1 instead of MACROEXPAND." + (macroexpand-expression (if p 'macroexpand-1 'macroexpand))) + + +(defcommand "Editor Evaluate Expression" (p) + "Prompt for an expression to evaluate in the editor Lisp." + "Prompt for an expression to evaluate in the editor Lisp." + (declare (ignore p)) + (in-lisp + (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}" + (eval (prompt-for-expression + :prompt "Editor Eval: " + :help "Expression to evaluate"))))) + +(defcommand "Editor Evaluate Buffer" (p) + "Evaluates the text in the current buffer in the editor Lisp." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. This occurs in the editor Lisp. The prefix argument is + ignored." + (declare (ignore p)) + (clear-echo-area) + (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (with-input-from-region (stream (buffer-region (current-buffer))) + (let ((*standard-output* *echo-area-stream*)) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object)))) + (message "Evaluation complete."))) + + + +;;; With-Output-To-Window -- Internal +;;; +;;; +(defmacro with-output-to-window ((stream name) &body forms) + "With-Output-To-Window (Stream Name) {Form}* + Bind Stream to a stream that writes into the buffer named Name a la + With-Output-To-Mark. The buffer is created if it does not exist already + and a window is created to display the buffer if it is not displayed. + For the duration of the evaluation this window is made the current window." + (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) + (window (gensym)) (old-window (gensym))) + `(let* ((,nam ,name) + (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam))) + (,point (buffer-end (buffer-point ,buffer))) + (,window (or (car (buffer-windows ,buffer)) (make-window ,point))) + (,old-window (current-window))) + (unwind-protect + (progn (setf (current-window) ,window) + (buffer-end ,point) + (with-output-to-mark (,stream ,point) ,@forms)) + (setf (current-window) ,old-window))))) + +(defcommand "Editor Compile File" (p) + "Prompts for file to compile in the editor Lisp. Does not compare source + and binary write dates. Does not check any buffer for that file for + whether the buffer needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + + +(defun older-or-non-existent-fasl-p (pathname &optional definitely) + (let ((obj-pn (probe-file (compile-file-pathname pathname)))) + (or definitely + (not obj-pn) + (< (file-write-date obj-pn) (file-write-date pathname))))) + + +(defcommand "Editor Compile Buffer File" (p) + "Compile the file in the current buffer in the editor Lisp if its associated + binary file (of type .fasl) is older than the source or doesn't exist. When + the binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the file + without checking the binary file. When \"Compile Buffer File Confirm\" is + set, this command will ask for confirmation when it otherwise would not." + "Compile the file in the current buffer in the editor Lisp if the fasl file + isn't up to date. When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + (t (when (or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))) + + + + + + + + +;;;; Lisp documentation stuff. + +;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and +;;; "Describe Function Call". +;;; +(defmacro function-to-describe (var error-name) + `(cond ((not (symbolp ,var)) + (,error-name "~S is not a symbol." ,var)) + ((special-operator-p ,var) ,var) + ((macro-function ,var)) + ((fboundp ,var)) + (t + (,error-name "~S is not a function." ,var)))) + +(defcommand "Editor Describe Function Call" (p) + "Describe the most recently typed function name in the editor Lisp." + "Describe the most recently typed function name in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let* ((sym (read s)) + (fun (function-to-describe sym editor-error))) + (with-pop-up-display (*standard-output* :title (format nil "~s" sym)) + (editor-describe-function fun sym))))))) + + +(defcommand "Editor Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol in the editor Lisp." + "Describe the previous s-expression if it is a symbol in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-input-from-region (s (region mark1 mark2)) + (let ((thing (read s))) + (if (symbolp thing) + (with-pop-up-display (*standard-output* :title (format nil "~s" thing)) + (describe thing)) + (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (with-pop-up-display (*standard-output* :title (format nil "~s" (cadr thing))) + (describe (cadr thing))) + (editor-error "~S is not a symbol, or 'symbol, or #'symbol." + thing))))))) + +;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol. +;;; However, if the marks are immediately before the first constituent char +;;; of the symbol name, we use the next symbol since the marks probably +;;; correspond to the point, and Hemlock's cursor display makes it look like +;;; the point is within the symbol name. This also tries to ignore :prefix +;;; characters such as quotes, commas, etc. +;;; +(defun mark-symbol (mark1 mark2) + (pre-command-parse-check mark1) + (with-mark ((tmark1 mark1) + (tmark2 mark1)) + (cond ((and (form-offset tmark1 1) + (form-offset (move-mark tmark2 tmark1) -1) + (or (mark= mark1 tmark2) + (and (find-attribute tmark2 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (mark= mark1 tmark2)))) + (form-offset mark2 1)) + (t + (form-offset mark1 -1) + (find-attribute mark1 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (form-offset (move-mark mark2 mark1) 1))))) + + +(defcommand "Editor Describe" (p) + "Call Describe on a Lisp object. + Prompt for an expression which is evaluated to yield the object." + "Prompt for an object to describe." + (declare (ignore p)) + (in-lisp + (let* ((exp (prompt-for-expression + :prompt "Object: " + :help "Expression to evaluate to get object to describe.")) + (obj (eval exp))) + (with-pop-up-display (*standard-output* :title (format nil "~s" exp)) + (describe obj))))) + + +(defcommand "Filter Region" (p) + "Apply a Lisp function to each line of the region. + An expression is prompted for which should evaluate to a Lisp function + from a string to a string. The function must neither modify its argument + nor modify the return value after it is returned." + "Call prompt for a function, then call Filter-Region with it and the region." + (declare (ignore p)) + (let* ((exp (prompt-for-expression + :prompt "Function: " + :help "Expression to evaluate to get function to use as filter.")) + (fun (in-lisp (eval exp))) + (region (current-region))) + (let* ((start (copy-mark (region-start region) :left-inserting)) + (end (copy-mark (region-end region) :left-inserting)) + (region (region start end)) + (undo-region (copy-region region))) + (filter-region fun region) + (make-region-undo :twiddle "Filter Region" region undo-region)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/macros.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/macros.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/macros.lisp (revision 8058) @@ -0,0 +1,608 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains most of the junk that needs to be in the compiler +;;; to compile Hemlock commands. +;;; +;;; Written by Rob MacLachlin and Bill Chiles. +;;; + +(in-package :hemlock-internals) + + + +;;;; Macros used for manipulating Hemlock variables. + +(defmacro invoke-hook (place &rest args) + "Call the functions in place with args. If place is a symbol, then this + interprets it as a Hemlock variable rather than a Lisp variable, using its + current value as the list of functions." + (let ((f (gensym))) + `(dolist (,f ,(if (symbolp place) `(%value ',place) place)) + (funcall ,f ,@args)))) + +(defmacro value (name) + "Return the current value of the Hemlock variable name." + `(%value ',name)) + +(defmacro setv (name new-value) + "Set the current value of the Hemlock variable name, calling any hook + functions with new-value before setting the value." + `(%set-value ',name ,new-value)) + +;;; WITH-VARIABLE-OBJECT -- Internal +;;; +;;; Look up the variable object for name and bind it to obj, giving error +;;; if there is no such variable. +;;; +(defmacro with-variable-object (name &body forms) + `(let ((obj (get ,name 'hemlock-variable-value))) + (unless obj (undefined-variable-error ,name)) + ,@forms)) + +(defmacro hlet (binds &rest forms) + "Hlet ({Var Value}*) {Form}* + Similar to Let, only it creates temporary Hemlock variable bindings. Each + of the vars have the corresponding value during the evaluation of the + forms." + (let ((lets ()) + (sets ()) + (unsets ())) + (dolist (bind binds) + (let ((n-obj (gensym)) + (n-val (gensym)) + (n-old (gensym))) + (push `(,n-val ,(second bind)) lets) + (push `(,n-old (variable-object-value ,n-obj)) lets) + (push `(,n-obj (with-variable-object ',(first bind) obj)) lets) + (push `(setf (variable-object-value ,n-obj) ,n-val) sets) + (push `(setf (variable-object-value ,n-obj) ,n-old) unsets))) + `(let* ,lets + (unwind-protect + (progn ,@sets nil ,@forms) + ,@unsets)))) + + + + +;;;; A couple funs to hack strings to symbols. + +(eval-when (:compile-toplevel :execute :load-toplevel) + +(defun bash-string-to-symbol (name suffix) + (intern (nsubstitute #\- #\space + #-scl + (nstring-upcase + (concatenate 'simple-string + name (symbol-name suffix))) + #+scl + (let ((base (concatenate 'simple-string + name (symbol-name suffix)))) + (if (eq ext:*case-mode* :upper) + (nstring-upcase base) + (nstring-downcase base)))))) + +;;; string-to-variable -- Exported +;;; +;;; Return the symbol which corresponds to the string name +;;; "string". +(defun string-to-variable (string) + "Returns the symbol name of a Hemlock variable from the corresponding string + name." + (intern (nsubstitute #\- #\space + #-scl + (the simple-string (string-upcase string)) + #+scl + (if (eq ext:*case-mode* :upper) + (string-upcase string) + (string-downcase string))) + (find-package :hemlock))) + +); eval-when + +;;; string-to-keyword -- Internal +;;; +;;; Mash a string into a Keyword. +;;; +(defun string-to-keyword (string) + (intern (nsubstitute #\- #\space + #-scl + (the simple-string (string-upcase string)) + #+scl + (if (eq ext:*case-mode* :upper) + (string-upcase string) + (string-downcase string))) + (find-package :keyword))) + + + +;;;; Macros to add and delete hook functions. + +;;; add-hook -- Exported +;;; +;;; Add a hook function to a hook, defining a variable if +;;; necessary. +;;; +(defmacro add-hook (place hook-fun) + "Add-Hook Place Hook-Fun + Add Hook-Fun to the list stored in Place. If place is a symbol then it + it is interpreted as a Hemlock variable rather than a Lisp variable." + (if (symbolp place) + `(pushnew ,hook-fun (value ,place)) + `(pushnew ,hook-fun ,place))) + +;;; remove-hook -- Public +;;; +;;; Delete a hook-function from somewhere. +;;; +(defmacro remove-hook (place hook-fun) + "Remove-Hook Place Hook-Fun + Remove Hook-Fun from the list in Place. If place is a symbol then it + it is interpreted as a Hemlock variable rather than a Lisp variable." + (if (symbolp place) + `(setf (value ,place) (delete ,hook-fun (value ,place))) + `(setf ,place (delete ,hook-fun ,place)))) + + + + +;;;; DEFCOMMAND. + +;;; Defcommand -- Public +;;; +(defmacro defcommand (name lambda-list command-doc function-doc + &body forms) + "Defcommand Name Lambda-List Command-Doc [Function-Doc] {Declaration}* {Form}* + + Define a new Hemlock command named Name. Lambda-List becomes the + lambda-list, Function-Doc the documentation, and the Forms the + body of the function which implements the command. The first + argument, which must be present, is the prefix argument. The name + of this function is derived by replacing all spaces in the name with + hyphens and appending \"-COMMAND\". Command-Doc becomes the + documentation for the command. See the command implementor's manual + for further details. + + An example: + (defcommand \"Forward Character\" (p) + \"Move the point forward one character. + With prefix argument move that many characters, with negative argument + go backwards.\" + \"Move the point of the current buffer forward p characters.\" + (unless (character-offset (buffer-point (current-buffer)) (or p 1)) + (editor-error)))" + + (unless (stringp function-doc) + (setq forms (cons function-doc forms)) + (setq function-doc command-doc)) + (when (atom lambda-list) + (error "Command argument list is not a list: ~S." lambda-list)) + (let (command-name function-name) + (cond ((listp name) + (setq command-name (car name) function-name (cadr name)) + (unless (symbolp function-name) + (error "Function name is not a symbol: ~S" function-name))) + (t + (setq command-name name + function-name (bash-string-to-symbol name '-command)))) + (unless (stringp command-name) + (error "Command name is not a string: ~S." name)) + `(eval-when (:load-toplevel :execute) + (defun ,function-name ,lambda-list ,function-doc + ,@forms) + (make-command ',name ,command-doc ',function-name) + ',function-name))) + + + + +;;;; PARSE-FORMS + +;;; Parse-Forms -- Internal +;;; +;;; Used for various macros to get the declarations out of a list of +;;; forms. +;;; +(eval-when (:compile-toplevel :execute :load-toplevel) +(defmacro parse-forms ((decls-var forms-var forms) &body gorms) + "Parse-Forms (Decls-Var Forms-Var Forms) {Form}* + Binds Decls-Var to leading declarations off of Forms and Forms-Var + to what is left." + `(do ((,forms-var ,forms (cdr ,forms-var)) + (,decls-var ())) + ((or (atom ,forms-var) (atom (car ,forms-var)) + (not (eq (caar ,forms-var) 'declare))) + ,@gorms) + (push (car ,forms-var) ,decls-var))) +) + + + + +;;;; WITH-MARK and USE-BUFFER. + +(defmacro with-mark (mark-bindings &rest forms) + "With-Mark ({(Mark Pos [Kind])}*) {declaration}* {form}* + With-Mark binds a variable named Mark to a mark specified by Pos. This + mark is :temporary, or of kind Kind. The forms are then evaluated." + (do ((bindings mark-bindings (cdr bindings)) + (let-slots ()) + (cleanup ())) + ((null bindings) + (if cleanup + (parse-forms (decls forms forms) + `(let ,(nreverse let-slots) + ,@decls + (unwind-protect + (progn ,@forms) + ,@cleanup))) + `(let ,(nreverse let-slots) ,@forms))) + (let ((name (caar bindings)) + (pos (cadar bindings)) + (type (or (caddar bindings) :temporary))) + (cond ((not (eq type :temporary)) + (push `(,name (copy-mark ,pos ,type)) let-slots) + (push `(delete-mark ,name) cleanup)) + (t + (push `(,name (copy-mark ,pos :temporary)) let-slots)))))) + +#||SAve this shit in case we want WITH-MARKto no longer cons marks. +(defconstant with-mark-total 50) +(defvar *with-mark-free-marks* (make-array with-mark-total)) +(defvar *with-mark-next* 0) + +(defmacro with-mark (mark-bindings &rest forms) + "WITH-MARK ({(Mark Pos [Kind])}*) {declaration}* {form}* + WITH-MARK evaluates each form with each Mark variable bound to a mark + specified by the respective Pos, a mark. The created marks are of kind + :temporary, or of kind Kind." + (do ((bindings mark-bindings (cdr bindings)) + (let-slots ()) + (cleanup ())) + ((null bindings) + (let ((old-next (gensym))) + (parse-forms (decls forms forms) + `(let ((*with-mark-next* *with-mark-next*) + (,old-next *with-mark-next*)) + (let ,(nreverse let-slots) + ,@decls + (unwind-protect + (progn ,@forms) + ,@cleanup)))))) + (let ((name (caar bindings)) + (pos (cadar bindings)) + (type (or (caddar bindings) :temporary))) + (push `(,name (mark-for-with-mark ,pos ,type)) let-slots) + (if (eq type :temporary) + (push `(delete-mark ,name) cleanup) + ;; Assume mark is on free list and drop its hold on data. + (push `(setf (mark-line ,name) nil) cleanup))))) + +;;; MARK-FOR-WITH-MARK -- Internal. +;;; +;;; At run time of a WITH-MARK form, this returns an appropriate mark at the +;;; position mark of type kind. First it uses one from the vector of free +;;; marks, possibly storing one in the vector if we need more marks than we +;;; have before, and that need is still less than the total free marks we are +;;; willing to hold onto. If we're over the free limit, just make one for +;;; throwing away. +;;; +(defun mark-for-with-mark (mark kind) + (let* ((line (mark-line mark)) + (charpos (mark-charpos mark)) + (mark (cond ((< *with-mark-next* with-mark-total) + (let ((m (svref *with-mark-free-marks* *with-mark-next*))) + (cond ((markp m) + (setf (mark-line m) line) + (setf (mark-charpos m) charpos) + (setf (mark-%kind m) kind)) + (t + (setf m (internal-make-mark line charpos kind)) + (setf (svref *with-mark-free-marks* + *with-mark-next*) + m))) + (incf *with-mark-next*) + m)) + (t (internal-make-mark line charpos kind))))) + (unless (eq kind :temporary) + (push mark (line-marks (mark-line mark)))) + mark)) +||# + + +(defmacro use-buffer (buffer &body forms) + "Use-Buffer Buffer {Form}* + Has The effect of making Buffer the current buffer during the evaluation + of the Forms. For restrictions see the manual." + (let ((gensym (gensym))) + `(let ((,gensym *current-buffer*) + (*current-buffer* ,buffer)) + (unwind-protect + (progn + (use-buffer-set-up ,gensym) + ,@forms) + (use-buffer-clean-up ,gensym))))) + + + + + +;;;; EDITOR-ERROR. + +(defun print-editor-error (condx s) + (apply #'format s (editor-error-format-string condx) + (editor-error-format-arguments condx))) + +(define-condition editor-error (error) + ((format-string :initform "" :initarg :format-string + :reader editor-error-format-string) + (format-arguments :initform '() :initarg :format-arguments + :reader editor-error-format-arguments)) + (:report print-editor-error)) +;;; +(setf (documentation 'editor-error-format-string 'function) + "Returns the FORMAT control string of the given editor-error condition.") +(setf (documentation 'editor-error-format-arguments 'function) + "Returns the FORMAT arguments for the given editor-error condition.") + +(defun editor-error (&rest args) + "This function is called to signal minor errors within Hemlock; + these are errors that a normal user could encounter in the course of editing + such as a search failing or an attempt to delete past the end of the buffer. + This function SIGNAL's an editor-error condition formed from args. Hemlock + invokes commands in a dynamic context with an editor-error condition handler + bound. This default handler beeps or flashes (or both) the display. If + args were supplied, it also invokes MESSAGE on them. The command in + progress is always aborted, and this function never returns." + (let ((condx (make-condition 'editor-error + :format-string (car args) + :format-arguments (cdr args)))) + (signal condx) + (error "Unhandled editor-error was signaled -- ~A." condx))) + + + + +;;;; Do-Strings + +(defmacro do-strings ((string-var value-var table &optional result) &body forms) + "Do-Strings (String-Var Value-Var Table [Result]) {declaration}* {form}* + Iterate over the strings in a String Table. String-Var and Value-Var + are bound to the string and value respectively of each successive entry + in the string-table Table in alphabetical order. If supplied, Result is + a form to evaluate to get the return value." + (let ((value-nodes (gensym)) + (num-nodes (gensym)) + (value-node (gensym)) + (i (gensym))) + `(let ((,value-nodes (string-table-value-nodes ,table)) + (,num-nodes (string-table-num-nodes ,table))) + (dotimes (,i ,num-nodes ,result) + (declare (fixnum ,i)) + (let* ((,value-node (svref ,value-nodes ,i)) + (,value-var (value-node-value ,value-node)) + (,string-var (value-node-proper ,value-node))) + (declare (simple-string ,string-var)) + ,@forms))))) + + + + +;;;; COMMAND-CASE + +;;; COMMAND-CASE -- Public +;;; +;;; Grovel the awful thing and spit out the corresponding Cond. See Echo +;;; for the definition of COMMAND-CASE-HELP and logical char stuff. +;;; +(eval-when (:compile-toplevel :execute :load-toplevel) +(defun command-case-tag (tag key-event char) + (cond ((and (characterp tag) (standard-char-p tag)) + `(and ,char (char= ,char ,tag))) + ((and (symbolp tag) (keywordp tag)) + `(logical-key-event-p ,key-event ,tag)) + (t + (error "Tag in COMMAND-CASE is not a standard character or keyword: ~S" + tag)))) +); eval-when +;;; +(defmacro command-case ((&key (change-window t) + (prompt "Command character: ") + (help "Choose one of the following characters:") + (bind (gensym))) + &body forms) + "This is analogous to the Common Lisp CASE macro. Commands such as \"Query + Replace\" use this to get a key-event, translate it to a character, and + then to dispatch on the character to the specified case. The syntax is + as follows: + (COMMAND-CASE ( {key value}* ) + {( {( {tag}* ) | tag} help {form}* )}* + ) + Each tag is either a character or a logical key-event. The user's typed + key-event is compared using either EXT:LOGICAL-KEY-EVENT-P or CHAR= of + EXT:KEY-EVENT-CHAR. + + The legal keys of the key/value pairs are :help, :prompt, :change-window, + and :bind. See the manual for details." + (do* ((forms forms (cdr forms)) + (form (car forms) (car forms)) + (cases ()) + (bname (gensym)) + (again (gensym)) + (n-prompt (gensym)) + (n-change (gensym)) + (bind-char (gensym)) + (docs ()) + (t-case `(t (beep) (reprompt)))) + ((atom forms) + `(macrolet ((reprompt () + `(progn + (setf ,',bind + (prompt-for-key-event* ,',n-prompt ,',n-change)) + (setf ,',bind-char (hemlock-ext:key-event-char ,',bind)) + (go ,',again)))) + (block ,bname + (let* ((,n-prompt ,prompt) + (,n-change ,change-window) + (,bind (prompt-for-key-event* ,n-prompt ,n-change)) + (,bind-char (hemlock-ext:key-event-char ,bind))) + (declare (ignorable ,n-prompt ,n-change ,bind ,bind-char)) + (tagbody + ,again + (return-from + ,bname + (cond ,@(nreverse cases) + ((logical-key-event-p ,bind :abort) + (editor-error)) + ((logical-key-event-p ,bind :help) + (command-case-help ,help ',(nreverse docs)) + (reprompt)) + ,t-case))))))) + + (cond ((atom form) + (error "Malformed Command-Case clause: ~S" form)) + ((eq (car form) t) + (setq t-case form)) + ((or (< (length form) 2) + (not (stringp (second form)))) + (error "Malformed Command-Case clause: ~S" form)) + (t + (let ((tag (car form)) + (rest (cddr form))) + (cond ((atom tag) + (push (cons (command-case-tag tag bind bind-char) rest) + cases) + (setq tag (list tag))) + (t + (do ((tag tag (cdr tag)) + (res () + (cons (command-case-tag (car tag) bind bind-char) + res))) + ((null tag) + (push `((or ,@res) . ,rest) cases))))) + (push (cons tag (second form)) docs)))))) + + + + +;;;; Some random macros used everywhere. + +(defmacro strlen (str) `(length (the simple-string ,str))) +(defmacro neq (a b) `(not (eq ,a ,b))) + + + + +;;;; Stuff from here on is implementation dependant. + + + + +;;;; WITH-INPUT & WITH-OUTPUT macros. + +(defvar *free-hemlock-output-streams* () + "This variable contains a list of free Hemlock output streams.") + +(defmacro with-output-to-mark ((var mark &optional (buffered ':line)) + &body gorms) + "With-Output-To-Mark (Var Mark [Buffered]) {Declaration}* {Form}* + During the evaluation of Forms, Var is bound to a stream which inserts + output at the permanent mark Mark. Buffered is the same as for + Make-Hemlock-Output-Stream." + (parse-forms (decls forms gorms) + `(let ((,var (pop *free-hemlock-output-streams*))) + ,@decls + (if ,var + (modify-hemlock-output-stream ,var ,mark ,buffered) + (setq ,var (make-hemlock-output-stream ,mark ,buffered))) + (unwind-protect + (progn ,@forms) + (setf (hemlock-output-stream-mark ,var) nil) + (push ,var *free-hemlock-output-streams*))))) + +(defvar *free-hemlock-region-streams* () + "This variable contains a list of free Hemlock input streams.") + +(defmacro with-input-from-region ((var region) &body gorms) + "With-Input-From-Region (Var Region) {Declaration}* {Form}* + During the evaluation of Forms, Var is bound to a stream which + returns input from Region." + (parse-forms (decls forms gorms) + `(let ((,var (pop *free-hemlock-region-streams*))) + ,@decls + (if ,var + (setq ,var (modify-hemlock-region-stream ,var ,region)) + (setq ,var (make-hemlock-region-stream ,region))) + (unwind-protect + (progn ,@forms) + (delete-mark (hemlock-region-stream-mark ,var)) + (push ,var *free-hemlock-region-streams*))))) + + + +(defmacro with-pop-up-display ((var &key height title) + &body body) + + "Execute body in a context with var bound to a stream. Output to the stream + appears in the buffer named buffer-name. The pop-up display appears after + the body completes, but if you supply :height, the output is line buffered, + displaying any current output after each line." + (when (and (numberp height) (zerop height)) + (editor-error "I doubt that you really want a window with no height")) + (let ((stream (gensym))) + `(let () + (let ((,stream (gui::typeout-stream ,title))) + (clear-output ,stream) + (unwind-protect + (progn + (catch 'more-punt + (let ((,var ,stream)) + ,@body))) + (force-output ,stream)))))) + + +(declaim (special *random-typeout-ml-fields* *buffer-names*)) + +(defvar *random-typeout-buffers* () "A list of random-typeout buffers.") + + + + + + +;;;; Error handling stuff. + +(declaim (special *echo-area-stream*)) + +;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because +;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite. It +;;; binds an error condition handler to get us out of here on a recursive error +;;; (we are already handling one if we are here). Since COMMAND-CASE uses +;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR, +;;; we bind an editor-error condition handler just inside of the error handler. +;;; This keeps us from being thrown out into the debugger with supposedly +;;; recursive errors occuring. What we really want in this case is to simply +;;; get back to the command loop and forget about the error we are currently +;;; handling. +;;; + +(defun lisp-error-error-handler (condition &optional internalp) + (declare (ignore internalp)) + (report-hemlock-error condition) + (throw 'editor-top-level-catcher nil)) + +(defmacro handle-lisp-errors (&body body) + "Handle-Lisp-Errors {Form}* + If a Lisp error happens during the evaluation of the body, then it is + handled in some fashion. This should be used by commands which may + get a Lisp error due to some action of the user." + `(handler-bind ((error #'lisp-error-error-handler)) + ,@body)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/main.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/main.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/main.lisp (revision 8058) @@ -0,0 +1,324 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock initialization code and random debugging stuff. +;;; +;;; Written by Bill Chiles and Rob MacLachlan +;;; + +(in-package :hemlock-internals) + +#|| +GB +(in-package :extensions) +(export '(save-all-buffers *hemlock-version*)) +(in-package :hemlock-internals) +||# + + + + +;;;; Definition of *hemlock-version*. + +(defvar *hemlock-version* "3.5") +(pushnew :hemlock *features*) +#+(or CMU scl) +(setf (getf ext:*herald-items* :hemlock) + `(" Hemlock " ,*hemlock-version*)) + + + +;;;; %INIT-HEMLOCK. + +(defvar *hemlock-initialized* nil) + +(defun %init-hemlock () + "Initialize hemlock's internal data structures." + ;; + ;; This function is defined in Buffer.Lisp. It creates fundamental mode + ;; and the buffer main. Until this is done it is not possible to define + ;; or use Hemlock variables. + (setup-initial-buffer) + ;; + ;; Define some of the system variables. + (define-some-variables) + ;; + ;; Site initializations such as window system variables. + (site-init) + ;; + ;; Set up syntax table data structures. + (%init-syntax-table) + ;; + ;; Define print representations for funny characters. + (%init-line-image) + (setq *hemlock-initialized* t)) + + + +;;;; Define some globals. + +;;; These globals cannot be defined in the appropriate file due to compilation +;;; or load time constraints. +;;; + +;;; The following belong in other files, but those files are loaded before +;;; table.lisp which defines MAKE-STRING-TABLE. +;;; +;;; vars.lisp +(defvar *global-variable-names* (make-string-table) + "A String Table of global variable names, the values are the symbol names.") +;;; +;;; buffer.lisp +(defvar *mode-names* (make-string-table) "A String Table of Mode names.") +(defvar *buffer-names* (make-string-table) + "A String Table of Buffer names and their corresponding objects.") +;;; +;;; interp.lisp +(defvar *command-names* (make-string-table) "String table of command names.") +;;; +;;; syntax.lisp +(defvar *character-attribute-names* (make-string-table) + "String Table of character attribute names and their corresponding keywords.") + + + + +;;;; DEFINE-SOME-VARIABLES. + +;;; This is necessary to define "Default Status Line Fields" which belongs +;;; beside the other modeline variables. This DEFVAR would live in +;;; Morecoms.Lisp, but it is compiled and loaded after this file. +;;; +(declaim (special hemlock::*recursive-edit-count*)) +;;; +(make-modeline-field + :name :edit-level :width 15 + :function #'(lambda (buffer window) + (declare (ignore buffer window)) + (if (zerop hemlock::*recursive-edit-count*) + "" + (format nil "Edit Level: ~2,'0D " + hemlock::*recursive-edit-count*)))) + +;;; This is necessary to define "Default Status Line Fields" which belongs +;;; beside the other modeline variables. This DEFVAR would live in +;;; Completion.Lisp, but it is compiled and loaded after this file. +;;; +(declaim (special hemlock::*completion-mode-possibility*)) +;;; Hack for now until completion mode is added. +(defvar hemlock::*completion-mode-possibility* "") +;;; +(make-modeline-field + :name :completion :width 40 + :function #'(lambda (buffer window) + (declare (ignore buffer window)) + hemlock::*completion-mode-possibility*)) + + +(defun define-some-variables () + (defhvar "Default Modes" + "This variable contains the default list of modes for new buffers." + :value '("Fundamental")) + (defhvar "Echo Area Height" + "Number of lines in the echo area window." + :value 3) + (defhvar "Make Buffer Hook" + "This hook is called with the new buffer whenever a buffer is created.") + (defhvar "Delete Buffer Hook" + "This hook is called with the buffer whenever a buffer is deleted.") + (defhvar "Enter Recursive Edit Hook" + "This hook is called with the new buffer when a recursive edit is + entered.") + (defhvar "Exit Recursive Edit Hook" + "This hook is called with the value returned when a recursive edit + is exited.") + (defhvar "Abort Recursive Edit Hook" + "This hook is called with the editor-error args when a recursive + edit is aborted.") + (defhvar "Buffer Major Mode Hook" + "This hook is called with the buffer and the new mode when a buffer's + major mode is changed.") + (defhvar "Buffer Minor Mode Hook" + "This hook is called a minor mode is changed. The arguments are + the buffer, the mode affected and T or NIL depending on when the + mode is being turned on or off.") + (defhvar "Buffer Writable Hook" + "This hook is called whenever someone sets whether the buffer is + writable.") + (defhvar "Buffer Name Hook" + "This hook is called with the buffer and the new name when the name of a + buffer is changed.") + (defhvar "Buffer Pathname Hook" + "This hook is called with the buffer and the new Pathname when the Pathname + associated with the buffer is changed.") + (defhvar "Buffer Modified Hook" + "This hook is called whenever a buffer changes from unmodified to modified + and vice versa. It takes the buffer and the new value for modification + flag.") + (defhvar "Buffer Package Hook" + "This hook is called with the new package name whenever a (Lisp) buffer's package changes") + (defhvar "Set Buffer Hook" + "This hook is called with the new buffer when the current buffer is set.") + (defhvar "After Set Buffer Hook" + "This hook is invoked with the old buffer after the current buffer has + been changed.") + (defhvar "Set Window Hook" + "This hook is called with the new window when the current window + is set.") + (defhvar "Make Window Hook" + "This hook is called with a new window when one is created.") + (defhvar "Delete Window Hook" + "This hook is called with a window before it is deleted.") + (defhvar "Window Buffer Hook" + "This hook is invoked with the window and new buffer when a window's + buffer is changed.") + (defhvar "Delete Variable Hook" + "This hook is called when a variable is deleted with the args to + delete-variable.") + (defhvar "Entry Hook" + "this hook is called when the editor is entered.") + (defhvar "Exit Hook" + "This hook is called when the editor is exited.") + (defhvar "Redisplay Hook" + "This is called on the current window from REDISPLAY after checking the + window display start, window image, and recentering. After calling the + functions in this hook, we do the above stuff and call the smart + redisplay method for the device." + :value nil) + (defhvar "Key Echo Delay" + "Wait this many seconds before echoing keys in the command loop. This + feature is inhibited when nil." + :value 1.0) + (defhvar "Input Hook" + "The functions in this variable are invoked each time a character enters + Hemlock." + :value nil) + (defhvar "Abort Hook" + "These functions are invoked when ^G is typed. No arguments are passed." + :value nil) + (defhvar "Command Abort Hook" + "These functions get called when commands are aborted, such as with + EDITOR-ERROR." + :value nil) + (defhvar "Character Attribute Hook" + "This hook is called with the attribute, character and new value + when the value of a character attribute is changed.") + (defhvar "Shadow Attribute Hook" + "This hook is called when a mode character attribute is made.") + (defhvar "Unshadow Attribute Hook" + "This hook is called when a mode character attribute is deleted.") + (defhvar "Default Modeline Fields" + "The default list of modeline-fields for MAKE-WINDOW." + :value *default-modeline-fields*) + (defhvar "Default Status Line Fields" + "This is the default list of modeline-fields for the echo area window's + modeline which is used for general information." + :value (list (make-modeline-field + :name :hemlock-banner :width 27 + :function #'(lambda (buffer window) + (declare (ignore buffer window)) + (format nil "Hemlock ~A " + *hemlock-version*))) + (modeline-field :edit-level) + (modeline-field :completion))) + (defhvar "Maximum Modeline Pathname Length" + "When set, this variable is the maximum length of the display of a pathname + in a modeline. When the pathname is too long, the :buffer-pathname + modeline-field function chops off leading directory specifications until + the pathname fits. \"...\" indicates a truncated pathname." + :value nil + :hooks (list 'maximum-modeline-pathname-length-hook))) + + + + +;;;; ED. + +(defvar *editor-has-been-entered* () + "True if and only if the editor has been entered.") +(defvar *in-the-editor* () + "True if we are inside the editor. This is used to prevent ill-advised + \"recursive\" edits.") + +(defvar *after-editor-initializations-funs* nil + "A list of functions to be called after the editor has been initialized upon + entering the first time.") + +(defmacro after-editor-initializations (&rest forms) + "Causes forms to be executed after the editor has been initialized. + Forms supplied with successive uses of this macro will be executed after + forms supplied with previous uses." + `(push #'(lambda () ,@forms) + *after-editor-initializations-funs*)) + +(defun maybe-load-hemlock-init (init) + (when init + (let* ((switch #+NILGB (find "hinit" *command-line-switches* + :test #'string-equal + :key #'cmd-switch-name)) + (spec-name + (if (not (eq init t)) + init + (and switch + (or (cmd-switch-value switch) + (car (cmd-switch-words switch)))))) + (home (user-homedir-pathname))) + (when home + (if spec-name + (load (merge-pathnames spec-name home) :if-does-not-exist nil) + (or (load (merge-pathnames (make-pathname :name "hemlock-init") home) + :if-does-not-exist nil) + (load (merge-pathnames (make-pathname :name ".hemlock-init") home) + :if-does-not-exist nil))))))) + + + +;;;; SAVE-ALL-BUFFERS. + +;;; SAVE-ALL-BUFFERS -- Public. +;;; +(defun save-all-buffers (&optional (list-unmodified-buffers nil)) + "This prompts users with each modified buffer as to whether they want to + write it out. If the buffer has no associated file, this will also prompt + for a file name. Supplying the optional argument non-nil causes this + to prompt for every buffer." + (dolist (buffer *buffer-list*) + (when (or list-unmodified-buffers (buffer-modified buffer)) + (maybe-save-buffer buffer)))) + +(defun maybe-save-buffer (buffer) + (let* ((modified (buffer-modified buffer)) + (pathname (buffer-pathname buffer)) + (name (buffer-name buffer)) + (string (if pathname (namestring pathname)))) + (format t "Buffer ~S is ~:[UNmodified~;modified~], Save it? " + name modified) + (force-output) + (when (y-or-n-p) + (let ((name (read-line-default "File to write" string))) + (format t "Writing file ~A..." name) + (force-output) + (write-file (buffer-region buffer) name) + (write-line "write WON"))))) + +(defun read-line-default (prompt default) + (format t "~A:~@[ [~A]~] " prompt default) + (force-output) + (do ((result (read-line) (read-line))) + (()) + (declare (simple-string result)) + (when (plusp (length result)) (return result)) + (when default (return default)) + (format t "~A:~@[ [~A]~] " prompt default) + (force-output))) + +(unless *hemlock-initialized* + (%init-hemlock)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/modeline.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/modeline.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/modeline.lisp (revision 8058) @@ -0,0 +1,261 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. + +(in-package :hemlock-internals) + + +;;;; Modelines-field structure support. + +(defun print-modeline-field (obj stream ignore) + (declare (ignore ignore)) + (write-string "#" stream)) + +(defun print-modeline-field-info (obj stream ignore) + (declare (ignore ignore)) + (write-string "#" stream)) + + +(defvar *modeline-field-names* (make-hash-table)) + +(defun make-modeline-field (&key name width function) + "Returns a modeline-field object." + (unless (or (eq width nil) (and (integerp width) (plusp width))) + (error "Width must be nil or a positive integer.")) + (when (gethash name *modeline-field-names*) + (with-simple-restart (continue + "Use the new definition for this modeline field.") + (error "Modeline field ~S already exists." + (gethash name *modeline-field-names*)))) + (setf (gethash name *modeline-field-names*) + (%make-modeline-field name function width))) + +(defun modeline-field (name) + "Returns the modeline-field object named name. If none exists, return nil." + (gethash name *modeline-field-names*)) + + +(declaim (inline modeline-field-name modeline-field-width + modeline-field-function)) + +(defun modeline-field-name (ml-field) + "Returns the name of a modeline field object." + (modeline-field-%name ml-field)) + +(defun %set-modeline-field-name (ml-field name) + (check-type ml-field modeline-field) + (when (gethash name *modeline-field-names*) + (error "Modeline field ~S already exists." + (gethash name *modeline-field-names*))) + (remhash (modeline-field-%name ml-field) *modeline-field-names*) + (setf (modeline-field-%name ml-field) name) + (setf (gethash name *modeline-field-names*) ml-field)) + +(defun modeline-field-width (ml-field) + "Returns the width of a modeline field." + (modeline-field-%width ml-field)) + +(declaim (special *buffer-list*)) + +(defun %set-modeline-field-width (ml-field width) + (check-type ml-field modeline-field) + (unless (or (eq width nil) (and (integerp width) (plusp width))) + (error "Width must be nil or a positive integer.")) + (unless (eql width (modeline-field-%width ml-field)) + (setf (modeline-field-%width ml-field) width) + (dolist (b *buffer-list*) + (when (buffer-modeline-field-p b ml-field) + (dolist (w (buffer-windows b)) + (update-modeline-fields b w))))) + width) + +(defun modeline-field-function (ml-field) + "Returns the function of a modeline field object. It returns a string." + (modeline-field-%function ml-field)) + +(defun %set-modeline-field-function (ml-field function) + (check-type ml-field modeline-field) + (check-type function (or symbol function)) + (setf (modeline-field-%function ml-field) function) + (dolist (b *buffer-list*) + (when (buffer-modeline-field-p b ml-field) + (dolist (w (buffer-windows b)) + (update-modeline-field b w ml-field)))) + function) + + + +;;;; Default modeline and update hooks. + +(make-modeline-field :name :hemlock-literal :width 8 + :function #'(lambda (buffer window) + "Returns \"Hemlock \"." + (declare (ignore buffer window)) + "Hemlock ")) + +(make-modeline-field + :name :external-format + :function #'(lambda (buffer window) + "Returns an indication of buffer's external-format, iff it's +other than :DEFAULT" + (declare (ignore window)) + (let* ((line-termination-string + (case (buffer-line-termination buffer) + ((:unix nil)) + (:macos "CR") + (:cp/m "CRLF"))) + (doc (buffer-document buffer)) + (encoding-name (if doc + (document-encoding-name doc) + "Default"))) + (format nil "[~a~@[ ~a~]] " + encoding-name line-termination-string)))) + + +(make-modeline-field + :name :package + :function #'(lambda (buffer window) + "Returns the value of buffer's \"Current Package\" followed + by a colon and two spaces, or a string with one space." + (declare (ignore window)) + (if (hemlock-bound-p 'hemlock::current-package :buffer buffer) + (let ((val (variable-value 'hemlock::current-package + :buffer buffer))) + (if val + (if (find-package val) + (format nil "~A: " val) + (format nil "?~A?: " val)) + " ")) + " "))) + +(make-modeline-field + :name :modes + :function #'(lambda (buffer window) + "Returns buffer's modes followed by one space." + (declare (ignore window)) + (let* ((m ())) + (dolist (mode (buffer-mode-objects buffer)) + (unless (or (hi::mode-object-major-p mode) + (hi::mode-object-hidden mode)) + (push (mode-object-name mode) m))) + (format nil "~A " (cons (hi::buffer-major-mode buffer) + (nreverse m)))))) + +(make-modeline-field + :name :modifiedp + :function #'(lambda (buffer window) + "Returns \"* \" if buffer is modified, or \" \"." + (declare (ignore window)) + (let ((modifiedp (buffer-modified buffer))) + (if modifiedp + "* " + " ")))) + +(make-modeline-field + :name :buffer-name + :function #'(lambda (buffer window) + "Returns buffer's name followed by a colon and a space if the + name is not derived from the buffer's pathname, or the empty + string." + (declare (ignore window)) + (let ((pn (buffer-pathname buffer)) + (name (buffer-name buffer))) + (cond ((not pn) + (format nil "~A: " name)) + ((string/= (hemlock::pathname-to-buffer-name pn) name) + (format nil "~A: " name)) + (t ""))))) + + +;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline +;;; Pathname Length" is set. +;;; +(defun maximum-modeline-pathname-length-hook (name kind where new-value) + (declare (ignore name new-value)) + (if (eq kind :buffer) + (hi::queue-buffer-change where) + (dolist (buffer *buffer-list*) + (when (and (buffer-modeline-field-p buffer :buffer-pathname) + (buffer-windows buffer)) + (hi::queue-buffer-change buffer))))) + +(defun buffer-pathname-ml-field-fun (buffer window) + "Returns the namestring of buffer's pathname if there is one. When + \"Maximum Modeline Pathname Length\" is set, and the namestring is too long, + return a truncated namestring chopping off leading directory specifications." + (declare (ignore window)) + (let ((pn (buffer-pathname buffer))) + (if pn + (let* ((name (namestring pn)) + (length (length name)) + ;; Prefer a buffer local value over the global one. + ;; Because variables don't work right, blow off looking for + ;; a value in the buffer's modes. In the future this will + ;; be able to get the "current" value as if buffer were current. + (max (if (hemlock-bound-p 'hemlock::maximum-modeline-pathname-length + :buffer buffer) + (variable-value 'hemlock::maximum-modeline-pathname-length + :buffer buffer) + (variable-value 'hemlock::maximum-modeline-pathname-length + :global)))) + (declare (simple-string name)) + (if (or (not max) (<= length max)) + name + (let* ((extra-chars (+ (- length max) 3)) + (slash (or (position #\/ name :start extra-chars) + ;; If no slash, then file-namestring is very + ;; long, and we should include all of it: + (position #\/ name :from-end t + :end extra-chars)))) + (if slash + (concatenate 'simple-string "..." (subseq name slash)) + name)))) + ""))) + + + +(make-modeline-field + :name :buffer-pathname + :function 'buffer-pathname-ml-field-fun) + + + +(make-modeline-field + :name :process-info + :function #'(lambda (buffer window) + (declare (ignore window)) + (let* ((proc (buffer-process buffer))) + (when proc + (format nil "~a(~d) [~a]" + (ccl::process-name proc) + (ccl::process-serial-number proc) + (ccl::process-whostate proc)))))) + +(defparameter *default-modeline-fields* + (list (modeline-field :modifiedp) ;(modeline-field :hemlock-literal) + (modeline-field :external-format) + (modeline-field :package) + (modeline-field :modes)) + "This is the default value for \"Default Modeline Fields\".") + +(defun %init-mode-redisplay () + (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change) + (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change) + (add-hook hemlock::buffer-name-hook 'queue-buffer-change) + (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change) + ;; (SETF (BUFFER-MODIFIED ...)) handles updating the modeline; + ;; it only wants to do so if the buffer's modified state changes. +; (add-hook hemlock::buffer-modified-hook 'queue-buffer-change) + (add-hook hemlock::window-buffer-hook 'queue-window-change) +) + +(defun queue-buffer-change (buffer &optional something-else another-else) + (declare (ignore something-else another-else)) + (dolist (w (buffer-windows buffer)) + (invalidate-modeline w))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/morecoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/morecoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/morecoms.lisp (revision 8058) @@ -0,0 +1,725 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; +;;; Even more commands... + +(in-package :hemlock) + +(defhvar "Region Query Size" + "A number-of-lines threshold that destructive, undoable region commands + should ask the user about when the indicated region is too big." + :value 30) + +(defun check-region-query-size (region) + "Checks the number of lines in region against \"Region Query Size\" and + asks the user if the region crosses this threshold. If the user responds + negatively, then an editor error is signaled." + (let ((threshold (or (value region-query-size) 0))) + (if (and (plusp threshold) + (>= (count-lines region) threshold) + (not (prompt-for-y-or-n + :prompt "Region size exceeds \"Region Query Size\". Confirm: " + :must-exist t))) + (editor-error)))) + +;;; Do nothing, but do it well ... +(defcommand "Do Nothing" (p) + "Do nothing." + "Absolutely nothing." + (declare (ignore p))) + + +;;;; Casing commands... + +(defcommand "Uppercase Word" (p) + "Uppercase a word at point. + With prefix argument uppercase that many words." + "Uppercase p words at the point." + (filter-words p (current-point) #'string-upcase)) + +(defcommand "Lowercase Word" (p) + "Uppercase a word at point. + With prefix argument uppercase that many words." + "Uppercase p words at the point." + (filter-words p (current-point) #'string-downcase)) + +;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word". +;;; +(defun filter-words (p point function) + (let ((arg (or p 1))) + (with-mark ((mark point)) + (if (word-offset (if (minusp arg) mark point) arg) + (filter-region function (region mark point)) + (editor-error "Not enough words."))))) + +;;; "Capitalize Word" is different than uppercasing and lowercasing because +;;; the differences between Hemlock's notion of what a word is and Common +;;; Lisp's notion are too annoying. +;;; +(defcommand "Capitalize Word" (p) + "Lowercase a word capitalizing the first character. With a prefix + argument, capitalize that many words. A negative argument capitalizes + words before the point, but leaves the point where it was." + "Capitalize p words at the point." + (let ((point (current-point)) + (arg (or p 1))) + (with-mark ((start point :left-inserting) + (end point)) + (when (minusp arg) + (unless (word-offset start arg) (editor-error "No previous word."))) + (do ((region (region start end)) + (cnt (abs arg) (1- cnt))) + ((zerop cnt) (move-mark point end)) + (unless (find-attribute start :word-delimiter #'zerop) + (editor-error "No next word.")) + (move-mark end start) + (find-attribute end :word-delimiter) + (loop + (when (mark= start end) + (move-mark point end) + (editor-error "No alphabetic characters in word.")) + (when (alpha-char-p (next-character start)) (return)) + (character-offset start 1)) + (setf (next-character start) (char-upcase (next-character start))) + (hi::buffer-note-modification (current-buffer) start 1) + (mark-after start) + (filter-region #'string-downcase region))))) + +(defcommand "Uppercase Region" (p) + "Uppercase words from point to mark." + "Uppercase words from point to mark." + (declare (ignore p)) + (twiddle-region (current-region) #'string-upcase "Uppercase Region")) + +(defcommand "Lowercase Region" (p) + "Lowercase words from point to mark." + "Lowercase words from point to mark." + (declare (ignore p)) + (twiddle-region (current-region) #'string-downcase "Lowercase Region")) + +;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region". +;;; +(defun twiddle-region (region function name) + (let* (;; don't delete marks start and end since undo stuff will. + (start (copy-mark (region-start region) :left-inserting)) + (end (copy-mark (region-end region) :left-inserting))) + (let* ((region (region start end)) + (undo-region (copy-region region))) + (filter-region function region) + (make-region-undo :twiddle name region undo-region)))) + + + + +;;;; More stuff. + +(defcommand "Delete Previous Character Expanding Tabs" (p) + "Delete the previous character. + When deleting a tab pretend it is the equivalent number of spaces. + With prefix argument, do it that many times." + "Delete the P previous characters, expanding tabs into spaces." + (let* ((buffer (current-buffer)) + (region (hi::%buffer-current-region buffer))) + (if region + (delete-region region) + (let ((point (current-point)) + (n (or p 1))) + (when (minusp n) + (editor-error "Delete Previous Character Expanding Tabs only accepts ~ + positive arguments.")) + ;; Pre-calculate the number of characters that need to be deleted + ;; and any remaining white space filling, allowing modification to + ;; be avoided if there are not enough characters to delete. + (let ((errorp nil) + (del 0) + (fill 0)) + (with-mark ((mark point)) + (dotimes (i n) + (if (> fill 0) + (decf fill) + (let ((prev (previous-character mark))) + (cond ((and prev (char= prev #\tab)) + (let ((pos (mark-column mark))) + (mark-before mark) + (incf fill (- pos (mark-column mark) 1))) + (incf del)) + ((mark-before mark) + (incf del)) + (t + (setq errorp t) + (return))))))) + (cond ((and (not errorp) (kill-characters point (- del))) + (with-mark ((mark point :left-inserting)) + (dotimes (i fill) + (insert-character mark #\space)))) + (t + (editor-error "There were not ~D characters before point." n)))))))) + + +(defvar *scope-table* + (list (make-string-table :initial-contents + '(("Global" . :global) + ("Buffer" . :buffer) + ("Mode" . :mode))))) + +(defun prompt-for-place (prompt help) + (multiple-value-bind (word val) + (prompt-for-keyword *scope-table* :prompt prompt + :help help :default "Global") + (declare (ignore word)) + (case val + (:buffer + (values :buffer (prompt-for-buffer :help "Buffer to be local to." + :default (current-buffer)))) + (:mode + (values :mode (prompt-for-keyword + (list *mode-names*) + :prompt "Mode: " + :help "Mode to be local to." + :default (buffer-major-mode (current-buffer))))) + (:global :global)))) + +(defcommand "Bind Key" (p) + "Bind a command to a key. + The command, key and place to make the binding are prompted for." + "Prompt for stuff to do a bind-key." + (declare (ignore p)) + (multiple-value-call #'bind-key + (values (prompt-for-keyword + (list *command-names*) + :prompt "Command to bind: " + :help "Name of command to bind to a key.")) + (values (prompt-for-key + :prompt "Bind to: " :must-exist nil + :help "Key to bind command to, confirm to complete.")) + (prompt-for-place "Kind of binding: " + "The kind of binding to make."))) + +(defcommand "Delete Key Binding" (p) + "Delete a key binding. + The key and place to remove the binding are prompted for." + "Prompt for stuff to do a delete-key-binding." + (declare (ignore p)) + (let ((key (prompt-for-key + :prompt "Delete binding: " :must-exist nil + :help "Key to delete binding from."))) + (multiple-value-bind (kind where) + (prompt-for-place "Kind of binding: " + "The kind of binding to make.") + (unless (get-command key kind where) + (editor-error "No such binding: ~S" key)) + (delete-key-binding key kind where)))) + + +(defcommand "Set Variable" (p) + "Prompt for a Hemlock variable and a new value." + "Prompt for a Hemlock variable and a new value." + (declare (ignore p)) + (multiple-value-bind (name var) + (prompt-for-variable + :prompt "Variable: " + :help "The name of a variable to set.") + (declare (ignore name)) + (setf (variable-value var) + (handle-lisp-errors + (eval (prompt-for-expression + :prompt "Value: " + :help "Expression to evaluate for new value.")))))) + +(defcommand "Defhvar" (p) + "Define a hemlock variable in some location. If the named variable exists + currently, its documentation is propagated to the new instance, but this + never prompts for documentation." + "Define a hemlock variable in some location." + (declare (ignore p)) + (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil))) + (var (string-to-variable name)) + (doc (if (hemlock-bound-p var) + (variable-documentation var) + "")) + (hooks (if (hemlock-bound-p var) (variable-hooks var))) + (val (prompt-for-expression :prompt "Variable value: " + :help "Value for the variable."))) + (multiple-value-bind + (kind where) + (prompt-for-place + "Kind of binding: " + "Whether the variable is global, mode, or buffer specific.") + (if (eq kind :global) + (defhvar name doc :value val :hooks hooks) + (defhvar name doc kind where :value val :hooks hooks))))) + + + + + +;;; This is used by the :edit-level modeline field which is defined in Main.Lisp. +;;; +(defvar *recursive-edit-count* 0) + +(defun do-recursive-edit () + "Does a recursive edit, wrapping []'s around the modeline of the current + window during its execution. The current window and buffer are saved + beforehand and restored afterward. If they have been deleted by the + time the edit is done then an editor-error is signalled." + (let* ((win (current-window)) + (buf (current-buffer))) + (unwind-protect + (let ((*recursive-edit-count* (1+ *recursive-edit-count*))) + (update-modeline-field *echo-area-buffer* *echo-area-window* + (modeline-field :edit-level)) + (recursive-edit)) + (update-modeline-field *echo-area-buffer* *echo-area-window* + (modeline-field :edit-level)) + (unless (and (member win *window-list*) (memq buf *buffer-list*)) + (editor-error "Old window or buffer has been deleted.")) + (setf (current-window) win) + (unless (eq (window-buffer win) buf) + (setf (window-buffer win) buf)) + (setf (current-buffer) buf)))) + +(defcommand "Exit Recursive Edit" (p) + "Exit a level of recursive edit. Signals an error when not in a + recursive edit." + "Exit a level of recursive edit. Signals an error when not in a + recursive edit." + (declare (ignore p)) + (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) + (exit-recursive-edit ())) + +(defcommand "Abort Recursive Edit" (p) + "Abort the current recursive edit. Signals an error when not in a + recursive edit." + "Abort the current recursive edit. Signals an error when not in a + recursive edit." + (declare (ignore p)) + (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) + (abort-recursive-edit "Recursive edit aborted.")) + + +;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current +;;; region is not active and to get start2 and end2 in proper order. Delete1, +;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the +;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which +;;; marks to dispose of at the end of all this stuff. When we actually get to +;;; swapping the regions, we must delete both up front if they both are to be +;;; deleted since we don't know what kind of marks are in start1, start2, end1, +;;; and end2, and the marks will be moving around unpredictably as we insert +;;; text at them. We copy point into ipoint for insertion purposes since one +;;; of our four marks is the point. +;;; +(defcommand "Transpose Regions" (p) + "Transpose two regions with endpoints defined by the mark stack and point. + To use: mark start of region1, mark end of region1, mark start of region2, + and place point at end of region2. Invoking this immediately following + one use will put the regions back, but you will have to activate the + current region." + "Transpose two regions with endpoints defined by the mark stack and point." + (declare (ignore p)) + (unless (>= (ring-length (value buffer-mark-ring)) 3) + (editor-error "Need two marked regions to do Transpose Regions.")) + (let* ((region (current-region)) + (end2 (region-end region)) + (start2 (region-start region)) + (delete1 (pop-buffer-mark)) + (end1 (pop-buffer-mark)) + (delete2 end1) + (start1 (pop-buffer-mark)) + (delete3 start1)) + ;;get marks in the right order, to simplify the code that follows + (unless (mark<= start1 end1) (rotatef start1 end1)) + (unless (mark<= start1 start2) + (rotatef start1 start2) + (rotatef end1 end2)) + ;;order now guaranteed: start1 end1 start2 end2 + (unless (mark<= end1 start2) + (editor-error "Can't transpose overlapping regions.")) + (let* ((adjacent-p (mark= end1 start2)) + (region1 (delete-and-save-region (region start1 end1))) + (region2 (unless adjacent-p + (delete-and-save-region (region start2 end2)))) + (point (current-point))) + (with-mark ((ipoint point :left-inserting)) + (let ((save-end2-loc (push-buffer-mark (copy-mark end2)))) + (ninsert-region (move-mark ipoint end2) region1) + (push-buffer-mark (copy-mark ipoint)) + (cond (adjacent-p + (push-buffer-mark (copy-mark start2)) + (move-mark point save-end2-loc)) + (t (push-buffer-mark (copy-mark end1)) + (ninsert-region (move-mark ipoint end1) region2) + (move-mark point ipoint)))))) + (delete-mark delete1) + (delete-mark delete2) + (delete-mark delete3))) + + +(defcommand "Goto Absolute Line" (p) + "Goes to the indicated line, if you counted them starting at the beginning + of the buffer with the number one. If a prefix argument is supplied, that + is the line number; otherwise, the user is prompted." + "Go to a user perceived line number." + (let ((p (or p (prompt-for-expression + :prompt "Line number: " + :help "Enter an absolute line number to goto.")))) + (unless (and (integerp p) (plusp p)) + (editor-error "Must supply a positive integer.")) + (let ((point (current-point))) + (with-mark ((m point)) + (unless (line-offset (buffer-start m) (1- p) 0) + (editor-error "Not enough lines in buffer.")) + (move-mark point m))))) + +(defcommand "Goto Absolute Position" (p) + "Goes to the indicated character position, if you counted them + starting at the beginning of the buffer with the number zero. If a + prefix argument is supplied, that is the line number; otherwise, the + user is prompted." + "Go to a user perceived character position." + (let ((p (or p (prompt-for-expression + :prompt "Character Position: " + :help "Enter an absolute character position to goto.")))) + (unless (and (integerp p) (not (minusp p))) + (editor-error "Must supply a non-negatige integer.")) + (let ((point (current-point-unless-selection))) + (when point + (with-mark ((m point)) + (unless (character-offset (buffer-start m) p) + (buffer-end m)) + (move-mark point m)))))) + +(defcommand "What Cursor Position" (p) + "Print info on current point position" + "Print info on current point position" + (declare (ignore p)) + (let* ((point (current-point)) + (current-line (mark-line point))) + (let* ((line-number (do* ((l 1 (1+ l)) + (mark-line (line-previous (mark-line point)) (line-previous mark-line))) + ((null mark-line) l))) + (charpos (mark-charpos point)) + (abspos (+ (hi::get-line-origin current-line) charpos)) + (char (next-character point)) + (size (count-characters (buffer-region (current-buffer))))) + (message "Char: ~s point = ~d of ~d(~d%) line ~d column ~d" + char abspos size (round (/ (* 100 abspos) size)) line-number charpos)))) + + + + + + + +;;;; Mouse Commands. + +(defcommand "Do Nothing" (p) + "Do nothing. + With prefix argument, do it that many times." + "Do nothing p times." + (dotimes (i (or p 1))) + (setf (last-command-type) (last-command-type))) + +(defun do-nothing (&rest args) + (declare (ignore args)) + nil) + +(defun maybe-change-window (window) + (unless (eq window (current-window)) + (when (or (eq window *echo-area-window*) + (eq (current-window) *echo-area-window*) + (member window *random-typeout-buffers* + :key #'(lambda (cons) + (hi::random-typeout-stream-window (cdr cons))))) + (supply-generic-pointer-up-function #'do-nothing) + (editor-error "I'm afraid I can't let you do that Dave.")) + (setf (current-window) window) + (let ((buffer (window-buffer window))) + (unless (eq (current-buffer) buffer) + (setf (current-buffer) buffer))))) + +(defcommand "Top Line to Here" (p) + "Move the top line to the line the mouse is on. + If in the first two columns then scroll continuously until the button is + released." + "Move the top line to the line the mouse is on." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless y (editor-error)) + (cond ((< x 2) + (loop + (when (listen-editor-input hi::*editor-input*) (return)) + (scroll-window window -1) + (redisplay) + (editor-finish-output window))) + (t + (scroll-window window (- y)))))) + +(defcommand "Here to Top of Window" (p) + "Move the line the mouse is on to the top of the window. + If in the first two columns then scroll continuously until the button is + released." + "Move the line the mouse is on to the top of the window." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless y (editor-error)) + (cond ((< x 2) + (loop + (when (listen-editor-input hi::*editor-input*) (return)) + (scroll-window window 1) + (redisplay) + (editor-finish-output window))) + (t + (scroll-window window y))))) + + +(defvar *generic-pointer-up-fun* nil + "This is the function for the \"Generic Pointer Up\" command that defines + its action. Other commands set this in preparation for this command's + invocation.") +;;; +(defun supply-generic-pointer-up-function (fun) + "This provides the action \"Generic Pointer Up\" command performs." + (check-type fun function) + (setf *generic-pointer-up-fun* fun)) + +(defcommand "Generic Pointer Up" (p) + "Other commands determine this command's action by supplying functions that + this command invokes. The following built-in commands supply the following + generic up actions: + \"Point to Here\" + When the position of the pointer is different than the current + point, the action pushes a buffer mark at point and moves point + to the pointer's position. + \"Bufed Goto and Quit\" + The action is a no-op." + "Invoke whatever is on *generic-pointer-up-fun*." + (declare (ignore p)) + (unless *generic-pointer-up-fun* + (editor-error "No commands have supplied a \"Generic Pointer Up\" action.")) + (funcall *generic-pointer-up-fun*)) + + +(defcommand "Point to Here" (p) + "Move the point to the position of the mouse. + If in the modeline, move to the absolute position in the file indicated by + the position within the modeline, pushing the old position on the mark + stack. This supplies a function \"Generic Pointer Up\" invokes if it runs + without any intervening generic pointer up predecessors running. If the + position of the pointer is different than the current point when the user + invokes \"Generic Pointer Up\", then this function pushes a buffer mark at + point and moves point to the pointer's position. This allows the user to + mark off a region with the mouse." + "Move the point to the position of the mouse." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless x (editor-error)) + (maybe-change-window window) + (if y + (let ((m (cursorpos-to-mark x y window))) + (unless m (editor-error)) + (move-mark (current-point) m)) + (let* ((buffer (window-buffer window)) + (region (buffer-region buffer)) + (point (buffer-point buffer))) + (push-buffer-mark (copy-mark point)) + (move-mark point (region-start region)) + (line-offset point (round (* (1- (count-lines region)) x) + (1- (window-width window))))))) + (supply-generic-pointer-up-function #'point-to-here-up-action)) + +(defun point-to-here-up-action () + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless x (editor-error)) + (when y + (maybe-change-window window) + (let ((m (cursorpos-to-mark x y window))) + (unless m (editor-error)) + (when (eq (line-buffer (mark-line (current-point))) + (line-buffer (mark-line m))) + (unless (mark= m (current-point)) + (push-buffer-mark (copy-mark (current-point)) t))) + (move-mark (current-point) m))))) + + +(defcommand "Insert Kill Buffer" (p) + "Move current point to the mouse location and insert the kill buffer." + "Move current point to the mouse location and insert the kill buffer." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless x (editor-error)) + (maybe-change-window window) + (if y + (let ((m (cursorpos-to-mark x y window))) + (unless m (editor-error)) + (move-mark (current-point) m) + (un-kill-command nil)) + (editor-error "Can't insert kill buffer in modeline.")))) + + + + +;;;; Page commands & stuff. + +(defvar *goto-page-last-num* 0) +(defvar *goto-page-last-string* "") + +(defcommand "Goto Page" (p) + "Go to an absolute page number (argument). If no argument, then go to + next page. A negative argument moves back that many pages if possible. + If argument is zero, prompt for string and goto page with substring + in title." + "Go to an absolute page number (argument). If no argument, then go to + next page. A negative argument moves back that many pages if possible. + If argument is zero, prompt for string and goto page with substring + in title." + (let ((point (current-point))) + (cond ((not p) + (page-offset point 1)) + ((zerop p) + (let* ((againp (eq (last-command-type) :goto-page-zero)) + (name (prompt-for-string :prompt "Substring of page title: " + :default (if againp + *goto-page-last-string* + *parse-default*))) + (dir (page-directory (current-buffer))) + (i 1)) + (declare (simple-string name)) + (cond ((not againp) + (push-buffer-mark (copy-mark point))) + ((string-equal name *goto-page-last-string*) + (setf dir (nthcdr *goto-page-last-num* dir)) + (setf i (1+ *goto-page-last-num*)))) + (loop + (when (null dir) + (editor-error "No page title contains ~S." name)) + (when (search name (the simple-string (car dir)) + :test #'char-equal) + (goto-page point i) + (setf (last-command-type) :goto-page-zero) + (setf *goto-page-last-num* i) + (setf *goto-page-last-string* name) + (return t)) + (incf i) + (setf dir (cdr dir))))) + ((minusp p) + (page-offset point p)) + (t (goto-page point p))) + (line-start (move-mark (window-display-start (current-window)) point)))) + +(defun goto-page (mark i) + (with-mark ((m mark)) + (buffer-start m) + (unless (page-offset m (1- i)) + (editor-error "No page numbered ~D." i)) + (move-mark mark m))) + + + + +(defcommand "Count Lines" (p) + "Display number of lines in the region." + "Display number of lines in the region." + (declare (ignore p)) + (multiple-value-bind (region activep) (get-count-region) + (message "~:[After point~;Active region~]: ~A lines" + activep (count-lines region)))) + +(defcommand "Count Words" (p) + "Prints in the Echo Area the number of words in the region + between the point and the mark by using word-offset. The + argument is ignored." + "Prints Number of Words in the Region" + (declare (ignore p)) + (multiple-value-bind (region activep) (get-count-region) + (let ((end-mark (region-end region))) + (with-mark ((beg-mark (region-start region))) + (let ((word-count 0)) + (loop + (when (mark>= beg-mark end-mark) + (return)) + (unless (word-offset beg-mark 1) + (return)) + (incf word-count)) + (message "~:[After point~;Active region~]: ~D Word~:P" + activep word-count)))))) + +;;; GET-COUNT-REGION -- Internal Interface. +;;; +;;; Returns the active region or the region between point and end-of-buffer. +;;; As a second value, it returns whether the region was active. +;;; +;;; Some searching commands use this routine. +;;; +(defun get-count-region () + (if (region-active-p) + (values (current-region) t) + (values (region (current-point) (buffer-end-mark (current-buffer))) + nil))) + + + + +;;;; Some modes: + +(defcommand "Fundamental Mode" (p) + "Put the current buffer into \"Fundamental\" mode." + "Put the current buffer into \"Fundamental\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Fundamental")) + +;;; +;;; Text mode. +;;; + +(defmode "Text" :major-p t) + +(defcommand "Text Mode" (p) + "Put the current buffer into \"Text\" mode." + "Put the current buffer into \"Text\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Text")) + +;;; +;;; Caps-lock mode. +;;; + +(defmode "CAPS-LOCK") + +(defcommand "Caps Lock Mode" (p) + "Simulate having a CAPS LOCK key. Toggle CAPS-LOCK mode. Zero or a + negative argument turns it off, while a positive argument turns it + on." + "Simulate having a CAPS LOCK key. Toggle CAPS-LOCK mode. Zero or a + negative argument turns it off, while a positive argument turns it + on." + (setf (buffer-minor-mode (current-buffer) "CAPS-LOCK") + (if p + (plusp p) + (not (buffer-minor-mode (current-buffer) "CAPS-LOCK"))))) + +(defcommand "Self Insert Caps Lock" (p) + "Insert the last character typed, or the argument number of them. + If the last character was an alphabetic character, then insert its + capital form." + "Insert the last character typed, or the argument number of them. + If the last character was an alphabetic character, then insert its + capital form." + (let ((char (char-upcase (hemlock-ext:key-event-char *last-key-event-typed*)))) + (if (and p (> p 1)) + (insert-string (current-point) (make-string p :initial-element char)) + (insert-character (current-point) char)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/package.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/package.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/package.lisp (revision 8058) @@ -0,0 +1,687 @@ +(in-package :cl-user) + +;; Note: I want real relative package names like the Symbolics has +;; them. In the mean time: + +#+CMU +(eval-when (:compile-toplevel :load-toplevel :execute) + (progn + ;; Just in case the original Hemlock is loaded. + (dolist (p '("HEMLOCK" "HEMLOCK-INTERNALS")) + (when (find-package p) + (delete-package p))))) + + +(defpackage :hemlock-interface + (:use) + (:export + ;; Functions from the CIM: + #:linep + #:line-string + #:line-previous + #:line-next + #:line-buffer + #:line-length + #:line-character + #:line-plist + #:line-signature + #:markp + #:mark-line + #:mark-charpos + #:mark-kind + #:previous-character + #:next-character + #:mark + #:copy-mark + #:delete-mark + #:move-to-position + #:move-mark + #:line-start + #:line-end + #:buffer-start + #:buffer-end + #:mark-before + #:mark-after + #:character-offset + #:line-offset + #:region + #:regionp + #:make-empty-region + #:copy-region + #:region-to-string + #:string-to-region + #:line-to-region + #:region-start + #:region-end + #:region-bounds + #:set-region-bounds + #:count-lines + #:count-characters + #:current-buffer + #:current-point-for-insertion + #:current-point-for-deletion + #:current-point-unless-selection + #:current-point-collapsing-selection + #:current-point-extending-selection + #:current-point + #:current-mark + #:pop-buffer-mark + #:push-buffer-mark + #:change-to-buffer + #:previous-buffer + #:make-buffer + #:bufferp + #:buffer-name + #:buffer-region + #:buffer-pathname + #:buffer-write-date + #:buffer-point + #:buffer-mark + #:buffer-start-mark + #:buffer-end-mark + #:buffer-writable + #:buffer-modified + #:buffer-signature + #:buffer-variables + #:buffer-modes + #:buffer-windows + #:buffer-delete-hook + #:buffer-package + #:delete-buffer + #:delete-buffer-if-possible + #:make-modeline-field + #:modeline-field-p + #:modeline-field-name + #:modeline-field + #:modeline-field-function + #:modeline-field-width + #:buffer-modeline-fields + #:buffer-modeline-field-p + #:update-modeline-fields + #:update-modeline-field + #:insert-character + #:insert-string + #:insert-region + #:ninsert-region + #:delete-characters + #:delete-region + #:delete-and-save-region + #:filter-region + #:start-line-p + #:end-line-p + #:empty-line-p + #:blank-line-p + #:blank-before-p + #:blank-after-p + #:same-line-p + #:mark< + #:mark<= + #:mark= + #:mark/= + #:mark>= + #:mark> + #:line< + #:line<= + #:line>= + #:line> + #:lines-related + #:first-line-p + #:last-line-p + #:kill-region + #:kill-characters + #:activate-region + #:deactivate-region + #:region-active-p + #:check-region-active + #:current-region + #:new-search-pattern + #:search-pattern-p + #:get-search-pattern + #:find-pattern + #:replace-pattern + #:current-variable-tables + #:defhvar + #:variable-value + #:variable-documentation + #:variable-hooks + #:variable-name + #:string-to-variable + #:hemlock-bound-p + #:delete-variable + #:make-command + #:commandp + #:command-documentation + #:command-function + #:command-name + #:bind-key + #:command-bindings + #:delete-key-binding + #:get-command + #:map-bindings + #:key-translation + #:interactive + #:last-command-type + #:prefix-argument + #:recursive-edit + #:in-recursive-edit + #:exit-recursive-edit + #:abort-recursive-edit + #:defmode + #:mode-documentation + #:buffer-major-mode + #:buffer-minor-mode + #:mode-variables + #:mode-major-p + #:defattribute + #:character-attribute-name + #:character-attribute-documentation + #:character-attribute + #:character-attribute-p + #:shadow-attribute + #:unshadow-attribute + #:find-attribute + #:find-not-attribute + #:reverse-find-attribute + #:reverse-find-not-attribute + #:character-attribute-hooks + #:current-window + #:make-window + #:windowp + #:delete-window + #:window-buffer + #:window-display-start + #:window-display-end + #:window-display-recentering + #:window-point + #:center-window + #:scroll-window + #:displayed-p + #:window-height + #:window-width + #:next-window + #:previous-window + #:mark-to-cursorpos + #:cursorpos-to-mark + #:last-key-event-cursorpos + #:mark-column + #:move-to-column + #:show-mark + #:redisplay + #:redisplay-all + #:editor-finish-output + #:define-logical-key-event + #:logical-key-event-key-events + #:logical-key-event-name + #:logical-key-event-documentation + #:logical-key-event-p + #:clear-echo-area + #:message + #:loud-message + #:prompt-for-buffer + #:prompt-for-key-event + #:prompt-for-key + #:prompt-for-file + #:prompt-for-integer + #:prompt-for-keyword + #:prompt-for-expression + #:prompt-for-string + #:prompt-for-variable + #:prompt-for-y-or-n + #:prompt-for-yes-or-no + #:process-file-options + #:pathname-to-buffer-name + #:buffer-default-pathname + #:read-file + #:write-file + #:write-buffer-file + #:read-buffer-file + #:find-file-buffer + ;; #:ed + #:exit-hemlock + #:pause-hemlock + #:get-key-event + #:unget-key-event + #:recursive-get-key-event + #:clear-editor-input + #:listen-editor-input + #:editor-sleep + #:make-hemlock-output-stream + #:hemlock-output-stream-p + #:make-hemlock-region-stream + #:hemlock-region-stream-p + #:editor-error-format-string + #:editor-error-format-arguments + #:editor-error + #:add-definition-dir-translation + #:delete-definition-dir-translation + #:schedule-event + #:remove-scheduled-event + #:in-lisp + #:indent-region + #:indent-region-for-commands + #:delete-horizontal-space + #:pre-command-parse-check + #:form-offset + #:top-level-offset + #:mark-top-level-form + #:defun-region + #:inside-defun-p + #:start-defun-p + #:forward-up-list + #:backward-up-list + #:valid-spot + #:defindent + #:word-offset + #:sentence-offset + #:paragraph-offset + #:mark-paragraph + #:goto-page + #:page-offset + #:page-directory + #:display-page-directory + #:fill-region + #:fill-region-by-paragraphs + #:make-string-table + #:string-table-p + #:string-table-separator + #:delete-string + #:clrstring + #:getstring + #:complete-string + #:find-ambiguous + #:find-containing + #:make-ring + #:ringp + #:ring-length + #:ring-ref + #:ring-push + #:ring-pop + #:rotate-ring + #:save-for-undo + #:make-region-undo + #:supply-generic-pointer-up-function + + ;; Macros from the CIM: + #:with-writable-buffer + #:value + #:setv + #:add-hook + #:remove-hook + #:invoke-hook + #:defcommand + #:use-buffer + #:command-case + #:define-file-option + #:define-file-type-hook + #:do-active-group + #:with-input-from-region + #:with-output-to-mark + #:with-pop-up-display + #:handle-lisp-errors + #:do-alpha-chars + #:do-strings + + )) + +(defpackage :hemlock-ext + (:use :common-lisp + :hemlock-interface) + #+cmu + (:import-from :ext #:complete-file) + (:shadow #:char-code-limit) + ;; + (:export + #:file-comment + #:without-interrupts + #:without-gcing + #:define-setf-method + #:getenv + + #:delq #:memq #:assq + #:fixnump + #:file-writable + + #:define-keysym #:define-mouse-keysym #:name-keysym #:keysym-names + #:keysym-preferred-name #:define-key-event-modifier #:define-clx-modifier + #:make-key-event-bits #:key-event-modifier-mask #:key-event-bits-modifiers + #:*all-modifier-names* #:translate-key-event #:translate-mouse-key-event + #:make-key-event #:key-event #:key-event-p #:key-event-bits #:key-event-keysym + #:char-key-event #:key-event-char #:key-event-bit-p #:do-alpha-key-events + #:print-pretty-key #:print-pretty-key-event + + ;; hemlock-ext.lisp + #:disable-clx-event-handling + #:quit + #:serve-event + #:sap-ref-8 + #:make-object-set + #:default-clx-event-handler + #:serve-exposure + #:serve-graphics-exposure + #:serve-no-exposure + #:serve-configure-notify + #:serve-destroy-notify + #:serve-unmap-notify + #:serve-map-notify + #:serve-reparent-notify + #:serve-gravity-notify + #:serve-circulate-notify + #:serve-client-message + #:serve-key-press + #:serve-button-press + #:serve-button-release + #:serve-enter-notify + #:serve-leave-notify + #:flush-display-events + #:object-set-event-handler + #:with-clx-event-handling + #:complete-file + #:default-directory)) + +(defpackage :hemlock-internals + (:use :common-lisp :hemlock-interface) + (:nicknames :hi) + (:shadow #:char-code-limit) + (:import-from + ;; gray streams + #+EXCL :excl + #+CLISP :gray + #+CMU :ext + #+sbcl :sb-gray + #+scl :ext + #+openmcl :gray + ;; + ;; Note the pacth i received from DTC mentions character-output and + ;; character-input-stream here, so we actually see us faced to + ;; provide for compatibility classes. --GB + #-scl #:fundamental-character-output-stream + #-scl #:fundamental-character-input-stream + ;; There is conditionalization in streams.lisp, see above --GB + #+scl #:character-output-stream + #+scl #:character-input-stream + + #:stream-write-char + #-scl #:stream-write-string ; wonder what that is called --GB + #:stream-read-char + #:stream-listen + #:stream-unread-char + #:stream-clear-input + #:stream-finish-output + #:stream-force-output + #:stream-line-column) + (:import-from :hemlock-ext + #:delq #:memq #:assq) + ;; + (:export + #:*FAST* ;hmm not sure about this one + + ;; rompsite.lisp + #:show-mark #:editor-sleep #:*input-transcript* #:fun-defined-from-pathname + #:editor-describe-function #:pause-hemlock #:store-cut-string + #:fetch-cut-string #:schedule-event #:remove-scheduled-event + #:enter-window-autoraise #:directoryp #:merge-relative-pathnames + ;; + ;; Export default-font to prevent a name conflict that occurs due to + ;; the Hemlock variable "Default Font" defined in SITE-INIT below. + ;; + #:default-font + #:*beep-function* #:beep + + ;; + #:mark #:mark-line #:mark-charpos #:markp #:region #:region-start #:region-end + #:regionp #:buffer #:bufferp #:buffer-modes #:buffer-point #:buffer-writable + #:buffer-delete-hook #:buffer-windows #:buffer-variables #:buffer-write-date + #:region #:regionp #:region-start #:region-end #:window #:windowp #:window-height + #:window-width #:window-display-start #:window-display-end #:window-point + #:window-display-recentering #:commandp #:command #:command-function + #:command-documentation #:modeline-field #:modeline-field-p + + ;; from input.lisp + #:get-key-event #:unget-key-event #:clear-editor-input #:listen-editor-input + #:*last-key-event-typed* #:*key-event-history* + #:input-waiting #:last-key-event-cursorpos + + ;; from macros.lisp + #:invoke-hook #:value #:setv #:hlet #:string-to-variable #:add-hook #:remove-hook + #:defcommand #:with-mark #:use-buffer #:editor-error + #:editor-error-format-string #:editor-error-format-arguments #:do-strings + #:command-case #:reprompt #:with-output-to-mark #:with-input-from-region + #:handle-lisp-errors #:with-pop-up-display #:*random-typeout-buffers* + + ;; from line.lisp + #:line #:linep #:line-previous #:line-next #:line-plist #:line-signature + + ;; from ring.lisp + #:ring #:ringp #:make-ring #:ring-push #:ring-pop #:ring-length #:ring-ref + #:rotate-ring + + ;; from table.lisp + #:string-table #:string-table-p #:make-string-table + #:string-table-separator #:getstring + #:find-ambiguous #:complete-string #:find-containing + #:delete-string #:clrstring #:do-strings + + ;; bit-display.lisp + #:redisplay #:redisplay-all + + ;; bit-screen.lisp + #:make-xwindow-like-hwindow #:*create-window-hook* #:*delete-window-hook* + #:*random-typeout-hook* #:*create-initial-windows-hook* + + ;; buffer.lisp + #:buffer-modified #:buffer-region #:buffer-name #:buffer-pathname + #:buffer-major-mode #:buffer-minor-mode #:buffer-modeline-fields + #:buffer-modeline-field-p #:current-buffer #:current-point + #:in-recursive-edit #:exit-recursive-edit #:abort-recursive-edit + #:recursive-edit #:defmode #:mode-major-p #:mode-variables #:mode-documentation + #:make-buffer #:delete-buffer #:with-writable-buffer #:buffer-start-mark + #:buffer-end-mark #:*buffer-list* + + ;; charmacs.lisp + #:syntax-char-code-limit #:search-char-code-limit #:do-alpha-chars + + ;; cursor.lisp + #:mark-to-cursorpos #:center-window #:displayed-p #:scroll-window + #:mark-column #:cursorpos-to-mark #:move-to-column + + ;; display.lisp + #:redisplay #:redisplay-all + + ;; echo.lisp + #:*echo-area-buffer* #:*echo-area-stream* #:*echo-area-window* + #:*parse-starting-mark* #:*parse-input-region* + #:*parse-verification-function* #:*parse-string-tables* + #:*parse-value-must-exist* #:*parse-default* #:*parse-default-string* + #:*parse-prompt* #:*parse-help* #:clear-echo-area #:message #:loud-message + #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer + #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string + #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n + #:prompt-for-key-event #:prompt-for-key #:*logical-key-event-names* + #:logical-key-event-p #:logical-key-event-documentation + #:logical-key-event-name #:logical-key-event-key-events + #:define-logical-key-event #:*parse-type* #:current-variable-tables + + ;; files.lisp + #:read-file #:write-file + + + ;; font.lisp + #:font-mark #:delete-font-mark #:delete-line-font-marks #:move-font-mark + #:window-font + + ;; htext1.lisp + #:line-length #:line-buffer #:line-string #:line-character #:mark #:mark-kind + #:copy-mark #:delete-mark #:move-to-position #:region #:make-empty-region + #:start-line-p #:end-line-p #:empty-line-p #:blank-line-p #:blank-before-p + #:blank-after-p #:same-line-p #:mark< #:mark<= #:mark> #:mark>= #:mark= #:mark/= + #:line< #:line<= #:line> #:line>= #:first-line-p #:last-line-p #:buffer-signature + #:lines-related + + + ;; htext2.lisp + #:region-to-string #:string-to-region #:line-to-region + #:previous-character #:next-character #:count-lines + #:count-characters #:line-start #:line-end #:buffer-start + #:buffer-end #:move-mark #:mark-before #:mark-after + #:character-offset #:line-offset #:region-bounds + #:set-region-bounds #:*print-region* + + + ;; htext3.lisp + #:insert-character #:insert-string #:insert-region #:ninsert-region + + + ;; htext4.lisp + #:delete-characters #:delete-region #:delete-and-save-region #:copy-region + #:filter-region + + + ;; interp.lisp + #:bind-key #:delete-key-binding #:get-command #:map-bindings + #:make-command #:command-name #:command-bindings #:last-command-type + #:prefix-argument #:exit-hemlock #:*invoke-hook* #:key-translation + + + ;; main.lisp + #:*global-variable-names* #:*mode-names* #:*buffer-names* + #:*character-attribute-names* #:*command-names* #:*buffer-list* + #:*window-list* #:*last-key-event-typed* #:after-editor-initializations + + ;; screen.lisp + #:make-window #:delete-window #:next-window #:previous-window + + + ;; search1.lisp + #:search-pattern #:search-pattern-p #:find-pattern #:replace-pattern + #:new-search-pattern + + + ;; streams.lisp + #:make-hemlock-output-stream + #:hemlock-region-stream #:hemlock-region-stream-p + #:hemlock-output-stream #:make-hemlock-region-stream + #:hemlock-output-stream-p #:make-kbdmac-stream + #:modify-kbdmac-stream + + ;; syntax.lisp + #:character-attribute-name + #:defattribute #:character-attribute-documentation #:character-attribute + #:character-attribute-hooks #:character-attribute-p #:shadow-attribute + #:unshadow-attribute #:find-attribute #:reverse-find-attribute + + ;; vars.lisp + #:variable-value #:variable-hooks #:variable-documentation #:variable-name + #:hemlock-bound-p #:defhvar #:delete-variable + + ;; window.lisp + #:current-window #:window-buffer #:modeline-field-width + #:modeline-field-function #:make-modeline-field #:update-modeline-fields + #:update-modeline-field #:modeline-field-name #:modeline-field + #:editor-finish-output #:*window-list* + + )) + + +(defpackage :hemlock + (:use :common-lisp :hemlock-interface :hi :hemlock-ext) +;;; (:import-from :hemlock-ext #:delq #:memq #:assq) +;;; (:import-from :hemlock-internals #:*fast*) + (:shadowing-import-from #:hemlock-ext + #:char-code-limit) + ;; #+cmu + ;; These are defined in EXTENSONS package in CMUCL + (:shadowing-import-from :hemlock-ext + #:*ALL-MODIFIER-NAMES* + #:ASSQ + #:CHAR-KEY-EVENT + #:DEFAULT-CLX-EVENT-HANDLER + #:DEFAULT-DIRECTORY + #:DEFINE-CLX-MODIFIER + #:DEFINE-KEY-EVENT-MODIFIER + #:DEFINE-KEYSYM + #:DEFINE-MOUSE-KEYSYM + #:DELQ + #:DISABLE-CLX-EVENT-HANDLING + #:DO-ALPHA-KEY-EVENTS + #:FILE-WRITABLE + #:FIXNUMP + #:FLUSH-DISPLAY-EVENTS + #:KEY-EVENT + #:KEY-EVENT-BIT-P + #:KEY-EVENT-BITS + #:KEY-EVENT-BITS-MODIFIERS + #:KEY-EVENT-CHAR + #:KEY-EVENT-KEYSYM + #:KEY-EVENT-MODIFIER-MASK + #:KEY-EVENT-P + #:KEYSYM-NAMES + #:KEYSYM-PREFERRED-NAME + #:MAKE-KEY-EVENT + #:MAKE-KEY-EVENT-BITS + #:MEMQ + #:NAME-KEYSYM + #:OBJECT-SET-EVENT-HANDLER + #:PRINT-PRETTY-KEY + #:PRINT-PRETTY-KEY-EVENT + #:QUIT + #:SERVE-BUTTON-PRESS + #:SERVE-BUTTON-RELEASE + #:SERVE-CIRCULATE-NOTIFY + #:SERVE-CLIENT-MESSAGE + #:SERVE-CONFIGURE-NOTIFY + #:SERVE-DESTROY-NOTIFY + #:SERVE-ENTER-NOTIFY + #:SERVE-EXPOSURE + #:SERVE-GRAPHICS-EXPOSURE + #:SERVE-GRAVITY-NOTIFY + #:SERVE-KEY-PRESS + #:SERVE-LEAVE-NOTIFY + #:SERVE-MAP-NOTIFY + #:SERVE-NO-EXPOSURE + #:SERVE-REPARENT-NOTIFY + #:SERVE-UNMAP-NOTIFY + + ;; These four are from SYSTEM package + #:MAKE-OBJECT-SET + #:SAP-REF-8 + #:SERVE-EVENT + #:WITHOUT-INTERRUPTS + + #:TRANSLATE-KEY-EVENT + #:TRANSLATE-MOUSE-KEY-EVENT + #:WITH-CLX-EVENT-HANDLING) + ) + + +;; $Log$ +;; Revision 1.2 2005/08/01 10:54:17 gb +;; Don't export CHECK-REGION-QUERY-SIZE. +;; +;; Revision 1.1.1.1 2003/10/19 08:57:16 gb +;; recovered 0.14 sources +;; +;; Revision 1.1.2.1 2003/08/10 19:11:33 gb +;; New files, imported from upstream CVS as of 03/08/09. +;; +;; Revision 1.9 2003/08/05 19:58:21 gilbert +;; - we now have a HEMLOCK-INTERFACE package which exports symbols mentioned +;; in the Command Implementors Manual. +;; +;; Revision 1.8 2003/07/28 20:35:32 jdz +;; BEEP function now works. +;; +;; Revision 1.7 2003/07/27 10:11:06 jdz +;; HEMLOCK-EXT package is now used by HEMLOCK. Conflicting symbols from +;; EXTENSIONS package in CMUCL are shadowed. +;; +;; Revision 1.6 2003/05/12 11:01:48 gbyers +;; Conditionalize (Gray streams package) for OpenMCL. +;; +;; Revision 1.5 2003/03/26 07:50:10 gilbert +;; Port to SCL by Douglas Crosher +;; +;; Revision 1.4 2003/03/06 21:38:58 gilbert +;; The symbol *FAST* is now exported from HI (no idea if that is the +;; right thing to do) and imported into HEMLOCK. Fixes bug: +;; auto-save.lisp was not compiling. +;; Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/pop-up-stream.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/pop-up-stream.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/pop-up-stream.lisp (revision 8058) @@ -0,0 +1,142 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contatins the stream operations for pop-up-displays. +;;; +;;; Written by Blaine Burks. +;;; + +(in-package :hemlock-internals) + + + + +;;;; Line-buffered Stream Methods. + +;; ###GB we want a more optimized interface + +(defmethod stream-write-char ((stream random-typeout-stream) char) + (with-slots (line-buffered-p) stream + (cond (line-buffered-p + (insert-character (random-typeout-stream-mark stream) char) + (when (and (char= char #\newline) + (not (random-typeout-stream-no-prompt stream))) + (funcall (device-random-typeout-line-more + (device-hunk-device + (window-hunk (random-typeout-stream-window stream)))) + stream 1))) + (t + (insert-character (random-typeout-stream-mark stream) char))))) + +(defmethod stream-write-string ((stream random-typeout-stream) string &optional start end) + (setf start (or start 0)) + (setf end (or end (length string))) + (unless (and (eql start 0) (eql end (length string))) + (setq string (subseq string start end))) + (with-slots (line-buffered-p) stream + (cond (line-buffered-p + (insert-string (random-typeout-stream-mark stream) string) + (unless (random-typeout-stream-no-prompt stream) + (let ((count (count #\newline string))) + (when count + (funcall (device-random-typeout-line-more + (device-hunk-device + (window-hunk (random-typeout-stream-window stream)))) + stream count))))) + (t + (insert-string (random-typeout-stream-mark stream) string))))) + +(defmethod stream-finish-output ((stream random-typeout-stream)) + (with-slots (line-buffered-p) stream + (cond (line-buffered-p + (random-typeout-redisplay (random-typeout-stream-window stream))) + (t + nil)))) + +(defmethod stream-force-output ((stream random-typeout-stream)) + (stream-finish-output stream)) + +(defmethod stream-line-column ((stream random-typeout-stream)) + (mark-charpos (random-typeout-stream-mark stream))) + +;;; Bitmap line-buffered support. + +;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to +;;; a line-buffered-random-typeout-stream on the bitmap. It does a lot of +;;; checking to make sure that strings of characters longer than the width of +;;; the window don't screw us. The code is a little wierd, so a brief +;;; explanation is below. +;;; +;;; The more-mark is how we tell when we will next need to more. Each time +;;; we do a more-prompt, we point the mark at the last visible character in +;;; the random typeout window. That way, when the mark is no longer +;;; DISPLAYED-P, we know it's time to do another more prompt. +;;; +;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying +;;; if there was at least one newline in the last batch of output. If we +;;; haven't done a more prompt yet (indicated by a value of T for +;;; first-more-p), then since we know the end of the buffer isn't visible, we +;;; need to do a more-prompt. If neither of the first two tests returns T, +;;; then we can only need to do a more-prompt if our more-mark has scrolled +;;; off the top of the screen. If it hasn't, everything is peechy-keen, so +;;; we scroll the screen one line and redisplay. +;;; +(defun update-bitmap-line-buffered-stream (stream newline-count) + (let* ((window (random-typeout-stream-window stream)) + (count 0)) + (when (plusp newline-count) (random-typeout-redisplay window)) + (loop + (cond ((no-text-past-bottom-p window) + (return)) + ((or (random-typeout-stream-first-more-p stream) + (not (displayed-p (random-typeout-stream-more-mark stream) + window))) + (do-bitmap-more-prompt stream) + (return)) + (t + (scroll-window window 1) + (random-typeout-redisplay window))) + (when (= (incf count) newline-count) (return))))) + +;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed +;;; in the random-typeout window. It does this by first making sure there is a +;;; line past the WINDOW-DISPLAY-END of the window. If there is, this line +;;; must be empty, and BUFFER-END-MARK must be on this line. The final test is +;;; that the window-end is displayed within the window. If it is not, then the +;;; last line wraps past the end of the window, and there is text past the +;;; bottom. +;;; +;;; Win-end is bound after the call to DISPLAYED-P because it updates the +;;; window's image moving WINDOW-DISPLAY-END. We want this updated value for +;;; the display end. +;;; +(defun no-text-past-bottom-p (window) + (let* ((window-end (window-display-end window)) + (window-end-displayed-p (displayed-p window-end window))) + (with-mark ((win-end window-end)) + (let ((one-after-end (line-offset win-end 1))) + (if one-after-end + (and (empty-line-p win-end) + (same-line-p win-end (buffer-end-mark (window-buffer window))) + window-end-displayed-p) + window-end-displayed-p))))) + +(defun reset-more-mark (stream) + (let* ((window (random-typeout-stream-window stream)) + (more-mark (random-typeout-stream-more-mark stream)) + (end (window-display-end window))) + (move-mark more-mark end) + (unless (displayed-p end window) (character-offset more-mark -1)))) + + + + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/register.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/register.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/register.lisp (revision 8058) @@ -0,0 +1,183 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Registers for holding text and positions. +;;; +;;; Written by Dave Touretzky. +;;; Modified by Bill Chiles for Hemlock consistency. +;;; +(in-package :hemlock) + + + + +;;;; Registers implementation. + +;;; Registers are named by characters. Each register refers to a mark or +;;; a cons of a region and the buffer it came from. +;;; +(defvar *registers* (make-hash-table)) + +(defun register-count () + (hash-table-count *registers*)) + +(defun register-value (reg-name) + (gethash reg-name *registers*)) + +(defsetf register-value (reg-name) (new-value) + (let ((name (gensym)) + (value (gensym)) + (old-value (gensym))) + `(let* ((,name ,reg-name) + (,value ,new-value) + (,old-value (gethash ,name *registers*))) + (when (and ,old-value (markp ,old-value)) + (delete-mark ,old-value)) + (setf (gethash ,name *registers*) ,value)))) + +(defun prompt-for-register (&optional (prompt "Register: ") must-exist) + (let ((reg-name (prompt-for-key-event :prompt prompt))) + (unless (or (not must-exist) (gethash reg-name *registers*)) + (editor-error "Register ~A is empty." reg-name)) + reg-name)) + + +(defmacro do-registers ((name value &optional sorted) &rest body) + (if sorted + (let ((sorted-regs (gensym)) + (reg (gensym))) + `(let ((,sorted-regs nil)) + (declare (list ,sorted-regs)) + (maphash #'(lambda (,name ,value) + (push (cons ,name ,value) ,sorted-regs)) + *registers*) + (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car)) + (dolist (,reg ,sorted-regs) + (let ((,name (car ,reg)) + (,value (cdr ,reg))) + ,@body)))) + `(maphash #'(lambda (,name ,value) + ,@body) + *registers*))) + + +;;; Hook to clean things up if a buffer is deleted while registers point to it. +;;; +(defun flush-reg-references-to-deleted-buffer (buffer) + (do-registers (name value) + (etypecase value + (mark (when (eq (line-buffer (mark-line value)) buffer) + (free-register name))) + (cons (free-register-value value buffer))))) +;;; +(add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer) + + +(defun free-register (name) + (let ((value (register-value name))) + (when value (free-register-value value))) + (remhash name *registers*)) + +(defun free-register-value (value &optional buffer) + (etypecase value + (mark + (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer)) + (delete-mark value))) + (cons + (when (and buffer (eq (cdr value) buffer)) + (setf (cdr value) nil))))) + + + + +;;;; Commands. + +;;; These commands all stash marks and regions with marks that point into some +;;; buffer, and they assume that the register values have the same property. +;;; + +(defcommand "Save Position" (p) + "Saves the current location in a register. Prompts for register name." + "Saves the current location in a register. Prompts for register name." + (declare (ignore p)) + (let ((reg-name (prompt-for-register))) + (setf (register-value reg-name) + (copy-mark (current-point) :left-inserting)))) + +(defcommand "Jump to Saved Position" (p) + "Moves the point to a location previously saved in a register." + "Moves the point to a location previously saved in a register." + (declare (ignore p)) + (let* ((reg-name (prompt-for-register "Jump to Register: " t)) + (val (register-value reg-name))) + (unless (markp val) + (editor-error "Register ~A does not hold a location." reg-name)) + (change-to-buffer (line-buffer (mark-line val))) + (move-mark (current-point) val))) + +(defcommand "Kill Register" (p) + "Kill a regist er. Prompts for the name." + "Kill a register. Prompts for the name." + (declare (ignore p)) + (free-register (prompt-for-register "Register to kill: "))) + +(defcommand "List Registers" (p) + "Lists all registers in a pop-up window." + "Lists all registers in a pop-up window." + (declare (ignore p)) + (with-pop-up-display (f :height (* 2 (register-count))) + (do-registers (name val :sorted) + (write-string "Reg " f) + (hemlock-ext:print-pretty-key-event name f) + (write-string ": " f) + (etypecase val + (mark + (let* ((line (mark-line val)) + (buff (line-buffer line)) + (len (line-length line))) + (format f "Line ~S, col ~S in buffer ~A~% ~A~:[~;...~]~%" + (count-lines (region (buffer-start-mark buff) val)) + (mark-column val) + (buffer-name buff) + (subseq (line-string line) 0 (min 61 len)) + (> len 60)))) + (cons + (let* ((str (region-to-string (car val))) + (nl (position #\newline str :test #'char=)) + (len (length str)) + (buff (cdr val))) + (declare (simple-string str)) + (format f "Text~@[ from buffer ~A~]~% ~A~:[~;...~]~%" + (if buff (buffer-name buff)) + (subseq str 0 (if nl (min 61 len nl) (min 61 len))) + (> len 60)))))))) + +(defcommand "Put Register" (p) + "Copies a region into a register. Prompts for register name." + "Copies a region into a register. Prompts for register name." + (declare (ignore p)) + (let ((region (current-region))) + ;; Bind the region before prompting in case the region isn't active. + (setf (register-value (prompt-for-register)) + (cons (copy-region region) (current-buffer))))) + +(defcommand "Get Register" (p) + "Copies a region from a register to the current point." + "Copies a region from a register to the current point." + (declare (ignore p)) + (let* ((reg-name (prompt-for-register "Register from which to get text: " t)) + (val (register-value reg-name))) + (unless (and (consp val) (regionp (car val))) + (editor-error "Register ~A does not hold a region." reg-name)) + (let ((point (current-point))) + (push-buffer-mark (copy-mark point)) + (insert-region (current-point) (car val)))) + (setf (last-command-type) :ephemerally-active)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/ring.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/ring.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/ring.lisp (revision 8058) @@ -0,0 +1,217 @@ +;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file defines a ring-buffer type and access functions. +;;; +(in-package :hemlock-internals) + +(defun %print-hring (obj stream depth) + (declare (ignore depth obj)) + (write-string "#" stream)) + +;;;; The ring data structure: +;;; +;;; An empty ring is indicated by an negative First value. +;;; The Bound is made (1- (- Size)) to make length work. Things are +;;; pushed at high indices first. +;;; +(defstruct (ring (:predicate ringp) + (:constructor internal-make-ring) + (:print-function %print-hring)) + "Used with Ring-Push and friends to implement ring buffers." + (first -1 :type fixnum) ;The index of the first position used. + (bound (required-argument) :type fixnum) ;The index after the last element. + delete-function ;The function to be called on deletion. + (vector (required-argument) :type simple-vector) ;The vector. + (lock (ccl:make-lock))) + +(defmacro with-ring-locked ((ring) &body body) + `(ccl:with-lock-grabbed ((ring-lock ,ring)) + ,@body)) + +;;; make-ring -- Public +;;; +;;; Make a new empty ring with some maximum size and type. +;;; +(defun make-ring (size &optional (delete-function #'identity)) + "Make a ring-buffer which can hold up to Size objects. Delete-Function + is a function which is called with each object that falls off the + end." + (unless (and (hemlock-ext:fixnump size) (> size 0)) + (error "Ring size, ~S is not a positive fixnum." size)) + (internal-make-ring :delete-function delete-function + :vector (make-array size) + :bound (1- (- size)))) + + +;;; ring-push -- Public +;;; +;;; Decrement first modulo the maximum size, delete any old +;;; element, and add the new one. +;;; +(defun ring-push (object ring) + "Push an object into a ring, deleting an element if necessary." + (with-ring-locked (ring) + (let ((first (ring-first ring)) + (vec (ring-vector ring)) + (victim 0)) + (declare (simple-vector vec) (fixnum first victim)) + (cond + ;; If zero, wrap around to end. + ((zerop first) + (setq victim (1- (length vec)))) + ;; If empty then fix up pointers. + ((minusp first) + (setf (ring-bound ring) 0) + (setq victim (1- (length vec)))) + (t + (setq victim (1- first)))) + (when (= first (ring-bound ring)) + (funcall (ring-delete-function ring) (aref vec victim)) + (setf (ring-bound ring) victim)) + (setf (ring-first ring) victim) + (setf (aref vec victim) object)))) + + +;;; ring-pop -- Public +;;; +;;; Increment first modulo the maximum size. +;;; +(defun ring-pop (ring) + "Pop an object from a ring and return it." + (with-ring-locked (ring) + (let* ((first (ring-first ring)) + (vec (ring-vector ring)) + (new (if (= first (1- (length vec))) 0 (1+ first))) + (bound (ring-bound ring))) + (declare (fixnum first new bound) (simple-vector vec)) + (cond + ((minusp bound) + (error "Cannot pop from an empty ring.")) + ((= new bound) + (setf (ring-first ring) -1 (ring-bound ring) (1- (- (length vec))))) + (t + (setf (ring-first ring) new))) + (shiftf (aref vec first) nil)))) + + +;;; ring-length -- Public +;;; +;;; Return the current and maximum size. +;;; +(defun ring-length (ring) + "Return as values the current and maximum size of a ring." + (with-ring-locked (ring) + (let ((diff (- (ring-bound ring) (ring-first ring))) + (max (length (ring-vector ring)))) + (declare (fixnum diff max)) + (values (if (plusp diff) diff (+ max diff)) max)))) + + +;;; ring-ref -- Public +;;; +;;; Do modulo arithmetic to find the correct element. +;;; +(defun ring-ref (ring index) + (declare (fixnum index)) + "Return the index'th element of a ring. This can be set with Setf." + (with-ring-locked (ring) + (let ((first (ring-first ring))) + (declare (fixnum first)) + (cond + ((and (zerop index) (not (minusp first))) + (aref (ring-vector ring) first)) + (t + (let* ((diff (- (ring-bound ring) first)) + (sum (+ first index)) + (vec (ring-vector ring)) + (max (length vec))) + (declare (fixnum diff max sum) (simple-vector vec)) + (when (or (>= index (if (plusp diff) diff (+ max diff))) + (minusp index)) + (error "Ring index ~D out of bounds." index)) + (aref vec (if (>= sum max) (- sum max) sum)))))))) + + +;;; %set-ring-ref -- Internal +;;; +;;; Setf form for ring-ref, set a ring element. +;;; +(defun %set-ring-ref (ring index value) + (declare (fixnum index)) + (with-ring-locked (ring) + (let* ((first (ring-first ring)) + (diff (- (ring-bound ring) first)) + (sum (+ first index)) + (vec (ring-vector ring)) + (max (length vec))) + (declare (fixnum diff first max) (simple-vector vec)) + (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index)) + (error "Ring index ~D out of bounds." index)) + (setf (aref vec (if (>= sum max) (- sum max) sum)) value)))) + + +(eval-when (:compile-toplevel :execute) +(defmacro 1+m (exp base) + `(if (= ,exp ,base) 0 (1+ ,exp))) +(defmacro 1-m (exp base) + `(if (zerop ,exp) ,base (1- ,exp))) +) ;eval-when (:compile-toplevel :execute) + +;;; rotate-ring -- Public +;;; +;;; Rotate a ring, blt'ing elements as necessary. +;;; +(defun rotate-ring (ring offset) + "Rotate a ring forward, i.e. second -> first, with positive offset, + or backwards with negative offset." + (declare (fixnum offset)) + (with-ring-locked (ring) + (let* ((first (ring-first ring)) + (bound (ring-bound ring)) + (vec (ring-vector ring)) + (max (length vec))) + (declare (fixnum first bound max) (simple-vector vec)) + (cond + ((= first bound) + (let ((new (rem (+ offset first) max))) + (declare (fixnum new)) + (if (minusp new) (setq new (+ new max))) + (setf (ring-first ring) new) + (setf (ring-bound ring) new))) + ((not (minusp first)) + (let* ((diff (- bound first)) + (1-max (1- max)) + (length (if (plusp diff) diff (+ max diff))) + (off (rem offset length))) + (declare (fixnum diff length off 1-max)) + (cond + ((minusp offset) + (do ((dst (1-m first 1-max) (1-m dst 1-max)) + (src (1-m bound 1-max) (1-m src 1-max)) + (cnt off (1+ cnt))) + ((zerop cnt) + (setf (ring-first ring) (1+m dst 1-max)) + (setf (ring-bound ring) (1+m src 1-max))) + (declare (fixnum dst src cnt)) + (shiftf (aref vec dst) (aref vec src) nil))) + (t + (do ((dst bound (1+m dst 1-max)) + (src first (1+m src 1-max)) + (cnt off (1- cnt))) + ((zerop cnt) + (setf (ring-first ring) src) + (setf (ring-bound ring) dst)) + (declare (fixnum dst src cnt)) + (shiftf (aref vec dst) (aref vec src) nil))))))))) + ring) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/rompsite.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/rompsite.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/rompsite.lisp (revision 8058) @@ -0,0 +1,363 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU +(ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; "Site dependent" stuff for the editor while on the IBM RT PC machine. +;;; + +(in-package :hi) + +;;;; SITE-INIT. + +;;; *key-event-history* is defined in input.lisp, but it needs to be set in +;;; SITE-INIT, since MAKE-RING doesn't exist at load time for this file. +;;; +(declaim (special *key-event-history*)) + +;;; SITE-INIT -- Internal +;;; +;;; This function is called at init time to set up any site stuff. +;;; +(defun site-init () + (defhvar "Beep Border Width" + "Width in pixels of the border area inverted by beep." + :value 20) + (defhvar "Default Window Width" + "This is used to make a window when prompting the user. The value is in + characters." + :value 80) + (defhvar "Default Window Height" + "This is used to make a window when prompting the user. The value is in + characters." + :value 24) + (defhvar "Default Initial Window Width" + "This is used when Hemlock first starts up to make its first window. + The value is in characters." + :value 80) + (defhvar "Default Initial Window Height" + "This is used when Hemlock first starts up to make its first window. + The value is in characters." + :value 24) + (defhvar "Default Initial Window X" + "This is used when Hemlock first starts up to make its first window. + The value is in pixels." + :value nil) + (defhvar "Default Initial Window Y" + "This is used when Hemlock first starts up to make its first window. + The value is in pixels." + :value nil) + (defhvar "Bell Style" + "This controls what beeps do in Hemlock. Acceptable values are :border-flash + (which is the default), :feep, :border-flash-and-feep, :flash, + :flash-and-feep, and NIL (do nothing)." + :value :border-flash) + (defhvar "Reverse Video" + "Paints white on black in window bodies, black on white in modelines." + :value nil + #+clx + :hooks #+clx '(reverse-video-hook-fun)) + (defhvar "Enter Window Hook" + "When the mouse enters an editor window, this hook is invoked. These + functions take the Hemlock Window as an argument." + :value nil) + (defhvar "Exit Window Hook" + "When the mouse exits an editor window, this hook is invoked. These + functions take the Hemlock Window as an argument." + :value nil) + (defhvar "Set Window Autoraise" + "When non-nil, setting the current window will automatically raise that + window via a function on \"Set Window Hook\". If the value is :echo-only + (the default), then only the echo area window will be raised + automatically upon becoming current." + :value :echo-only) + (defhvar "Default Font" + "The string name of the font to be used for Hemlock -- buffer text, + modelines, random typeout, etc. The font is loaded when initializing + Hemlock." + :value "*-courier-medium-r-normal--*-120-*") + (defhvar "Active Region Highlighting Font" + "The string name of the font to be used for highlighting active regions. + The font is loaded when initializing Hemlock." + :value "*-courier-medium-o-normal--*-120-*") + (defhvar "Open Paren Highlighting Font" + "The string name of the font to be used for highlighting open parens. + The font is loaded when initializing Hemlock." + :value "*-courier-bold-r-normal--*-120-*") + (defhvar "Thumb Bar Meter" + "When non-nil (the default), windows will be created to be displayed with + a ruler in the bottom border of the window." + :value t) + + (setf *key-event-history* (make-ring 60)) + nil) + + + +;;;; Some generally useful file-system functions. + +;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or +;;; relative to default-dir, merging it as appropriate and returning a definite +;;; directory pathname. +;;; +;;; This function isn't really needed anymore now that merge-pathnames does +;;; this, but the semantics are slightly different. So it's easier to just +;;; keep this around instead of changing all the uses of it. +;;; +(defun merge-relative-pathnames (pathname default-directory) + "Merges pathname with default-directory. If pathname is not absolute, it + is assumed to be relative to default-directory. The result is always a + directory." + (let ((pathname (merge-pathnames pathname default-directory))) + (if (directoryp pathname) + pathname + (pathname (concatenate 'simple-string + (namestring pathname) + "/"))))) + +(defun directoryp (pathname) + "Returns whether pathname names a directory, that is whether it has no + name and no type components." + (not (or (pathname-name pathname) (pathname-type pathname)))) + + + + +;;;; I/O specials and initialization + +;;; File descriptor for the terminal. +;;; +(defvar *editor-file-descriptor*) + +(declaim (special *editor-input* *real-editor-input*)) + +(declaim (declaration values)) +(declaim (special *default-font-family*)) + +;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would +;;; assume it to be special, issuing a nasty warning. +;;; +(defconstant font-map-size 32) + + + +;;;; HEMLOCK-BEEP. + +(defvar *beep-function* #'(lambda () (print "BEEP!"))) + +(defun beep (&optional (stream *terminal-io*)) + (funcall *beep-function* stream)) + + + +;;;; Line Wrap Char. + +(defvar *line-wrap-char* #\! + "The character to be displayed to indicate wrapped lines.") + + + +;;;; Current terminal character translation. + +(defvar termcap-file "/etc/termcap") + + + + +;;;; Event scheduling. + +;;; The time queue provides a ROUGH mechanism for scheduling events to +;;; occur after a given amount of time has passed, optionally repeating +;;; using the given time as an interval for rescheduling. When the input +;;; loop goes around, it will check the current time and process all events +;;; that should have happened before or at this time. The function gets +;;; called on the number of seconds that have elapsed since it was last +;;; called. +;;; +;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the +;;; editor stream in methods. +;;; +;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces. + +(defstruct (tq-event (:print-function print-tq-event) + (:constructor make-tq-event + (time last-time interval function))) + time ; When the event should happen. + last-time ; When the event was scheduled. + interval ; When non-nil, how often the event should happen. + function) ; What to do. + +(defun print-tq-event (obj stream n) + (declare (ignore n)) + (format stream "#" (tq-event-function obj))) + +(defvar *time-queue* nil + "This is the time priority queue used in Hemlock input streams for event + scheduling.") + +;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*. +;;; Event is inserted before the first element that it is less than (which +;;; means that it gets inserted after elements that are the same). +;;; *time-queue* is returned. +;;; +(defun queue-time-event (event) + (let ((time (tq-event-time event))) + (if *time-queue* + (if (< time (tq-event-time (car *time-queue*))) + (push event *time-queue*) + (do ((prev *time-queue* rest) + (rest (cdr *time-queue*) (cdr rest))) + ((or (null rest) + (< time (tq-event-time (car rest)))) + (push event (cdr prev)) + *time-queue*))) + (push event *time-queue*)))) + +;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for +;;; the next event to happen. +;;; +(defun next-scheduled-event-wait () + (if *time-queue* + (let ((wait (round (- (tq-event-time (car *time-queue*)) + (get-internal-real-time)) + internal-time-units-per-second))) + (if (plusp wait) wait 0)))) + +;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose +;;; time has come. If we run out of events, or there are none, then we get +;;; out. If we popped an event whose time hasn't come, we push it back on the +;;; queue. Each function is called on how many seconds, roughly, went by since +;;; the last time it was called (or scheduled). If it has an interval, we +;;; re-queue it. While invoking the function, bind *time-queue* to nothing in +;;; case the event function tries to read off *editor-input*. +;;; +(defun invoke-scheduled-events () + (let ((time (get-internal-real-time))) + (loop + (unless *time-queue* (return)) + (let* ((event (car *time-queue*)) + (event-time (tq-event-time event))) + (cond ((>= time event-time) + (let ((*time-queue* nil)) + (funcall (tq-event-function event) + (round (- time (tq-event-last-time event)) + internal-time-units-per-second))) + (hemlock-ext:without-interrupts + (let ((interval (tq-event-interval event))) + (when interval + (setf (tq-event-time event) (+ time interval)) + (setf (tq-event-last-time event) time) + (pop *time-queue*) + (queue-time-event event))))) + (t (return))))))) + +(defun schedule-event (time function &optional (repeat t)) + "This causes function to be called after time seconds have passed, + optionally repeating every time seconds. This is a rough mechanism + since commands can take an arbitrary amount of time to run; the function + will be called at the first possible moment after time has elapsed. + Function takes the time that has elapsed since the last time it was + called (or since it was scheduled for the first invocation)." + (let ((now (get-internal-real-time)) + (itime (* internal-time-units-per-second time))) + (queue-time-event (make-tq-event (+ itime now) now (if repeat itime) + function)))) + +(defun remove-scheduled-event (function) + "Removes function queued with SCHEDULE-EVENT." + (setf *time-queue* (delete function *time-queue* :key #'tq-event-function))) + + + + +;;;; Editor sleeping. + +(defun editor-sleep (time) + "Sleep for approximately Time seconds." + (unless (or (zerop time) (listen-editor-input *editor-input*)) + ;(internal-redisplay) + (sleep-for-time time) + nil)) + +(defun sleep-for-time (time) + (timed-wait-for-key-event *editor-input* time)) + + + +;;;; Function description and defined-from. + +;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It +;;; returns a pathname for the file the function was defined in. If it was +;;; not defined in some file, then nil is returned. +;;; +(defun fun-defined-from-pathname (function) + "Takes a symbol or function and returns the pathname for the file the + function was defined in. If it was not defined in some file, nil is + returned." + #+CMU + (flet ((frob (code) + (let ((info (kernel:%code-debug-info code))) + (when info + (let ((sources (c::debug-info-source info))) + (when sources + (let ((source (car sources))) + (when (eq (c::debug-source-from source) :file) + (c::debug-source-name source))))))))) + (typecase function + (symbol (fun-defined-from-pathname (fdefinition function))) + (kernel:byte-closure + (fun-defined-from-pathname (kernel:byte-closure-function function))) + (kernel:byte-function + (frob (c::byte-function-component function))) + (function + (frob (kernel:function-code-header (kernel:%function-self function)))) + (t nil))) + #+openmcl + (flet ((true-namestring (path) (namestring (truename path)))) + (typecase function + (function (fun-defined-from-pathname (ccl::function-name function))) + (symbol (let* ((info (ccl::%source-files function))) + (if (atom info) + (true-namestring info) + (let* ((finfo (assq 'function info))) + (when finfo + (true-namestring + (if (atom finfo) + finfo + (car finfo))))))))))) + + +(defvar *editor-describe-stream* + (#+CMU system:make-indenting-stream #-CMU progn *standard-output*)) + +;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to +;;; work. These apparently work fine for DESCRIBE, for which they were defined, +;;; but not in general. It seems they don't indent initial text, only that +;;; following a newline, so inside our use of INDENTING-FURTHER, we need some +;;; form before the WRITE-STRING. To get this to work, I had to remove the ~% +;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with +;;; the ~% caused an extra blank line. Possibly I should not have glommed onto +;;; this hack whose interface comes from three different packages, but it did +;;; the right thing .... +;;; +;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream +;;; is based on whatever *standard-output* is when we are called. +;;; +(defun editor-describe-function (fun sym) + "Calls DESCRIBE on fun. If fun is compiled, and its original name is not sym, + then this also outputs any 'function documentation for sym to + *standard-output*." + (declare (ignorable sym)) + (describe fun) + (let ((doc (documentation sym 'function))) + (when doc + (format *standard-output* "~%Function documentation for ~S:~&~%" sym) + (write-string doc *standard-output*)))) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/search1.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/search1.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/search1.lisp (revision 8058) @@ -0,0 +1,668 @@ +;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Searching and replacing functions for Hemlock. +;;; Originally written by Skef Wholey, Rewritten by Rob MacLachlan. +;;; + +(in-package :hemlock-internals) + + + +;;; The search pattern structure is used only by simple searches, more +;;; complex ones make structures which include it. + +(defstruct (search-pattern (:print-function %print-search-pattern) + (:constructor internal-make-search-pattern)) + kind ; The kind of pattern to search for. + direction ; The direction to search in. + pattern ; The search pattern to use. + search-function ; The function to call to search. + reclaim-function) ; The function to call to reclaim this pattern. + +(setf (documentation 'search-pattern-p 'function) + "Returns true if its argument is a Hemlock search-pattern object, + Nil otherwise.") + +(defun %print-search-pattern (object stream depth) + (let ((*print-level* (and *print-level* (- *print-level* depth))) + (*print-case* :downcase)) + (declare (special *print-level* *print-case*)) + (write-string "# stream) + (terpri stream))) + +(defvar *search-pattern-experts* (make-hash-table :test #'eq) + "Holds an eq hashtable which associates search kinds with the functions + that know how to make patterns of that kind.") +(defvar *search-pattern-documentation* () + "A list of all the kinds of search-pattern that are defined.") + +;;; define-search-kind -- Internal +;;; +;;; This macro is used to define a new kind of search pattern. Kind +;;; is the kind of search pattern to define. Lambda-list is the argument +;;; list for the expert-function to be built and forms it's body. +;;; The arguments passed are the direction, the pattern, and either +;;; an old search-pattern of the same type or nil. Documentation +;;; is put on the search-pattern-documentation property of the kind +;;; keyword. +;;; +(defmacro define-search-kind (kind lambda-list documentation &body forms) + (let ((dummy #-CLISP (gensym) #+CLISP (gentemp (format nil ".search-kind.~A" kind)))) + `(progn + (push ,documentation *search-pattern-documentation*) + (defun ,dummy () + (setf (gethash ,kind *search-pattern-experts*) + #'(lambda ,lambda-list ,@forms))) + (,dummy)))) + + +;;; new-search-pattern -- Public +;;; +;;; This function deallocates any old search-pattern and then dispatches +;;; to the correct expert. +;;; +(defun new-search-pattern (kind direction pattern &optional + result-search-pattern) + "Makes a new Hemlock search pattern of kind Kind to search direction + using Pattern. Direction is either :backward or :forward. + If supplied, result-search-pattern is a pattern to destroy to make + the new one. The variable *search-pattern-documentation* contains + documentation for each kind." + (unless (or (eq direction :forward) (eq direction :backward)) + (error "~S is not a legal search direction." direction)) + (when result-search-pattern + (funcall (search-pattern-reclaim-function result-search-pattern) + result-search-pattern) + (unless (eq kind (search-pattern-kind result-search-pattern)) + (setq result-search-pattern nil))) + (let ((expert (gethash kind *search-pattern-experts*))) + (unless expert + (error "~S is not a defined search pattern kind." kind)) + (funcall expert direction pattern result-search-pattern))) + +;;;; stuff to allocate and de-allocate simple-vectors search-char-code-limit +;;;; in length. + +(defvar *spare-search-vectors* ()) +(eval-when (:compile-toplevel :execute) +(defmacro new-search-vector () + `(if *spare-search-vectors* + (pop *spare-search-vectors*) + (make-array search-char-code-limit))) + +(defmacro dispose-search-vector (vec) + `(push ,vec *spare-search-vectors*)) +); eval-when (:compile-toplevel :execute) + + +;;;; macros used by various search kinds: + +;;; search-once-forward-macro -- Internal +;;; +;;; Passes search-fun strings, starts and lengths to do a forward +;;; search. The other-args are passed through to the searching +;;; function after after everything else The search-fun is +;;; expected to return NIL if nothing is found, or it index where the +;;; match ocurred. Something non-nil is returned if something is +;;; found and line and start are set to where it was found. +;;; +(defmacro search-once-forward-macro (line start search-fun &rest other-args) + `(do* ((l ,line) + (chars (line-chars l) (line-chars l)) + (len (length chars) (length chars)) + (start-pos ,start 0) + (index 0)) + (()) + (declare (simple-string chars) (fixnum start-pos len) + (type (or fixnum null) index)) + (setq index (,search-fun chars start-pos len ,@other-args)) + (when index + (setq ,start index ,line l) + (return t)) + (setq l (line-next l)) + (when (null l) (return nil)))) + + +;;; search-once-backward-macro -- Internal +;;; +;;; Like search-once-forward-macro, except it goes backwards. Length +;;; is not passed to the search function, since it won't need it. +;;; +(defmacro search-once-backward-macro (line start search-fun &rest other-args) + `(do* ((l ,line) + (chars (line-chars l) (line-chars l)) + (start-pos (1- ,start) (1- (length chars))) + (index 0)) + (()) + (declare (simple-string chars) (fixnum start-pos) + (type (or fixnum null) index)) + (setq index (,search-fun chars start-pos ,@other-args)) + (when index + (setq ,start index ,line l) + (return t)) + (setq l (line-previous l)) + (when (null l) (return nil)))) + + + +;;;; String Searches. +;;; +;;; We use the Boyer-Moore algorithm for string searches. +;;; + +;;; sensitive-string-search-macro -- Internal +;;; +;;; This macro does a case-sensitive Boyer-Moore string search. +;;; +;;; Args: +;;; String - The string to search in. +;;; Start - The place to start searching at. +;;; Length - NIL if going backward, the length of String if going forward. +;;; Pattern - A simple-vector of characters. A simple-vector is used +;;; rather than a string because it is believed that simple-vector access +;;; will be faster in most implementations. +;;; Patlen - The length of Pattern. +;;; Last - (1- Patlen) +;;; Jumps - The jump vector as given by compute-boyer-moore-jumps +;;; +/- - The function to increment with, either + (forward) or - +;;; (backward) +;;; -/+ - Like +/-, only the other way around. +(eval-when (:compile-toplevel :execute) +(defmacro sensitive-string-search-macro (string start length pattern patlen + last jumps +/- -/+) + `(do ((scan (,+/- ,start ,last)) + (patp ,last)) + (,(if length `(>= scan ,length) '(minusp scan))) + (declare (fixnum scan patp)) + (let ((char (schar ,string scan))) + (cond + ((char= char (svref ,pattern patp)) + (if (zerop patp) + (return scan) + (setq scan (,-/+ scan 1) patp (1- patp)))) + (t + ;; If mismatch consult jump table to find amount to skip. + (let ((jump (svref ,jumps (search-char-code char)))) + (declare (fixnum jump)) + (if (> jump (- ,patlen patp)) + (setq scan (,+/- scan jump)) + (setq scan (,+/- scan (- ,patlen patp))))) + (setq patp ,last)))))) + + +;;; insensitive-string-search-macro -- Internal +;;; +;;; This macro is very similar to the case sensitive one, except that +;;; we do the search for a hashed string, and then when we find a match +;;; we compare the uppercased search string with the found string uppercased +;;; and only say we win when they match too. +;;; +(defmacro insensitive-string-search-macro (string start length pattern + folded-string patlen last + jumps +/- -/+) + `(do ((scan (,+/- ,start ,last)) + (patp ,last)) + (,(if length `(>= scan ,length) '(minusp scan))) + (declare (fixnum scan patp)) + (let ((hash (search-hash-code (schar ,string scan)))) + (declare (fixnum hash)) + (cond + ((= hash (the fixnum (svref ,pattern patp))) + (if (zerop patp) + (if (do ((i ,last (1- i))) + (()) + (when (char/= + (search-char-upcase (schar ,string (,+/- scan i))) + (schar ,folded-string i)) + (return nil)) + (when (zerop i) (return t))) + (return scan) + (setq scan (,+/- scan ,patlen) patp ,last)) + (setq scan (,-/+ scan 1) patp (1- patp)))) + (t + ;; If mismatch consult jump table to find amount to skip. + (let ((jump (svref ,jumps hash))) + (declare (fixnum jump)) + (if (> jump (- ,patlen patp)) + (setq scan (,+/- scan jump)) + (setq scan (,+/- scan (- ,patlen patp))))) + (setq patp ,last)))))) + + +;;;; Searching for strings with newlines in them: +;;; +;;; Due to the buffer representation, search-strings with embedded +;;; newlines need to be special-cased. What we do is break +;;; the search string up into lines and then searching for a line with +;;; the correct prefix. This is actually a faster search. +;;; For this one we just have one big hairy macro conditionalized for +;;; both case-sensitivity and direction. Have fun!! + +;;; newline-search-macro -- Internal +;;; +;;; Do a search for a string containing newlines. Line is the line +;;; to start on, and Start is the position to start at. Pattern and +;;; optionally Pattern2, are simple-vectors of things that represent +;;; each line in the pattern, and are passed to Test-Fun. Pattern +;;; must contain simple-strings so we can take the length. Test-Fun is a +;;; thing to compare two strings and see if they are equal. Forward-p +;;; tells whether to go forward or backward. +;;; +(defmacro newline-search-macro (line start test-fun pattern forward-p + &optional pattern2) + `(let* ((patlen (length ,pattern)) + (first (svref ,pattern 0)) + (firstlen (length first)) + (l ,line) + (chars (line-chars l)) + (len (length chars)) + ,@(if pattern2 `((other (svref ,pattern2 0))))) + (declare (simple-string first chars) (fixnum firstlen patlen len)) + ,(if forward-p + ;; If doing a forward search, go to the next line if we could not + ;; match due to the start position. + `(when (< (- len ,start) firstlen) + (setq l (line-next l))) + ;; If doing a backward search, go to the previous line if the current + ;; line could not match the last line in the pattern, and then go + ;; back the 1- number of lines in the pattern to avoid a possible + ;; match across the starting point. + `(let ((1-len (1- patlen))) + (declare (fixnum 1-len)) + (when (< ,start (length (the simple-string + (svref ,pattern 1-len)))) + (setq l (line-previous l))) + (dotimes (i 1-len) + (when (null l) (return nil)) + (setq l (line-previous l))))) + (do* () + ((null l)) + (setq chars (line-chars l) len (length chars)) + ;; If the end of this line is the first line in the pattern then check + ;; to see if the other lines match. + (when (and (>= len firstlen) + (,test-fun chars first other + :start1 (- len firstlen) :end1 len + :end2 firstlen)) + (when + (do ((m (line-next l) (line-next m)) + (i 2 (1+ i)) + (next (svref ,pattern 1) (svref ,pattern i)) + ,@(if pattern2 + `((another (svref ,pattern2 1) + (svref ,pattern2 i)))) + (len 0) + (nextlen 0) + (chars "")) + ((null m)) + (declare (simple-string next chars) (fixnum len nextlen i)) + (setq chars (line-chars m) nextlen (length next) + len (length chars)) + ;; When on last line of pattern, check if prefix of line. + (when (= i patlen) + (return (and (>= len nextlen) + (,test-fun chars next another :end1 nextlen + :end2 nextlen)))) + (unless (,test-fun chars next another :end1 len + :end2 nextlen) + (return nil))) + (setq ,line l ,start (- len firstlen)) + (return t))) + ;; If not, try the next line + (setq l ,(if forward-p '(line-next l) '(line-previous l)))))) + + +;;;; String-comparison macros that are passed to newline-search-macro + +;;; case-sensitive-test-fun -- Internal +;;; +;;; Just thows away the extra arg and calls string=. +;;; +(defmacro case-sensitive-test-fun (string1 string2 ignore &rest keys) + (declare (ignore ignore)) + `(string= ,string1 ,string2 ,@keys)) + +;;; case-insensitive-test-fun -- Internal +;;; +;;; First compare the characters hashed with hashed-string2 and then +;;; only if they agree do an actual compare with case-folding. +;;; +(defmacro case-insensitive-test-fun (string1 string2 hashed-string2 + &key end1 (start1 0) end2) + `(when (= (- ,end1 ,start1) ,end2) + (do ((i 0 (1+ i))) + ((= i ,end2) + (dotimes (i ,end2 t) + (when (char/= (search-char-upcase (schar ,string1 (+ ,start1 i))) + (schar ,string2 i)) + (return nil)))) + (when (/= (search-hash-code (schar ,string1 (+ ,start1 i))) + (svref ,hashed-string2 i)) + (return nil))))) +); eval-when (:compile-toplevel :execute) + + +;;; compute-boyer-moore-jumps -- Internal +;;; +;;; Compute return a jump-vector to do a Boyer-Moore search for +;;; the "string" of things in Vector. Access-fun is a function +;;; that aref's vector and returns a number. +;;; +(defun compute-boyer-moore-jumps (vec access-fun) + (declare (simple-vector vec)) + (let ((jumps (new-search-vector)) + (len (length vec))) + (declare (simple-vector jumps)) + (when (zerop len) (error "Zero length search string not allowed.")) + ;; The default jump is the length of the search string. + (dotimes (i search-char-code-limit) + (setf (aref jumps i) len)) + ;; For chars in the string the jump is the distance from the end. + (dotimes (i len) + (setf (aref jumps (funcall access-fun vec i)) (- len i 1))) + jumps)) + + +;;;; Case insensitive searches + +;;; In order to avoid case folding, we do a case-insensitive hash of +;;; each character. We then search for string in this translated +;;; character set, and reject false successes by checking of the found +;;; string is string-equal the the original search string. +;;; + +(defstruct (string-insensitive-search-pattern + (:include search-pattern) + (:conc-name string-insensitive-) + (:print-function %print-search-pattern)) + jumps + hashed-string + folded-string) + +;;; Search-Hash-String -- Internal +;;; +;;; Return a simple-vector containing the search-hash-codes of the +;;; characters in String. +;;; +(defun search-hash-string (string) + (declare (simple-string string)) + (let* ((len (length string)) + (result (make-array len))) + (declare (fixnum len) (simple-vector result)) + (dotimes (i len result) + (setf (aref result i) (search-hash-code (schar string i)))))) + +;;; make-insensitive-newline-pattern -- Internal +;;; +;;; Make bash in fields in a string-insensitive-search-pattern to +;;; do a search for a string with newlines in it. +;;; +(defun make-insensitive-newline-pattern (pattern folded-string) + (declare (simple-string folded-string)) + (let* ((len (length folded-string)) + (num (1+ (count #\newline folded-string :end len))) + (hashed (make-array num)) + (folded (make-array num))) + (declare (simple-vector hashed folded) (fixnum len num)) + (do ((prev 0 nl) + (i 0 (1+ i)) + (nl (position #\newline folded-string :end len) + (position #\newline folded-string :start nl :end len))) + ((null nl) + (let ((piece (subseq folded-string prev len))) + (setf (aref folded i) piece) + (setf (aref hashed i) (search-hash-string piece)))) + (let ((piece (subseq folded-string prev nl))) + (setf (aref folded i) piece) + (setf (aref hashed i) (search-hash-string piece))) + (incf nl)) + (setf (string-insensitive-folded-string pattern) folded + (string-insensitive-hashed-string pattern) hashed))) + + + +(define-search-kind :string-insensitive (direction pattern old) + ":string-insensitive - Pattern is a string to do a case-insensitive + search for." + (unless old (setq old (make-string-insensitive-search-pattern))) + (setf (search-pattern-kind old) :string-insensitive + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern) + (let* ((folded-string (string-upcase pattern))) + (declare (simple-string folded-string)) + (cond + ((find #\newline folded-string) + (make-insensitive-newline-pattern old folded-string) + (setf (search-pattern-search-function old) + (if (eq direction :forward) + #'insensitive-find-newline-once-forward-method + #'insensitive-find-newline-once-backward-method)) + (setf (search-pattern-reclaim-function old) #'identity)) + (t + (case direction + (:forward + (setf (search-pattern-search-function old) + #'insensitive-find-string-once-forward-method)) + (t + (setf (search-pattern-search-function old) + #'insensitive-find-string-once-backward-method) + (nreverse folded-string))) + (let ((hashed-string (search-hash-string folded-string))) + (setf (string-insensitive-hashed-string old) hashed-string + (string-insensitive-folded-string old) folded-string) + (setf (string-insensitive-jumps old) + (compute-boyer-moore-jumps hashed-string #'svref)) + (setf (search-pattern-reclaim-function old) + #'(lambda (p) + (dispose-search-vector (string-insensitive-jumps p)))))))) + old) + + +(defun insensitive-find-string-once-forward-method (pattern line start) + (let* ((hashed-string (string-insensitive-hashed-string pattern)) + (folded-string (string-insensitive-folded-string pattern)) + (jumps (string-insensitive-jumps pattern)) + (patlen (length hashed-string)) + (last (1- patlen))) + (declare (simple-vector jumps hashed-string) (simple-string folded-string) + (fixnum patlen last)) + (when (search-once-forward-macro + line start insensitive-string-search-macro + hashed-string folded-string patlen last jumps + -) + (values line start patlen)))) + +(defun insensitive-find-string-once-backward-method (pattern line start) + (let* ((hashed-string (string-insensitive-hashed-string pattern)) + (folded-string (string-insensitive-folded-string pattern)) + (jumps (string-insensitive-jumps pattern)) + (patlen (length hashed-string)) + (last (1- patlen))) + (declare (simple-vector jumps hashed-string) (simple-string folded-string) + (fixnum patlen last)) + (when (search-once-backward-macro + line start insensitive-string-search-macro + nil hashed-string folded-string patlen last jumps - +) + (values line (- start last) patlen)))) + +(eval-when (:compile-toplevel :execute) +(defmacro def-insensitive-newline-search-method (name direction) + `(defun ,name (pattern line start) + (let* ((hashed (string-insensitive-hashed-string pattern)) + (folded-string (string-insensitive-folded-string pattern)) + (patlen (length (the string (search-pattern-pattern pattern))))) + (declare (simple-vector hashed folded-string)) + (when (newline-search-macro line start case-insensitive-test-fun + folded-string ,direction hashed) + (values line start patlen))))) +); eval-when (:compile-toplevel :execute) + +(def-insensitive-newline-search-method + insensitive-find-newline-once-forward-method t) +(def-insensitive-newline-search-method + insensitive-find-newline-once-backward-method nil) + + +;;;; And Snore, case sensitive. +;;; +;;; This is horribly repetitive, but if I introduce another level of +;;; macroexpansion I will go Insaaaane.... +;;; +(defstruct (string-sensitive-search-pattern + (:include search-pattern) + (:conc-name string-sensitive-) + (:print-function %print-search-pattern)) + string + jumps) + +;;; make-sensitive-newline-pattern -- Internal +;;; +;;; The same, only more sensitive (it hurts when you do that...) +;;; +(defun make-sensitive-newline-pattern (pattern string) + (declare (simple-vector string)) + (let* ((string (coerce string 'simple-string)) + (len (length string)) + (num (1+ (count #\newline string :end len))) + (sliced (make-array num))) + (declare (simple-string string) (simple-vector sliced) (fixnum len num)) + (do ((prev 0 nl) + (i 0 (1+ i)) + (nl (position #\newline string :end len) + (position #\newline string :start nl :end len))) + ((null nl) + (setf (aref sliced i) (subseq string prev len))) + (setf (aref sliced i) (subseq string prev nl)) + (incf nl)) + (setf (string-sensitive-string pattern) sliced))) + + + +(define-search-kind :string-sensitive (direction pattern old) + ":string-sensitive - Pattern is a string to do a case-sensitive + search for." + (unless old (setq old (make-string-sensitive-search-pattern))) + (setf (search-pattern-kind old) :string-sensitive + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern) + (let* ((string (coerce pattern 'simple-vector))) + (declare (simple-vector string)) + (cond + ((find #\newline string) + (make-sensitive-newline-pattern old string) + (setf (search-pattern-search-function old) + (if (eq direction :forward) + #'sensitive-find-newline-once-forward-method + #'sensitive-find-newline-once-backward-method)) + (setf (search-pattern-reclaim-function old) #'identity)) + (t + (case direction + (:forward + (setf (search-pattern-search-function old) + #'sensitive-find-string-once-forward-method)) + (t + (setf (search-pattern-search-function old) + #'sensitive-find-string-once-backward-method) + (nreverse string))) + (setf (string-sensitive-string old) string) + (setf (string-sensitive-jumps old) + (compute-boyer-moore-jumps + string #'(lambda (v i) (char-code (svref v i))))) + (setf (search-pattern-reclaim-function old) + #'(lambda (p) + (dispose-search-vector (string-sensitive-jumps p))))))) + old) + + + +(defun sensitive-find-string-once-forward-method (pattern line start) + (let* ((string (string-sensitive-string pattern)) + (jumps (string-sensitive-jumps pattern)) + (patlen (length string)) + (last (1- patlen))) + (declare (simple-vector jumps string) (fixnum patlen last)) + (when (search-once-forward-macro + line start sensitive-string-search-macro + string patlen last jumps + -) + (values line start patlen)))) + +(defun sensitive-find-string-once-backward-method (pattern line start) + (let* ((string (string-sensitive-string pattern)) + (jumps (string-sensitive-jumps pattern)) + (patlen (length string)) + (last (1- patlen))) + (declare (simple-vector jumps string) (fixnum patlen last)) + (when (search-once-backward-macro + line start sensitive-string-search-macro + nil string patlen last jumps - +) + (values line (- start last) patlen)))) + +(eval-when (:compile-toplevel :execute) +(defmacro def-sensitive-newline-search-method (name direction) + `(defun ,name (pattern line start) + (let* ((string (string-sensitive-string pattern)) + (patlen (length (the string (search-pattern-pattern pattern))))) + (declare (simple-vector string)) + (when (newline-search-macro line start case-sensitive-test-fun + string ,direction) + (values line start patlen))))) +); eval-when (:compile-toplevel :execute) + +(def-sensitive-newline-search-method + sensitive-find-newline-once-forward-method t) +(def-sensitive-newline-search-method + sensitive-find-newline-once-backward-method nil) + + +(defun find-pattern (mark search-pattern) + "Find a match of Search-Pattern starting at Mark. Mark is moved to + point before the match and the number of characters matched is returned. + If there is no match for the pattern then Mark is not modified and NIL + is returned." + (close-line) + (multiple-value-bind (line start matched) + (funcall (search-pattern-search-function search-pattern) + search-pattern (mark-line mark) + (mark-charpos mark)) + (when matched + (move-to-position mark start line) + matched))) + +;;; replace-pattern -- Public +;;; +;;; +(defun replace-pattern (mark search-pattern replacement &optional n) + "Replaces N occurrences of the Search-Pattern with the Replacement string + in the text starting at the given Mark. If N is Nil, all occurrences + following the Mark are replaced." + (close-line) + (do* ((replacement (coerce replacement 'simple-string)) + (new (length (the simple-string replacement))) + (fun (search-pattern-search-function search-pattern)) + (forward-p (eq (search-pattern-direction search-pattern) :forward)) + (n (if n (1- n) -1) (1- n)) + (m (copy-mark mark :temporary)) line start matched) + (()) + (multiple-value-setq (line start matched) + (funcall fun search-pattern (mark-line m) (mark-charpos m))) + (unless matched (return m)) + (setf (mark-line m) line (mark-charpos m) start) + (delete-characters m matched) + (insert-string m replacement) + (when forward-p (character-offset m new)) + (when (zerop n) (return m)) + (close-line))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/search2.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/search2.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/search2.lisp (revision 8058) @@ -0,0 +1,211 @@ +;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; More searching function for Hemlock. This file contains the stuff +;;; to implement the various kinds of character searches. +;;; +;;; Written by Rob MacLachlan +;;; + +(in-package :hemlock-internals) + +;;;; Character and Not-Character search kinds: + +(eval-when (:compile-toplevel :execute) +(defmacro forward-character-search-macro (string start length char test) + `(position ,char ,string :start ,start :end ,length :test ,test)) + +(defmacro backward-character-search-macro (string start char test) + `(position ,char ,string :end (1+ ,start) :test ,test :from-end t)) + +(defmacro define-character-search-method (name search macro test) + `(defun ,name (pattern line start) + (let ((char (search-pattern-pattern pattern))) + (when (,search line start ,macro char ,test) + (values line start 1))))) +); eval-when (:compile-toplevel :execute) + +(define-character-search-method find-character-once-forward-method + search-once-forward-macro forward-character-search-macro #'char=) +(define-character-search-method find-not-character-once-forward-method + search-once-forward-macro forward-character-search-macro #'char/=) +(define-character-search-method find-character-once-backward-method + search-once-backward-macro backward-character-search-macro #'char=) +(define-character-search-method find-not-character-once-backward-method + search-once-backward-macro backward-character-search-macro #'char/=) + + + +(define-search-kind :character (direction pattern old) + ":character - Pattern is a character to search for." + (unless old (setq old (internal-make-search-pattern))) + (setf (search-pattern-kind old) :character + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern + (search-pattern-reclaim-function old) #'identity + (search-pattern-search-function old) + (if (eq direction :forward) + #'find-character-once-forward-method + #'find-character-once-backward-method)) + old) + +(define-search-kind :not-character (direction pattern old) + ":not-character - Find the first character which is not Char= to Pattern." + (unless old (setq old (internal-make-search-pattern))) + (setf (search-pattern-kind old) :not-character + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern + (search-pattern-reclaim-function old) #'identity + (search-pattern-search-function old) + (if (eq direction :forward) + #'find-not-character-once-forward-method + #'find-not-character-once-backward-method)) + old) + + +;;;; Character set searching. +;;; +;;; These functions implement the :test, :test-not, :any and :not-any +;;; search-kinds. + +;;; The Character-Set abstraction is used to hide somewhat the fact that +;;; we are using %Sp-Find-Character-With-Attribute to implement the +;;; character set searches. + +(defvar *free-character-sets* () + "A list of unused character-set objects for use by the Hemlock searching + primitives.") + +;;; Create-Character-Set -- Internal +;;; +;;; Create-Character-Set returns a character-set which will search +;;; for no character. +;;; +(defun create-character-set () + (let ((set (or (pop *free-character-sets*) + (make-array 256 :element-type '(mod 256))))) + (declare (type (simple-array (mod 256)) set)) + (dotimes (i search-char-code-limit) + (setf (aref set i) 0)) + set)) + +;;; Add-Character-To-Set -- Internal +;;; +;;; Modify the character-set Set to succeed for Character. +;;; +(declaim (inline add-character-to-set)) +(defun add-character-to-set (character set) + (setf (aref (the (simple-array (mod 256)) set) + (search-char-code character)) + 1)) + +;;; Release-Character-Set -- Internal +;;; +;;; Release the storage for the character set Set. +;;; +(defun release-character-set (set) + (push set *free-character-sets*)) + +(eval-when (:compile-toplevel :execute) +;;; Forward-Set-Search-Macro -- Internal +;;; +;;; Do a search for some character in Set in String starting at Start +;;; and ending at End. +;;; +(defmacro forward-set-search-macro (string start last set) + `(%sp-find-character-with-attribute ,string ,start ,last ,set 1)) + +;;; Backward-Set-Search-Macro -- Internal +;;; +;;; Like forward-set-search-macro, only :from-end, and start is +;;; implicitly 0. +;;; +(defmacro backward-set-search-macro (string last set) + `(%sp-reverse-find-character-with-attribute ,string 0 (1+ ,last) ,set 1)) +); eval-when (:compile-toplevel :execute) + + +(defstruct (set-search-pattern + (:include search-pattern) + (:print-function %print-search-pattern)) + set) + +(eval-when (:compile-toplevel :execute) +(defmacro define-set-search-method (name search macro) + `(defun ,name (pattern line start) + (let ((set (set-search-pattern-set pattern))) + (when (,search line start ,macro set) + (values line start 1))))) +); eval-when (:compile-toplevel :execute) + +(define-set-search-method find-set-once-forward-method + search-once-forward-macro forward-set-search-macro) + +(define-set-search-method find-set-once-backward-method + search-once-backward-macro backward-set-search-macro) + +(defun frob-character-set (pattern direction old kind) + (unless old (setq old (make-set-search-pattern))) + (setf (search-pattern-kind old) kind + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern + (search-pattern-search-function old) + (if (eq direction :forward) + #'find-set-once-forward-method + #'find-set-once-backward-method) + (search-pattern-reclaim-function old) + #'(lambda (x) (release-character-set (set-search-pattern-set x)))) + old) + + +(define-search-kind :test (direction pattern old) + ":test - Find the first character which satisfies the test function Pattern. + Pattern must be a function of its argument only." + (setq old (frob-character-set pattern direction old :test)) + (let ((set (create-character-set))) + (dotimes (i search-char-code-limit) + (when (funcall pattern (code-char i)) + (add-character-to-set (code-char i) set))) + (setf (set-search-pattern-set old) set)) + old) + + +(define-search-kind :test-not (direction pattern old) + ":test-not - Find the first character which does not satisfy the + test function Pattern. Pattern must be a function of its argument only." + (setq old (frob-character-set pattern direction old :test-not)) + (let ((set (create-character-set))) + (dotimes (i search-char-code-limit) + (unless (funcall pattern (code-char i)) + (add-character-to-set (code-char i) set))) + (setf (set-search-pattern-set old) set)) + old) + +(define-search-kind :any (direction pattern old) + ":any - Find the first character which is the string Pattern." + (declare (string pattern)) + (setq old (frob-character-set pattern direction old :any)) + (let ((set (create-character-set))) + (dotimes (i (length pattern)) + (add-character-to-set (char pattern i) set)) + (setf (set-search-pattern-set old) set)) + old) + +(define-search-kind :not-any (direction pattern old) + ":not-any - Find the first character which is not in the string Pattern." + (declare (string pattern)) + (setq old (frob-character-set pattern direction old :not-any)) + (let ((set (create-character-set))) + (dotimes (i search-char-code-limit) + (unless (find (code-char i) pattern) + (add-character-to-set (code-char i) set))) + (setf (set-search-pattern-set old) set)) + old) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/searchcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/searchcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/searchcoms.lisp (revision 8058) @@ -0,0 +1,693 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains searching and replacing commands. +;;; + +(in-package :hemlock) + + + + +;;;; Some global state. + +(defvar *last-search-string* () "Last string searched for.") +(defvar *last-search-pattern* + (new-search-pattern :string-insensitive :forward "Foo") + "Search pattern we keep around so we don't cons them all the time.") +(defvar *search-wrapped-p* nil "True if search wrapped") + +(defhvar "String Search Ignore Case" + "When set, string searching commands use case insensitive." + :value t) + +(defun get-search-pattern (string direction) + (declare (simple-string string)) + (when (zerop (length string)) (editor-error)) + (setq *last-search-string* string) + (setq *last-search-pattern* + (new-search-pattern (if (value string-search-ignore-case) + :string-insensitive + :string-sensitive) + direction string *last-search-pattern*))) + + + + +;;;; Vanilla searching. + +(defcommand "Forward Search" (p &optional string) + "Do a forward search for a string. + Prompt for the string and leave the point after where it is found." + "Searches for the specified String in the current buffer." + (declare (ignore p)) + (if (not string) + (setq string (prompt-for-string :prompt "Search: " + :default *last-search-string* + :help "String to search for"))) + (let* ((pattern (get-search-pattern string :forward)) + (point (current-point)) + (mark (copy-mark point)) + ;; find-pattern moves point to start of match, and returns is # chars matched + (won (find-pattern point pattern))) + (cond (won (move-mark mark point) + (character-offset point won) + (push-buffer-mark mark t) + (hi::note-selection-set-by-search)) + (t (delete-mark mark) + (editor-error))) + (clear-echo-area))) + +(defcommand "Reverse Search" (p &optional string) + "Do a backward search for a string. + Prompt for the string and leave the point before where it is found." + "Searches backwards for the specified String in the current buffer." + (declare (ignore p)) + (if (not string) + (setq string (prompt-for-string :prompt "Reverse Search: " + :default *last-search-string* + :help "String to search for"))) + (let* ((pattern (get-search-pattern string :backward)) + (point (current-point)) + (mark (copy-mark point)) + (won (find-pattern point pattern))) + (cond (won (move-mark mark point) + (character-offset mark won) + (push-buffer-mark mark t) + (hi::note-selection-set-by-search)) + (t (delete-mark mark) + (editor-error))) + (clear-echo-area))) + + + + +;;;; Incremental searching. + +(defun i-search-pattern (string direction) + (setq *last-search-pattern* + (new-search-pattern (if (value string-search-ignore-case) + :string-insensitive + :string-sensitive) + direction string *last-search-pattern*))) + +;;; %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental +;;; search. +;;; +(defun %i-search-echo-refresh (string direction failure) + (when (interactive) + (clear-echo-area) + (format *echo-area-stream* + "~:[~;Failing ~]~:[~;Overwrapped ~]~:[Reverse I-Search~;I-Search~]: ~A" + failure *search-wrapped-p* (eq direction :forward) string))) + +(defcommand "Incremental Search" (p) + "Searches for input string as characters are provided. + These are the default I-Search command characters: ^Q quotes the + next character typed. Backspace cancels the last character typed. ^S + repeats forward, and ^R repeats backward. ^R or ^S with empty string + either changes the direction or yanks the previous search string. + Escape exits the search unless the string is empty. Escape with + an empty search string calls the non-incremental search command. + Other control characters cause exit and execution of the appropriate + command. If the search fails at some point, ^G and backspace may be + used to backup to a non-failing point; also, ^S and ^R may be used to + look the other way. ^W extends the search string to include the the word + after the point. ^G during a successful search aborts and returns + point to where it started." + "Search for input string as characters are typed in. + It sets up for the recursive searching and checks return values." + (declare (ignore p)) + (setf (last-command-type) nil) + (%i-search-echo-refresh "" :forward nil) + (let* ((*search-wrapped-p* nil) + (point (current-point)) + (save-start (copy-mark point :temporary))) + (with-mark ((here point)) + (when (eq (catch 'exit-i-search + (%i-search "" point here :forward nil)) + :control-g) + (move-mark point save-start) + (invoke-hook abort-hook) + (editor-error)) + (if (region-active-p) + (delete-mark save-start) + (push-buffer-mark save-start))))) + + +(defcommand "Reverse Incremental Search" (p) + "Searches for input string as characters are provided. + These are the default I-Search command characters: ^Q quotes the + next character typed. Backspace cancels the last character typed. ^S + repeats forward, and ^R repeats backward. ^R or ^S with empty string + either changes the direction or yanks the previous search string. + Altmode exits the search unless the string is empty. Altmode with + an empty search string calls the non-incremental search command. + Other control characters cause exit and execution of the appropriate + command. If the search fails at some point, ^G and backspace may be + used to backup to a non-failing point; also, ^S and ^R may be used to + look the other way. ^G during a successful search aborts and returns + point to where it started." + "Search for input string as characters are typed in. + It sets up for the recursive searching and checks return values." + (declare (ignore p)) + (setf (last-command-type) nil) + (%i-search-echo-refresh "" :backward nil) + (let* ((*search-wrapped-p* nil) + (point (current-point)) + (save-start (copy-mark point :temporary))) + (with-mark ((here point)) + (when (eq (catch 'exit-i-search + (%i-search "" point here :backward nil)) + :control-g) + (move-mark point save-start) + (invoke-hook abort-hook) + (editor-error)) + (if (region-active-p) + (delete-mark save-start) + (push-buffer-mark save-start))))) + +;;; %I-SEARCH recursively (with support functions) searches to provide +;;; incremental searching. There is a loop in case the recursion is ever +;;; unwound to some call. curr-point must be saved since point is clobbered +;;; with each recursive call, and the point must be moved back before a +;;; different letter may be typed at a given call. In the CASE at :cancel +;;; and :control-g, if the string is not null, an accurate pattern for this +;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time +;;; since it is possible for ^S or ^R to be typed. +;;; +(defun %i-search (string point trailer direction failure) + (do* ((curr-point (copy-mark point :temporary)) + (curr-trailer (copy-mark trailer :temporary))) + (nil) + (let* ((next-key-event (recursive-get-key-event hi::*editor-input* t)) + (val (%i-search-char-eval next-key-event string point trailer + direction failure)) + (empty-string-p (zerop (length string)))) + (case val + (:mouse-exit + (clear-echo-area) + (throw 'exit-i-search nil)) + (:cancel + (%i-search-echo-refresh string direction failure) + (unless empty-string-p + (i-search-pattern string direction))) ;sets *last-search-pattern* + (:return-cancel ;backspace was typed + (if empty-string-p + (beep) + (return :cancel))) + (:control-g + (when failure (return :control-g)) + (%i-search-echo-refresh string direction nil) + (unless empty-string-p + (i-search-pattern string direction)))) ;*last-search-pattern* + (move-mark point curr-point) + (move-mark trailer curr-trailer)))) + +;;; %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes +;;; necessary actions. +;;; +(defun %i-search-char-eval (key-event string point trailer direction failure) + (declare (simple-string string)) + (cond ((let ((character (key-event-char key-event))) + (and character (standard-char-p character))) + (%i-search-printed-char key-event string point trailer + direction failure)) + ((or (logical-key-event-p key-event :forward-search) + (logical-key-event-p key-event :backward-search)) + (%i-search-control-s-or-r key-event string point trailer + direction failure)) + ((logical-key-event-p key-event :cancel) :return-cancel) + ((logical-key-event-p key-event :extend-search-word) + (with-mark ((end point)) + (word-offset end 1) + (let ((extension (region-to-string (region point end)))) + (%i-search-extend-string string extension point trailer direction failure)))) + ((logical-key-event-p key-event :abort) + (unless failure + (clear-echo-area) + (message "Search aborted.") + (throw 'exit-i-search :control-g)) + :control-g) + ((logical-key-event-p key-event :quote) + (%i-search-printed-char (get-key-event hi::*editor-input* t) + string point trailer direction failure)) + ((and (zerop (length string)) (logical-key-event-p key-event :exit)) + (if (eq direction :forward) + (forward-search-command nil) + (reverse-search-command nil)) + (throw 'exit-i-search nil)) + (t + (unless (logical-key-event-p key-event :exit) + (unget-key-event key-event hi::*editor-input*)) + (unless (zerop (length string)) + (setf *last-search-string* string)) + (throw 'exit-i-search nil)))) + +;;; %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search. Note +;;; that there cannot be failure in the last COND branch: since the direction +;;; has just been changed, there cannot be a failure before trying a new +;;; direction. +;;; +(defun %i-search-control-s-or-r (key-event string point trailer + direction failure) + (let ((forward-direction-p (eq direction :forward)) + (forward-character-p (logical-key-event-p key-event :forward-search))) + (cond ((zerop (length string)) + (%i-search-empty-string point trailer direction forward-direction-p + forward-character-p)) + ((eq forward-direction-p forward-character-p) ;keep searching in the same direction + (cond ((eq failure :first-failure) + (cond (forward-direction-p + (buffer-start point) + (buffer-start trailer) + (character-offset trailer (length string))) + (t + (buffer-end point) + (buffer-end trailer))) + (push-buffer-mark (copy-mark point)) + (let ((*search-wrapped-p* t)) + (%i-search-echo-refresh string direction nil) + (%i-search-find-pattern string point trailer direction))) + (failure + (%i-search string point trailer direction t)) + (t + (%i-search-find-pattern string point (move-mark trailer point) + direction)))) + (t + (let ((new-direction (if forward-character-p :forward :backward))) + (%i-search-echo-refresh string new-direction nil) + (i-search-pattern string new-direction) ;sets *last-search-pattern* + (%i-search-find-pattern string point (move-mark trailer point) + new-direction)))))) + + +;;; %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S +;;; or ^R is typed. If the direction and character typed do not agree, +;;; then merely switch directions. If there was a previous string, search +;;; for it, else flash at the guy. +;;; +(defun %i-search-empty-string (point trailer direction forward-direction-p + forward-character-p) + (cond ((eq forward-direction-p (not forward-character-p)) + (let ((direction (if forward-character-p :forward :backward))) + (%i-search-echo-refresh "" direction nil) + (%i-search "" point trailer direction nil))) + (*last-search-string* + (%i-search-echo-refresh *last-search-string* direction nil) + (i-search-pattern *last-search-string* direction) ;sets *last-search-pattern* + (%i-search-find-pattern *last-search-string* point trailer direction)) + (t (beep)))) + + +;;; %I-SEARCH-PRINTED-CHAR handles the case of standard character input. +;;; If the direction is backwards, we have to be careful not to MARK-AFTER +;;; the end of the buffer or to include the next character at the beginning +;;; of the search. +;;; +(defun %i-search-printed-char (key-event string point trailer direction failure) + (let ((tchar (hemlock-ext:key-event-char key-event))) + (unless tchar (editor-error "Not a text character -- ~S" (key-event-char + key-event))) + (when (interactive) + (insert-character (buffer-point *echo-area-buffer*) tchar) + (force-output *echo-area-stream*)) + (let ((new-string (concatenate 'simple-string string (string tchar)))) + (i-search-pattern new-string direction) ;sets *last-search-pattern* + (cond (failure (%i-search new-string point trailer direction failure)) + ((and (eq direction :backward) (next-character trailer)) + (%i-search-find-pattern new-string point (mark-after trailer) + direction)) + (t + (%i-search-find-pattern new-string point trailer direction)))))) + +(defun %i-search-extend-string (string extension point trailer direction failure) + (when (interactive) + (insert-string (buffer-point *echo-area-buffer*) extension) + (force-output *echo-area-stream*)) + (let ((new-string (concatenate 'simple-string string extension))) + (i-search-pattern new-string direction) ;sets *last-search-pattern* + (cond (failure (%i-search new-string point trailer direction failure)) + ((and (eq direction :backward) (next-character trailer)) + (%i-search-find-pattern new-string point (mark-after trailer) + direction)) + (t + (%i-search-find-pattern new-string point trailer direction))))) + + +;;; %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction +;;; and finds it, updating necessary pointers for the next call to %I-SEARCH. +;;; If the search failed, tell the user and do not move any pointers. +;;; +(defun %i-search-find-pattern (string point trailer direction) + (let ((found-offset (find-pattern trailer *last-search-pattern*))) + (cond (found-offset + (cond ((eq direction :forward) + (character-offset (move-mark point trailer) found-offset)) + (t + (move-mark point trailer) + (character-offset trailer found-offset))) + (push-buffer-mark (copy-mark trailer) t) + (hi::note-selection-set-by-search) + (%i-search string point trailer direction nil)) + (t + (%i-search-echo-refresh string direction t) + (if (interactive) + (beep) + (editor-error "I-Search failed.")) + (%i-search string point trailer direction :first-failure))))) + + + + +;;;; Replacement commands: + +(defcommand "Replace String" (p &optional + (target (prompt-for-string + :prompt "Replace String: " + :help "Target string" + :default *last-search-string*)) + (replacement (prompt-for-string + :prompt "With: " + :help "Replacement string"))) + "Replaces the specified Target string with the specified Replacement + string in the current buffer for all occurrences after the point or within + the active region, depending on whether it is active." + "Replaces the specified Target string with the specified Replacement + string in the current buffer for all occurrences after the point or within + the active region, depending on whether it is active. The prefix argument + may limit the number of replacements." + (multiple-value-bind (ignore count) + (query-replace-function p target replacement + "Replace String" t) + (declare (ignore ignore)) + (message "~D Occurrences replaced." count))) + +(defcommand "Query Replace" (p &optional + (target (prompt-for-string + :prompt "Query Replace: " + :help "Target string" + :default *last-search-string*)) + (replacement (prompt-for-string + :prompt "With: " + :help "Replacement string"))) + "Replaces the Target string with the Replacement string if confirmation + from the keyboard is given. If the region is active, limit queries to + occurrences that occur within it, otherwise use point to end of buffer." + "Replaces the Target string with the Replacement string if confirmation + from the keyboard is given. If the region is active, limit queries to + occurrences that occur within it, otherwise use point to end of buffer. + A prefix argument may limit the number of queries." + (let ((mark (copy-mark (current-point)))) + (multiple-value-bind (ignore count) + (query-replace-function p target replacement + "Query Replace") + (declare (ignore ignore)) + (message "~D Occurrences replaced." count)) + (push-buffer-mark mark))) + + +(defhvar "Case Replace" + "If this is true then \"Query Replace\" will try to preserve case when + doing replacements." + :value t) + +(defstruct (replace-undo (:constructor make-replace-undo (mark region))) + mark + region) + +(setf (documentation 'replace-undo-mark 'function) + "Return the mark where a replacement was made.") +(setf (documentation 'replace-undo-region 'function) + "Return region deleted due to replacement.") + +(defvar *query-replace-undo-data* nil) + +;;; REPLACE-THAT-CASE replaces a string case-sensitively. Lower, Cap and Upper +;;; are the original, capitalized and uppercase replacement strings. Mark is a +;;; :left-inserting mark after the text to be replaced. Length is the length +;;; of the target string. If dumb, then do a simple replace. This pushes +;;; an undo information structure into *query-replace-undo-data* which +;;; QUERY-REPLACE-FUNCTION uses. +;;; +(defun replace-that-case (lower cap upper mark length dumb) + (character-offset mark (- length)) + (let ((insert (cond (dumb lower) + ((upper-case-p (next-character mark)) + (mark-after mark) + (prog1 (if (upper-case-p (next-character mark)) upper cap) + (mark-before mark))) + (t lower)))) + (with-mark ((undo-mark1 mark :left-inserting) + (undo-mark2 mark :left-inserting)) + (character-offset undo-mark2 length) + (push (make-replace-undo + ;; Save :right-inserting, so the INSERT-STRING at mark below + ;; doesn't move the copied mark the past replacement. + (copy-mark mark :right-inserting) + (delete-and-save-region (region undo-mark1 undo-mark2))) + *query-replace-undo-data*)) + (insert-string mark insert))) + +;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands: +;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace". +;;; Name is the name of the command for undoing purposes. If doing-all? is +;;; true, this replaces all ocurrences for the non-querying commands. This +;;; returns t if it completes successfully, and nil if it is aborted. As a +;;; second value, it returns the number of replacements. +;;; +;;; The undo method, before undo'ing anything, makes all marks :left-inserting. +;;; There's a problem when two replacements are immediately adjacent, such as +;;; foofoo +;;; replacing "foo" with "bar". If the marks were still :right-inserting as +;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would +;;; bring the two marks together due to the DELETE-CHARACTERS. Then inserting +;;; the region would move the second replacement's mark to be before the first +;;; replacement. +;;; +(defun query-replace-function (count target replacement name + &optional (doing-all? nil)) + (declare (simple-string replacement)) + (let ((replacement-len (length replacement)) + (*query-replace-undo-data* nil)) + (when (and count (minusp count)) + (editor-error "Replacement count is negative.")) + (get-search-pattern target :forward) + (unwind-protect + (query-replace-loop (get-count-region) (or count -1) target replacement + replacement-len (current-point) doing-all?) + (let ((undo-data (nreverse *query-replace-undo-data*))) + (save-for-undo name + #'(lambda () + (dolist (ele undo-data) + (setf (mark-kind (replace-undo-mark ele)) :left-inserting)) + (dolist (ele undo-data) + (let ((mark (replace-undo-mark ele))) + (delete-characters mark replacement-len) + (ninsert-region mark (replace-undo-region ele))))) + #'(lambda () + (dolist (ele undo-data) + (delete-mark (replace-undo-mark ele))))))))) + +;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION. The first +;;; value is whether we completed all replacements, nil if we aborted. The +;;; second value is how many replacements occurred. +;;; +(defun query-replace-loop (region count target replacement replacement-len + point doing-all?) + (with-mark ((last-found point) + ;; Copy REGION-END before moving point to REGION-START in case + ;; the end is point. Also, make it permanent in case we make + ;; replacements on the last line containing the end. + (stop-mark (region-end region) :left-inserting)) + (move-mark point (region-start region)) + (let ((length (length target)) + (cap (string-capitalize replacement)) + (upper (string-upcase replacement)) + (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch)) + (lower-case-p ch))) + (the string replacement)) + (value case-replace))))) + (values + (loop + (let ((won (find-pattern point *last-search-pattern*))) + (when (or (null won) (zerop count) (mark> point stop-mark)) + (character-offset (move-mark point last-found) replacement-len) + (return t)) + (decf count) + (move-mark last-found point) + (character-offset point length) + (if doing-all? + (replace-that-case replacement cap upper point length dumb) + (command-case + (:prompt + "Query replace: " + :help "Type one of the following single-character commands:" + :change-window nil :bind key-event) + (:yes "Replace this occurrence." + (replace-that-case replacement cap upper point length + dumb)) + (:no "Don't replace this occurrence, but continue.") + (:do-all "Replace this and all remaining occurrences." + (replace-that-case replacement cap upper point length + dumb) + (setq doing-all? t)) + (:do-once "Replace this occurrence, then exit." + (replace-that-case replacement cap upper point length + dumb) + (return nil)) + (:recursive-edit + "Go into a recursive edit at the current position." + (do-recursive-edit) + (get-search-pattern target :forward)) + (:exit "Exit immediately." + (return nil)) + (t (unget-key-event key-event hi::*editor-input*) + (return nil)))))) + (length (the list *query-replace-undo-data*)))))) + + + + +;;;; Occurrence searching. + +(defcommand "List Matching Lines" (p &optional string) + "Prompts for a search string and lists all matching lines after the point or + within the current-region, depending on whether it is active or not. + With an argument, lists p lines before and after each matching line." + "Prompts for a search string and lists all matching lines after the point or + within the current-region, depending on whether it is active or not. + With an argument, lists p lines before and after each matching line." + (unless string + (setf string (prompt-for-string :prompt "List Matching: " + :default *last-search-string* + :help "String to search for"))) + (let ((pattern (get-search-pattern string :forward)) + (matching-lines nil) + (region (get-count-region))) + (with-mark ((mark (region-start region)) + (end-mark (region-end region))) + (loop + (when (or (null (find-pattern mark pattern)) (mark> mark end-mark)) + (return)) + (setf matching-lines + (nconc matching-lines (list-lines mark (or p 0)))) + (unless (line-offset mark 1 0) + (return)))) + (with-pop-up-display (s :height (length matching-lines) :title (format nil "Lines matching ~s" string)) + (dolist (line matching-lines) + (write-line line s))))) + +;;; LIST-LINES creates a lists of strings containing (num) lines before the +;;; line that the point is on, the line that the point is on, and (num) +;;; lines after the line that the point is on. If (num) > 0, a string of +;;; dashes will be added to make life easier for List Matching Lines. +;;; +(defun list-lines (mark num) + (if (<= num 0) + (list (line-string (mark-line mark))) + (with-mark ((mark mark) + (beg-mark mark)) + (unless (line-offset beg-mark (- num)) + (buffer-start beg-mark)) + (unless (line-offset mark num) + (buffer-end mark)) + (let ((lines (list "--------"))) + (loop + (push (line-string (mark-line mark)) lines) + (when (same-line-p mark beg-mark) + (return lines)) + (line-offset mark -1)))))) + +(defcommand "Delete Matching Lines" (p &optional string) + "Deletes all lines that match the search pattern using delete-region. If + the current region is active, limit the search to it. The argument is + ignored." + "Deletes all lines that match the search pattern using delete-region. If + the current region is active, limit the search to it. The argument is + ignored." + (declare (ignore p)) + (unless string + (setf string (prompt-for-string :prompt "Delete Matching: " + :default *last-search-string* + :help "String to search for"))) + (let* ((region (get-count-region)) + (pattern (get-search-pattern string :forward)) + (start-mark (region-start region)) + (end-mark (region-end region))) + (with-mark ((bol-mark start-mark :left-inserting) + (eol-mark start-mark :right-inserting)) + (loop + (unless (and (find-pattern bol-mark pattern) (mark< bol-mark end-mark)) + (return)) + (move-mark eol-mark bol-mark) + (line-start bol-mark) + (unless (line-offset eol-mark 1 0) + (buffer-end eol-mark)) + (delete-region (region bol-mark eol-mark)))))) + +(defcommand "Delete Non-Matching Lines" (p &optional string) + "Deletes all lines that do not match the search pattern using delete-region. + If the current-region is active, limit the search to it. The argument is + ignored." + "Deletes all lines that do not match the search pattern using delete-region. + If the current-region is active, limit the search to it. The argument is + ignored." + (declare (ignore p)) + (unless string + (setf string (prompt-for-string :prompt "Delete Non-Matching:" + :default *last-search-string* + :help "String to search for"))) + (let* ((region (get-count-region)) + (start-mark (region-start region)) + (stop-mark (region-end region)) + (pattern (get-search-pattern string :forward))) + (with-mark ((beg-mark start-mark :left-inserting) + (end-mark start-mark :right-inserting)) + (loop + (move-mark end-mark beg-mark) + (cond ((and (find-pattern end-mark pattern) (mark< end-mark stop-mark)) + (line-start end-mark) + (delete-region (region beg-mark end-mark)) + (unless (line-offset beg-mark 1 0) + (return))) + (t + (delete-region (region beg-mark stop-mark)) + (return))))))) + +(defcommand "Count Occurrences" (p &optional string) + "Prompts for a search string and counts occurrences of it after the point or + within the current-region, depending on whether it is active or not. The + argument is ignored." + "Prompts for a search string and counts occurrences of it after the point or + within the current-region, depending on whether it is active or not. The + argument is ignored." + (declare (ignore p)) + (unless string + (setf string (prompt-for-string + :prompt "Count Occurrences: " + :default *last-search-string* + :help "String to search for"))) + (message "~D occurrence~:P" + (count-occurrences-region (get-count-region) string))) + +(defun count-occurrences-region (region string) + (let ((pattern (get-search-pattern string :forward)) + (end-mark (region-end region))) + (let ((occurrences 0)) + (with-mark ((mark (region-start region))) + (loop + (let ((won (find-pattern mark pattern))) + (when (or (null won) (mark> mark end-mark)) + (return)) + (incf occurrences) + (character-offset mark won)))) + occurrences))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/streams.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/streams.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/streams.lisp (revision 8058) @@ -0,0 +1,265 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains definitions of various types of streams used +;;; in Hemlock. They are implementation dependant, but should be +;;; portable to all implementations based on Spice Lisp with little +;;; difficulty. +;;; +;;; Written by Skef Wholey and Rob MacLachlan. +;;; + +(in-package :hemlock-internals) + +(defclass hemlock-output-stream (#-scl fundamental-character-output-stream + #+scl character-output-stream) + ((mark + :initform nil + :accessor hemlock-output-stream-mark + :documentation "The mark we insert at.") + (out + :accessor old-lisp-stream-out) + (sout + :accessor old-lisp-stream-sout) + ) ) + +;; this should suffice for now: +(defmethod stream-write-char ((stream hemlock-output-stream) char) + (funcall (old-lisp-stream-out stream) stream char)) + +(defmethod stream-write-string ((stream hemlock-output-stream) string + &optional + (start 0) + (end (length string))) + (funcall (old-lisp-stream-sout stream) stream string start end)) + + +(defmethod print-object ((object hemlock-output-stream) stream) + (write-string "#" stream)) + +(defun make-hemlock-output-stream (mark &optional (buffered :line)) + "Returns an output stream whose output will be inserted at the Mark. + Buffered, which indicates to what extent the stream may be buffered + is one of the following: + :None -- The screen is brought up to date after each stream operation. + :Line -- The screen is brought up to date when a newline is written. + :Full -- The screen is not updated except explicitly via Force-Output." + (modify-hemlock-output-stream (make-instance 'hemlock-output-stream) mark + buffered)) + + +(defun modify-hemlock-output-stream (stream mark buffered) + (unless (and (markp mark) + (member (mark-kind mark) '(:right-inserting :left-inserting))) + (error "~S is not a permanent mark." mark)) + (setf (hemlock-output-stream-mark stream) mark) + (case buffered + (:none + (setf (old-lisp-stream-out stream) #'hemlock-output-unbuffered-out + (old-lisp-stream-sout stream) #'hemlock-output-unbuffered-sout)) + (:line + (setf (old-lisp-stream-out stream) #'hemlock-output-line-buffered-out + (old-lisp-stream-sout stream) #'hemlock-output-line-buffered-sout)) + (:full + (setf (old-lisp-stream-out stream) #'hemlock-output-buffered-out + (old-lisp-stream-sout stream) #'hemlock-output-buffered-sout)) + (t + (error "~S is a losing value for Buffered." buffered))) + stream) + +(defmacro with-left-inserting-mark ((var form) &body forms) + (let ((change (gensym))) + `(let* ((,var ,form) + (,change (eq (mark-kind ,var) :right-inserting))) + (unwind-protect + (progn + (when ,change + (setf (mark-kind ,var) :left-inserting)) + ,@forms) + (when ,change + (setf (mark-kind ,var) :right-inserting)))))) + +(defun hemlock-output-unbuffered-out (stream character) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (let* ((buffer (line-%buffer (mark-line mark)))) + (buffer-document-begin-editing buffer) + (unwind-protect + (insert-character mark character) + (buffer-document-end-editing buffer))))) + +(defun hemlock-output-unbuffered-sout (stream string start end) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (unless (and (eql start 0) + (eql end (length string))) + (setq string (subseq string start end))) + (let* ((buffer (line-%buffer (mark-line mark)))) + (buffer-document-begin-editing buffer) + (unwind-protect + (insert-string mark string) + (buffer-document-end-editing buffer))))) + +(defun hemlock-output-buffered-out (stream character) + (hemlock-output-unbuffered-out stream character)) + + +(defun hemlock-output-buffered-sout (stream string start end) + (hemlock-output-unbuffered-sout stream string start end)) + +(defun hemlock-output-line-buffered-out (stream character) + (hemlock-output-unbuffered-out stream character)) + +(defun hemlock-output-line-buffered-sout (stream string start end) + (hemlock-output-unbuffered-sout stream string start end)) + + +(defmethod stream-finish-output ((stream hemlock-output-stream))) + +(defmethod stream-force-output ((stream hemlock-output-stream))) + +(defmethod close ((stream hemlock-output-stream) &key abort) + (declare (ignore abort)) + (setf (hemlock-output-stream-mark stream) nil)) + +(defmethod stream-line-column ((stream hemlock-output-stream)) + (mark-charpos (hemlock-output-stream-mark stream))) + + + + +(defclass hemlock-region-stream (#-scl fundamental-character-input-stream + #+scl character-input-stream) + ;; + ;; The region we read from. + ((region :initarg :region + :accessor hemlock-region-stream-region) + ;; + ;; The mark pointing to the next character to read. + (mark :initarg :mark + :accessor hemlock-region-stream-mark)) ) + +(defmethod print-object ((object hemlock-region-stream) stream) + (declare (ignorable object)) + (write-string "#" stream)) + +(defun make-hemlock-region-stream (region) + "Returns an input stream that will return successive characters from the + given Region when asked for input." + (make-instance 'hemlock-region-stream + :region region + :mark (copy-mark (region-start region) :right-inserting))) + +(defun modify-hemlock-region-stream (stream region) + (setf (hemlock-region-stream-region stream) region) + (let* ((mark (hemlock-region-stream-mark stream)) + (start (region-start region)) + (start-line (mark-line start))) + ;; Make sure it's dead. + (delete-mark mark) + (setf (mark-line mark) start-line (mark-charpos mark) (mark-charpos start)) + (push mark (line-marks start-line))) + stream) + +(defmethod stream-read-char ((stream hemlock-region-stream)) + (let ((mark (hemlock-region-stream-mark stream))) + (cond ((mark< mark + (region-end (hemlock-region-stream-region stream))) + (prog1 (next-character mark) (mark-after mark))) + (t :eof)))) + +(defmethod stream-listen ((stream hemlock-region-stream)) + (mark< (hemlock-region-stream-mark stream) + (region-end (hemlock-region-stream-region stream)))) + +(defmethod stream-unread-char ((stream hemlock-region-stream) char) + (let ((mark (hemlock-region-stream-mark stream))) + (unless (mark> mark + (region-start (hemlock-region-stream-region stream))) + (error "Nothing to unread.")) + (unless (char= char (previous-character mark)) + (error "Unreading something not read: ~S" char)) + (mark-before mark))) + +(defmethod stream-clear-input ((stream hemlock-region-stream)) + (move-mark + (hemlock-region-stream-mark stream) + (region-end (hemlock-region-stream-region stream))) + nil) + +(defmethod close ((stream hemlock-region-stream) &key abort) + (declare (ignorable abort)) + (delete-mark (hemlock-region-stream-mark stream)) + (setf (hemlock-region-stream-region stream) nil)) + +#+excl +(defmethod excl:stream-read-char-no-hang ((stream hemlock-region-stream)) + (stream-read-char stream)) + +#|| +(defmethod excl::stream-file-position ((stream hemlock-output-stream) &optional pos) + (assert (null pos)) + (mark-charpos (hemlock-output-stream-mark stream))) + +(defun region-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + + (:file-position + (let ((start (region-start (hemlock-region-stream-region stream))) + (mark (hemlock-region-stream-mark stream))) + (cond (arg1 + (move-mark mark start) + (character-offset mark arg1)) + (t + (count-characters (region start mark)))))) )) +||# + + + +;;;; Stuff to support keyboard macros. + +#+later +(progn + +(defstruct (kbdmac-stream + (:include editor-input + (get #'kbdmac-get) + (unget #'kbdmac-unget) + (listen #'kbdmac-listen)) + (:constructor make-kbdmac-stream ())) + buffer ; The simple-vector that holds the characters. + index) ; Index of the next character. + +(defun kbdmac-get (stream ignore-abort-attempts-p) + (declare (ignore ignore-abort-attempts-p)) + (let ((index (kbdmac-stream-index stream))) + (setf (kbdmac-stream-index stream) (1+ index)) + (setq *last-key-event-typed* + (svref (kbdmac-stream-buffer stream) index)))) + +(defun kbdmac-unget (ignore stream) + (declare (ignore ignore)) + (if (plusp (kbdmac-stream-index stream)) + (decf (kbdmac-stream-index stream)) + (error "Nothing to unread."))) + +(defun kbdmac-listen (stream) + (declare (ignore stream)) + t) + +;;; MODIFY-KBDMAC-STREAM -- Internal +;;; +;;; Bash the kbdmac-stream Stream so that it will return the Input. +;;; +(defun modify-kbdmac-stream (stream input) + (setf (kbdmac-stream-index stream) 0) + (setf (kbdmac-stream-buffer stream) input) + stream) +) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/struct.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/struct.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/struct.lisp (revision 8058) @@ -0,0 +1,738 @@ + ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Structures and assorted macros for Hemlock. +;;; + +(in-package :hemlock-internals) + + + +;;;; Marks. + +(defstruct (mark (:print-function %print-hmark) + (:predicate markp) + (:copier nil) + (:constructor internal-make-mark (line charpos %kind))) + "A Hemlock mark object. See Hemlock Command Implementor's Manual for details." + line ; pointer to line + charpos ; character position + %kind) ; type of mark + +(setf (documentation 'markp 'function) + "Returns true if its argument is a Hemlock mark object, false otherwise.") +(setf (documentation 'mark-line 'function) + "Returns line that a Hemlock mark points to.") +(setf (documentation 'mark-charpos 'function) + "Returns the character position of a Hemlock mark. + A mark's character position is the index within the line of the character + following the mark.") + +(defstruct (font-mark (:print-function + (lambda (s stream d) + (declare (ignore d)) + (write-string "#" stream))) + (:include mark) + (:copier nil) + (:constructor internal-make-font-mark + (line charpos %kind font))) + font + region) + +(defmacro fast-font-mark-p (s) + `(typep ,s 'font-mark)) + + + +;;;; Regions, buffers, modeline fields. + +;;; The region object: +;;; +(defstruct (region (:print-function %print-hregion) + (:predicate regionp) + (:copier nil) + (:constructor internal-make-region (start end))) + "A Hemlock region object. See Hemlock Command Implementor's Manual for details." + start ; starting mark + end) ; ending mark + +(setf (documentation 'regionp 'function) + "Returns true if its argument is a Hemlock region object, Nil otherwise.") +(setf (documentation 'region-end 'function) + "Returns the mark that is the end of a Hemlock region.") +(setf (documentation 'region-start 'function) + "Returns the mark that is the start of a Hemlock region.") + +(defstruct (font-region (:include region) + (:constructor internal-make-font-region (start end))) + node) + +;;; The buffer object: +;;; +(defstruct (buffer (:constructor internal-make-buffer) + (:print-function %print-hbuffer) + (:copier nil) + (:predicate bufferp)) + "A Hemlock buffer object. See Hemlock Command Implementor's Manual for details." + %name ; name of the buffer (a string) + %region ; the buffer's region + %pathname ; associated pathname + modes ; list of buffer's mode names + mode-objects ; list of buffer's mode objects + bindings ; buffer's command table + point ; current position in buffer + %mark ; a saved buffer position + region-active ; modified-tick when region last activated + (%writable t) ; t => can alter buffer's region + (modified-tick -2) ; The last time the buffer was modified. + (unmodified-tick -1) ; The last time the buffer was unmodified + #+clx + windows ; List of all windows into this buffer. + #+clozure ;; should be #+Cocoa + document ; NSDocument object associated with this buffer + var-values ; the buffer's local variables + variables ; string-table of local variables + write-date ; File-Write-Date for pathname. + display-start ; Window display start when switching to buf. + %modeline-fields ; List of modeline-field-info's. + (delete-hook nil) ; List of functions to call upon deletion. + (line-termination :unix) ; Line-termination, for the time being + process ; Maybe a listener + (gap-context ) ; The value of *buffer-gap-context* + ; in the thread that can modify the buffer. + protected-region ; (optional) write-protected region + (font-regions (ccl::init-dll-header (ccl::make-dll-header))) + ; a doubly-linked list of font regions. + active-font-region ; currently active font region + ) + +(defstruct (font-region-node (:include ccl::dll-node) + (:constructor make-font-region-node (region))) + region) + +(setf (documentation 'buffer-modes 'function) + "Return the list of the names of the modes active in a given buffer.") +(setf (documentation 'buffer-point 'function) + "Return the mark that is the current focus of attention in a buffer.") +(setf (documentation 'buffer-windows 'function) + "Return the list of windows that are displaying a given buffer.") +(setf (documentation 'buffer-variables 'function) + "Return the string-table of the variables local to the specifed buffer.") +(setf (documentation 'buffer-write-date 'function) + "Return in universal time format the write date for the file associated + with the buffer. If the pathname is set, then this should probably + be as well. Should be NIL if the date is unknown or there is no file.") +(setf (documentation 'buffer-delete-hook 'function) + "This is the list of buffer specific functions that Hemlock invokes when + deleting this buffer.") + + +;;; Modeline fields. +;;; +(defstruct (modeline-field (:print-function print-modeline-field) + (:constructor %make-modeline-field + (%name %function %width))) + "This is one item displayed in a Hemlock window's modeline." + %name ; EQL name of this field. + %function ; Function that returns a string for this field. + %width) ; Width to display this field in. + +(setf (documentation 'modeline-field-p 'function) + "Returns true if its argument is a modeline field object, nil otherwise.") + +(defstruct (modeline-field-info (:print-function print-modeline-field-info) + (:conc-name ml-field-info-) + (:constructor make-ml-field-info (field))) + field + (start nil) + (end nil)) + + + + +;;;; The mode object. + +(defstruct (mode-object (:predicate modep) + (:copier nil) + (:print-function %print-hemlock-mode)) + name ; name of this mode + setup-function ; setup function for this mode + cleanup-function ; Cleanup function for this mode + bindings ; The mode's command table. + transparent-p ; Are key-bindings transparent? + hook-name ; The name of the mode hook. + major-p ; Is this a major mode? + precedence ; The precedence for a minor mode. + character-attributes ; Mode local character attributes + variables ; String-table of mode variables + var-values ; Alist for saving mode variables + documentation ; Introductory comments for mode describing commands. + hidden ; Not listed in modeline fields +) + +(defun %print-hemlock-mode (object stream depth) + (declare (ignore depth)) + (write-string "#" stream)) + + + + +;;;; Variables. + +;;; This holds information about Hemlock variables, and the system stores +;;; these structures on the property list of the variable's symbolic +;;; representation under the 'hemlock-variable-value property. +;;; +(defstruct (variable-object + (:print-function + (lambda (object stream depth) + (declare (ignore depth)) + (format stream "#" + (variable-object-name object)))) + (:copier nil) + (:constructor make-variable-object (documentation name))) + value ; The value of this variable. + hooks ; The hook list for this variable. + down ; The variable-object for the previous value. + documentation ; The documentation. + name) ; The string name. + + + + +;#+clx +(progn +;;;; Windows, dis-lines, and font-changes. + +;;; The window object: +;;; + (defstruct (window (:constructor internal-make-window) + (:predicate windowp) + (:copier nil) + (:print-function %print-hwindow)) + "This structure implements a Hemlock window." + tick ; The last time this window was updated. + %buffer ; buffer displayed in this window. + height ; Height of window in lines. + width ; Width of the window in characters. + old-start ; The charpos of the first char displayed. + first-line ; The head of the list of dis-lines. + last-line ; The last dis-line displayed. + first-changed ; The first changed dis-line on last update. + last-changed ; The last changed dis-line. + spare-lines ; The head of the list of unused dis-lines + (old-lines 0) ; Slot used by display to keep state info + hunk ; The device hunk that displays this window. + display-start ; first character position displayed + display-end ; last character displayed + point ; Where the cursor is in this window. + modeline-dis-line ; Dis-line for modeline display. + modeline-buffer ; Complete string of all modeline data. + modeline-buffer-len ; Valid chars in modeline-buffer. + display-recentering) ; Tells whether redisplay recenters window + ; regardless of whether it is current. + + (setf (documentation 'windowp 'function) + "Returns true if its argument is a Hemlock window object, Nil otherwise.") + (setf (documentation 'window-height 'function) + "Return the height of a Hemlock window in character positions.") + (setf (documentation 'window-width 'function) + "Return the width of a Hemlock window in character positions.") + (setf (documentation 'window-display-start 'function) + "Return the mark which points before the first character displayed in + the supplied window.") + (setf (documentation 'window-display-end 'function) + "Return the mark which points after the last character displayed in + the supplied window.") + (setf (documentation 'window-point 'function) + "Return the mark that points to where the cursor is displayed in this + window. When the window is made current, the Buffer-Point of this window's + buffer is moved to this position. While the window is current, redisplay + makes this mark point to the same position as the Buffer-Point of its + buffer.") + (setf (documentation 'window-display-recentering 'function) + "This determines whether redisplay recenters window regardless of whether it + is current. This is SETF'able.") + + (defstruct (window-dis-line (:copier nil) + (:constructor make-window-dis-line (chars)) + (:conc-name dis-line-)) + chars ; The line-image to be displayed. + (length 0 :type fixnum) ; Length of line-image. + font-changes ; Font-Change structures for changes in this line. + old-chars ; Line-Chars of line displayed. + line ; Line displayed. + (flags 0 :type fixnum) ; Bit flags indicate line status. + (delta 0 :type fixnum) ; # lines moved from previous position. + (position 0 :type fixnum) ; Line # to be displayed on. + (end 0 :type fixnum)) ; Index after last logical character displayed. + + (defstruct (font-change (:copier nil) + (:constructor make-font-change (next))) + x ; X position that change takes effect. + font ; Index into font-map of font to use. + next ; The next Font-Change on this dis-line. + mark) ; Font-Mark responsible for this change. + + + + +;;;; Font family. + + (defstruct font-family + map ; Font-map for hunk. + height ; Height of char box includung VSP. + width ; Width of font. + baseline ; Pixels from top of char box added to Y. + cursor-width ; Pixel width of cursor. + cursor-height ; Pixel height of cursor. + cursor-x-offset ; Added to pos of UL corner of char box to get + cursor-y-offset) ; UL corner of cursor blotch. + + ) + + + +;;;; Attribute descriptors. + +(defstruct (attribute-descriptor + (:copier nil) + (:print-function %print-attribute-descriptor)) + "This structure is used internally in Hemlock to describe a character + attribute." + name + keyword + documentation + vector + hooks + end-value) + + + + +;;;; Commands. + +(defstruct (command (:constructor internal-make-command + (%name documentation function)) + (:copier nil) + (:predicate commandp) + (:print-function %print-hcommand)) + %name ;The name of the command + documentation ;Command documentation string or function + function ;The function which implements the command + %bindings) ;Places where command is bound + +(setf (documentation 'commandp 'function) + "Returns true if its argument is a Hemlock command object, Nil otherwise.") +(setf (documentation 'command-documentation 'function) + "Return the documentation for a Hemlock command, given the command-object. + Command documentation may be either a string or a function. This may + be set with Setf.") + + + + +;;;; Random typeout streams. + +;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY. +;;; + +(defclass random-typeout-stream (#-scl fundamental-character-output-stream + #+scl character-output-stream) + ((mark :initarg :mark + :initform nil + :accessor random-typeout-stream-mark + :documentation "The buffer point of the associated buffer.") + (window :initarg :window + :initform nil + :accessor random-typeout-stream-window + :documentation "The hemlock window all this shit is in.") + (more-mark :initarg :more-mark + :initform nil + :accessor random-typeout-stream-more-mark + :documentation "The mark that is not displayed when we need to more.") + (no-prompt :initarg :no-prompt + :initform nil + :accessor random-typeout-stream-no-prompt + :documentation "T when we want to exit, still collecting output.") + (first-more-p :initarg :first-more-p + :initform t + :accessor random-typeout-stream-first-more-p + :documentation "T until the first time we more. Nil after.") + (line-buffered-p :documentation "whether line buffered") )) + +(defun make-random-typeout-stream (mark) + (make-instance 'random-typeout-stream + :mark mark)) + +(defmethod print-object ((object random-typeout-stream) stream) + (format stream "#" + (ignore-errors + (buffer-name + (line-buffer (mark-line (random-typeout-stream-mark object))))))) + + + +;;;; Redisplay devices. + +;;; Devices contain monitor specific redisplay methods referenced by +;;; redisplay independent code. +;;; +(defstruct (device (:print-function print-device) + (:constructor %make-device)) + name ; simple-string such as "concept" or "lnz". + init ; fun to call whenever going into the editor. + ; args: device + exit ; fun to call whenever leaving the editor. + ; args: device + smart-redisplay ; fun to redisplay a window on this device. + ; args: window &optional recenterp + dumb-redisplay ; fun to redisplay a window on this device. + ; args: window &optional recenterp + after-redisplay ; args: device + ; fun to call at the end of redisplay entry points. + clear ; fun to clear the entire display. + ; args: device + note-read-wait ; fun to somehow note on display that input is expected. + ; args: on-or-off + put-cursor ; fun to put the cursor at (x,y) or (column,line). + ; args: hunk &optional x y + show-mark ; fun to display the screens cursor at a certain mark. + ; args: window x y time + next-window ; funs to return the next and previous window + previous-window ; of some window. + ; args: window + make-window ; fun to make a window on the screen. + ; args: device start-mark + ; &optional modeline-string modeline-function + delete-window ; fun to remove a window from the screen. + ; args: window + random-typeout-setup ; fun to prepare for random typeout. + ; args: device n + random-typeout-cleanup; fun to clean up after random typeout. + ; args: device degree + random-typeout-line-more ; fun to keep line-buffered streams up to date. + random-typeout-full-more ; fun to do full-buffered more-prompting. + ; args: # of newlines in the object just inserted + ; in the buffer. + force-output ; if non-nil, fun to force any output possibly buffered. + finish-output ; if non-nil, fun to force output and hand until done. + ; args: device window + beep ; fun to beep or flash the screen. + bottom-window-base ; bottom text line of bottom window. + hunks) ; list of hunks on the screen. + +(defun print-device (obj str n) + (declare (ignore n)) + (format str "#" (device-name obj))) + + +(defstruct (bitmap-device #|(:print-function print-device)|# + (:include device)) + display) ; CLX display object. + + +(defstruct (tty-device #|(:print-function print-device)|# + (:constructor %make-tty-device) + (:include device)) + dumbp ; t if it does not have line insertion and deletion. + lines ; number of lines on device. + columns ; number of columns per line. + display-string ; fun to display a string of characters at (x,y). + ; args: hunk x y string &optional start end + standout-init ; fun to put terminal in standout mode. + ; args: hunk + standout-end ; fun to take terminal out of standout mode. + ; args: hunk + clear-lines ; fun to clear n lines starting at (x,y). + ; args: hunk x y n + clear-to-eol ; fun to clear to the end of a line from (x,y). + ; args: hunk x y + clear-to-eow ; fun to clear to the end of a window from (x,y). + ; args: hunk x y + open-line ; fun to open a line moving lines below it down. + ; args: hunk x y &optional n + delete-line ; fun to delete a line moving lines below it up. + ; args: hunk x y &optional n + insert-string ; fun to insert a string in the middle of a line. + ; args: hunk x y string &optional start end + delete-char ; fun to delete a character from the middle of a line. + ; args: hunk x y &optional n + (cursor-x 0) ; column the cursor is in. + (cursor-y 0) ; line the cursor is on. + standout-init-string ; string to put terminal in standout mode. + standout-end-string ; string to take terminal out of standout mode. + clear-to-eol-string ; string to cause device to clear to eol at (x,y). + clear-string ; string to cause device to clear entire screen. + open-line-string ; string to cause device to open a blank line. + delete-line-string ; string to cause device to delete a line, moving + ; lines below it up. + insert-init-string ; string to put terminal in insert mode. + insert-char-init-string ; string to prepare terminal for insert-mode character. + insert-char-end-string ; string to affect terminal after insert-mode character. + insert-end-string ; string to take terminal out of insert mode. + delete-init-string ; string to put terminal in delete mode. + delete-char-string ; string to delete a character. + delete-end-string ; string to take terminal out of delete mode. + init-string ; device init string. + cm-end-string ; takes device out of cursor motion mode. + (cm-x-add-char nil) ; char-code to unconditionally add to x coordinate. + (cm-y-add-char nil) ; char-code to unconditionally add to y coordinate. + (cm-x-condx-char nil) ; char-code threshold for adding to x coordinate. + (cm-y-condx-char nil) ; char-code threshold for adding to y coordinate. + (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate. + (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate. + cm-string1 ; initial substring of cursor motion string. + cm-string2 ; substring of cursor motion string between coordinates. + cm-string3 ; substring of cursor motion string after coordinates. + cm-one-origin ; non-nil if need to add one to coordinates. + cm-reversep ; non-nil if need to reverse coordinates. + (cm-x-pad nil) ; nil, 0, 2, or 3 for places to pad. + ; 0 sends digit-chars. + (cm-y-pad nil) ; nil, 0, 2, or 3 for places to pad. + ; 0 sends digit-chars. + screen-image ; vector device-lines long of strings + ; device-columns long. + ;; + ;; This terminal's baud rate, or NIL for infinite. + (speed nil :type (or (unsigned-byte 24) null))) + + + +;;;; Device screen hunks and window-group. + +;;; Window groups are used to keep track of the old width and height of a group +;;; so that when a configure-notify event is sent, we can determine if the size +;;; of the window actually changed or not. +;;; +(defstruct (window-group (:print-function %print-window-group) + (:constructor + make-window-group (xparent width height))) + xparent + width + height) + +(defun %print-window-group (object stream depth) + (declare (ignore object depth)) + (format stream "#")) + +;;; Device-hunks are used to claim a piece of the screen and for ordering +;;; pieces of the screen. Window motion primitives and splitting/merging +;;; primitives use hunks. Hunks are somewhat of an interface between the +;;; portable and non-portable parts of screen management, between what the +;;; user sees on the screen and how Hemlock internals deal with window +;;; sequencing and creation. Note: the echo area hunk is not hooked into +;;; the ring of other hunks via the next and previous fields. +;;; +(defstruct (device-hunk (:print-function %print-device-hunk)) + "This structure is used internally by Hemlock's screen management system." + window ; Window displayed in this hunk. + position ; Bottom Y position of hunk. + height ; Height of hunk in pixels or lines. + next ; Next and previous hunks. + previous + device) ; Display device hunk is on. + +(defun %print-device-hunk (object stream depth) + (declare (ignore depth)) + (format stream "#" + (device-hunk-position object) + (device-hunk-height object) + (let* ((window (device-hunk-window object)) + (buffer (if window (window-buffer window)))) + (if buffer (buffer-name buffer))))) + + +;;; Bitmap hunks. +;;; +;;; The lock field is no longer used. If events could be handled while we +;;; were in the middle of something with the hunk, then this could be set +;;; for exclusion purposes. +;;; +(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|# + (:include device-hunk)) + width ; Pixel width. + char-height ; Height of text body in characters. + char-width ; Width in characters. + xwindow ; X window for this hunk. + gcontext ; X gcontext for xwindow. + start ; Head of dis-line list (no dummy). + end ; Exclusive end, i.e. nil if nil-terminated. + modeline-dis-line ; Dis-line for modeline, or NIL if none. + modeline-pos ; Position of modeline in pixels. + (lock t) ; Something going on, set trashed if we're changed. + trashed ; Something bad happened, recompute image. + font-family ; Font-family used in this window. + input-handler ; Gets hunk, char, x, y when char read. + changed-handler ; Gets hunk when size changed. + (thumb-bar-p nil) ; True if we draw a thumb bar in the top border. + window-group) ; The window-group to which this hunk belongs. + + +;;; Terminal hunks. +;;; +(defstruct (tty-hunk #|(:print-function %print-device-hunk)|# + (:include device-hunk)) + text-position ; Bottom Y position of text in hunk. + text-height) ; Number of lines of text. + + + + +;;;; Some defsetfs: + +(defsetf buffer-writable %set-buffer-writable + "Sets whether the buffer is writable and invokes the Buffer Writable Hook.") +(defsetf buffer-name %set-buffer-name + "Sets the name of a specified buffer, invoking the Buffer Name Hook.") +(defsetf buffer-modified %set-buffer-modified + "Make a buffer modified or unmodified.") +(defsetf buffer-pathname %set-buffer-pathname + "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.") + +(defsetf getstring %set-string-table + "Sets the value for a string-table entry, making a new one if necessary.") + +(defsetf window-buffer %set-window-buffer + "Change the buffer a window is mapped to.") + +(define-setf-expander value (var) + "Set the value of a Hemlock variable, calling any hooks." + (let ((svar (gensym))) + (values + () + () + (list svar) + `(%set-value ',var ,svar) + `(value ,var)))) + +(defsetf variable-value (name &optional (kind :current) where) (new-value) + "Set the value of a Hemlock variable, calling any hooks." + `(%set-variable-value ,name ,kind ,where ,new-value)) + +(defsetf variable-hooks (name &optional (kind :current) where) (new-value) + "Set the list of hook functions for a Hemlock variable." + `(%set-variable-hooks ,name ,kind ,where ,new-value)) + +(defsetf variable-documentation (name &optional (kind :current) where) (new-value) + "Set a Hemlock variable's documentation." + `(%set-variable-documentation ,name ,kind ,where ,new-value)) + +(defsetf buffer-minor-mode %set-buffer-minor-mode + "Turn a buffer minor mode on or off.") +(defsetf buffer-major-mode %set-buffer-major-mode + "Set a buffer's major mode.") +(defsetf previous-character %set-previous-character + "Sets the character to the left of the given Mark.") +(defsetf next-character %set-next-character + "Sets the characters to the right of the given Mark.") +(defsetf character-attribute %set-character-attribute + "Set the value for a character attribute.") +(defsetf character-attribute-hooks %set-character-attribute-hooks + "Set the hook list for a Hemlock character attribute.") +(defsetf ring-ref %set-ring-ref "Set an element in a ring.") +(defsetf current-window %set-current-window "Set the current window.") +(defsetf current-buffer %set-current-buffer + "Set the current buffer, doing necessary stuff.") +(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.") +(defsetf buffer-region %set-buffer-region "Set a buffer's region.") +(defsetf command-name %set-command-name + "Change a Hemlock command's name.") +(defsetf line-string %set-line-string + "Replace the contents of a line.") +(defsetf last-command-type %set-last-command-type + "Set the Last-Command-Type for use by the next command.") +(defsetf prefix-argument %set-prefix-argument + "Set the prefix argument for the next command.") +(defsetf logical-key-event-p %set-logical-key-event-p + "Change what Logical-Char= returns for the specified arguments.") +(defsetf window-font %set-window-font + "Change the font-object associated with a font-number in a window.") +(defsetf default-font %set-default-font + "Change the font-object associated with a font-number in new windows.") + +(defsetf buffer-modeline-fields %set-buffer-modeline-fields + "Sets the buffer's list of modeline fields causing all windows into buffer + to be updated for the next redisplay.") +(defsetf modeline-field-name %set-modeline-field-name + "Sets a modeline-field's name. If one already exists with that name, an + error is signaled.") +(defsetf modeline-field-width %set-modeline-field-width + "Sets a modeline-field's width and updates all the fields for all windows + in any buffer whose fields list contains the field.") +(defsetf modeline-field-function %set-modeline-field-function + "Sets a modeline-field's function and updates this field for all windows in + any buffer whose fields list contains the field.") + +;;; Shared buffer-gap context, used to communicate between command threads +;;; and the event thread. Note that this isn't buffer-specific; in particular, +;;; OPEN-LINE and friends may not point at a line that belongs to any +;;; buffer. + +(defstruct buffer-gap-context + (lock (ccl::make-lock)) + (left-open-pos 0) + (right-open-pos 0) + (line-cache-length 200) + (open-line nil) + (open-chars (make-string 200)) +) + +(defun ensure-buffer-gap-context (buffer) + (or (buffer-gap-context buffer) + (setf (buffer-gap-context buffer) (make-buffer-gap-context)))) + +(defun buffer-lock (buffer) + (buffer-gap-context-lock (ensure-buffer-gap-context buffer))) + +(defun current-gap-context () + (unless (boundp '*current-buffer*) + (error "Gap context not bound")) + (ensure-buffer-gap-context *current-buffer*)) + +(defun current-line-cache-length () + (buffer-gap-context-line-cache-length (current-gap-context))) + +(defun (setf current-line-cache-length) (len) + (setf (buffer-gap-context-line-cache-length (current-gap-context)) len)) + +(defun current-open-line () + (buffer-gap-context-open-line (current-gap-context))) + +(defun current-open-line-p (line) + (eq line (current-open-line))) + +(defun (setf current-open-line) (value) + (setf (buffer-gap-context-open-line (current-gap-context)) value)) + +(defun current-open-chars () + (buffer-gap-context-open-chars (current-gap-context))) + +(defun (setf current-open-chars) (value) + (setf (buffer-gap-context-open-chars (current-gap-context)) value)) + +(defun current-left-open-pos () + (buffer-gap-context-left-open-pos (current-gap-context))) + +(defun (setf current-left-open-pos) (value) + (setf (buffer-gap-context-left-open-pos (current-gap-context)) value)) + +(defun current-right-open-pos () + (buffer-gap-context-right-open-pos (current-gap-context))) + +(defun (setf current-right-open-pos) (value) + (setf (buffer-gap-context-right-open-pos (current-gap-context)) value)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/symbol-completion.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/symbol-completion.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/symbol-completion.lisp (revision 8058) @@ -0,0 +1,391 @@ +;;; -*- Package: Hemlock -*- +;;; +;;; Copyright (c) 2007 Clozure Associates +;;; This file is part of Clozure Common Lisp. +;;; +;;; Dynamic symbol completion +;;; gz@clozure.com +;;; +;;; This uses wordchar attributes set up in completion.lisp, but otherwise is unrelated. + +(in-package :hemlock) + +;; Context maintained so repeated M-/'s can walk through all available abbreviations + +(defstruct (dabbrev-context (:conc-name "DABBREV.")) + ;; The buffer this context belongs to + (buffer nil) + ;; The last expansion + (expansion nil) + ;; The thing that was expanded. This is usually a prefix of expansion, but it might + ;; be initials (i.e. abbrev = mvb, expansion = multiple-value-bind). + (abbrev "" :type simple-string) + ;; The package prefix if any, including the ending colon(s). + (prefix nil) + ;; The position of the end of the expansion + (end-mark nil) + ;; buffer-signature as of the time the expansion was inserted. + (signature nil) + ;; list of expansions already tried and rejected + (seen ()) + ;; List of places to try next + (state-path '(:before-point :after-point :other-buffers :this-package :other-packages)) + ;; Sequence of sources to go thru before changing state + (sources '(:last-used)) + ;; a sequence of expansions to go thru before changing source + (seq (make-array 10 :fill-pointer 0 :adjustable t))) + +(defun symbol-completion-buffer-hook (buffer) + (defhvar "DAbbrev Context" + "Internal variable for cycling through symbol completions" + :buffer buffer + :value nil) + (defhvar "DAbbrev Cache" + "Internal variable for caching symbols in buffer" + :buffer buffer + ;; Cons of buffer sig and a vector of all symbols in buffer as of the time + ;; of the buffer sig. + :value (cons nil nil)) + ) + +(add-hook make-buffer-hook #'symbol-completion-buffer-hook) + +;; Global table of all abbrevs expanded in this session, and the last value they expanded to. +(defvar *dabbrevs* (make-hash-table :test #'equalp)) + +(defun dabbrev-package (context) + (or (dabbrev-package-for-prefix (dabbrev.prefix context)) + ;; TODO: look for in-package form preceeding point... + (buffer-package (dabbrev.buffer context)))) + +(defun dabbrev-external-symbol-p (context) + ;; True if explicitly looking for an external symbol. + (let* ((prefix (dabbrev.prefix context)) + (prefix-len (length prefix))) + (or (eql prefix-len 1) + (and (>= prefix-len 2) + (not (eql (aref prefix (- prefix-len 2)) #\:)))))) + +(defun dabbrev-package-for-prefix (prefix) + (when prefix + (let* ((prefix-len (length prefix))) + (if (eql prefix-len 1) + ccl::*keyword-package* + (find-package (subseq prefix 0 (if (eql (aref prefix (- prefix-len 2)) #\:) + (- prefix-len 2) + (- prefix-len 1)))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; State machine support: + +(defun dabbrev-next-expansion (context) + (cond ((> (length (dabbrev.seq context)) 0) + (let* ((exp (vector-pop (dabbrev.seq context)))) + (if (find exp (dabbrev.seen context) :test #'string=) + (dabbrev-next-expansion context) + exp))) + ((dabbrev.sources context) + (dabbrev-collect-expansions (pop (dabbrev.sources context)) context) + (dabbrev-next-expansion context)) + ((dabbrev.state-path context) + (setf (dabbrev.sources context) + (dabbrev-sources-in (pop (dabbrev.state-path context)) context)) + (dabbrev-next-expansion context)) + (t nil))) + + +;; dabbrev-sources-in: maps state -> sources + +(defmethod dabbrev-sources-in ((state t) context) + (declare (ignore context)) + (list state)) + +(defmethod dabbrev-sources-in ((state (eql :other-buffers)) context) + (let* ((buffers (mapcar #'window-buffer (gui::ordered-hemlock-windows)))) + ;; Remove duplicates, always keeping the first occurance (frontmost window) + (loop for blist on buffers do (setf (cdr blist) (delete (car blist) (cdr blist)))) + (delete (dabbrev.buffer context) buffers))) + +(defmethod dabbrev-sources-in ((state (eql :other-packages)) context) + (let* ((all (copy-list (list-all-packages))) + (this-package (dabbrev-package context)) + (keyword-package ccl::*keyword-package*)) + (setq all (delete this-package all)) + (unless (eq this-package keyword-package) + (setq all (nconc (delete keyword-package all) (list keyword-package)))) + all)) + +;; dabbrev-collect-expansion: maps source -> expansions +;; Note that in general these methods don't bother to check for dabbrev.seen +;; or duplicates, even though they could, because there is no reason to spend +;; time up front on checking expansions we might never get to. + +(defun dabbrev-match-p (context exp) + (let* ((abbrev (dabbrev.abbrev context)) + (abbrev-len (length abbrev))) + (or (and (< abbrev-len (length exp)) + (string-equal abbrev exp :end1 abbrev-len :end2 abbrev-len)) + ;; Check for initials. + (loop + for char across abbrev + for pos = 0 then (and (setq pos (position-if-not #'alphanumericp exp :start pos)) + (position-if #'alphanumericp exp :start (1+ pos))) + always (and pos (char-equal char (aref exp pos))))))) + +(defmethod dabbrev-collect-expansions ((source (eql :last-used)) context) + (let* ((abbrev (dabbrev.abbrev context)) + (prefix (dabbrev.prefix context)) + (abbrev-len (length abbrev)) + (prefix-len (length prefix)) + (string (concatenate 'string abbrev prefix))) + (loop + for end from (+ abbrev-len prefix-len) downto prefix-len + for key = string then (subseq string 0 end) + as exp = (gethash key *dabbrevs*) + when (and exp (dabbrev-match-p context exp)) + do (return (vector-push-extend exp (dabbrev.seq context)))))) + +(defmethod dabbrev-collect-expansions ((buffer buffer) context) + ;; TODO: need to take prefix into account - give preferences to things + ;; matching prefix. For now, ignore the prefix-only case here since can't + ;; do anything useful. + (unless (equal (dabbrev.abbrev context) "") + (let* ((vec (dabbrev-symbols-in-buffer buffer)) + (seq (dabbrev.seq context))) + (loop + for exp across vec + when (dabbrev-match-p context exp) + do (vector-push-extend exp seq)) + seq))) + +;; TODO: have a background process that does this. (Since the architecture doesn't allow locking +;; against buffer changes, might need to do ignore-errors and just bludgeon through, checking +;; for sig changes at end. Or perhaps could use the modification hook, if that's reliable) +(defun dabbrev-symbols-in-buffer (buffer) + (let* ((cache (variable-value 'dabbrev-cache :buffer buffer))) + (unless (and cache (eql (car cache) (buffer-signature buffer))) + (let* ((hi::*current-buffer* buffer) + (start-mark (buffer-start-mark buffer)) + (symbols (make-array 100 :adjustable t :fill-pointer 0))) + (with-mark ((word-start start-mark) + (word-end start-mark)) + (loop + (unless (find-attribute word-end :completion-wordchar) (return)) + (move-mark word-start word-end) + (unless (find-not-attribute word-end :completion-wordchar) + (buffer-end word-end)) + (let* ((word (region-to-string (region word-start word-end)))) + (unless (find word symbols :test #'equal) + (vector-push-extend word symbols))))) + (setf (variable-value 'dabbrev-cache :buffer buffer) + (setq cache (cons (buffer-signature buffer) (coerce symbols 'simple-vector)))))) + (cdr cache))) + +(defun dabbrev-next-in-buffer (mark temp-mark temp-string) + ;; Leaves temp-mark at start and point-mark at end of next symbol + (when (find-attribute mark :completion-wordchar) + (move-mark temp-mark mark) + (unless (find-not-attribute mark :completion-wordchar) + (buffer-end mark)) + (region-to-string (region temp-mark mark) temp-string))) + +(defun dabbrev-prev-in-buffer (mark temp-mark temp-string) + (when (reverse-find-attribute mark :completion-wordchar) + (move-mark temp-mark mark) + (unless (reverse-find-not-attribute mark :completion-wordchar) + (buffer-start mark)) + (region-to-string (region mark temp-mark) temp-string))) + +(defmethod dabbrev-collect-expansions ((source (eql :before-point)) context) + (dabbrev-collect-expansions-1 source context)) + +(defmethod dabbrev-collect-expansions ((source (eql :after-point)) context) + (dabbrev-collect-expansions-1 source context)) + +(defun dabbrev-collect-expansions-1 (direction context) + (let* ((buffer (dabbrev.buffer context)) + (point (buffer-point buffer)) + (abbrev (dabbrev.abbrev context)) + (abbrev-len (length abbrev)) + (seq (dabbrev.seq context)) + (temp-string (make-string 30))) + ;; TODO: need to take prefix into account - give preferences to things + ;; matching prefix. For now, ignore the prefix-only case here since can't + ;; do anything useful. + (when (eql abbrev-len 0) + (return-from dabbrev-collect-expansions-1)) + (with-mark ((mark point) (temp-mark point)) + (when (eq direction :before-point) (character-offset mark (- abbrev-len))) + (loop + (multiple-value-bind (word word-len) + (if (eq direction :before-point) + (dabbrev-prev-in-buffer mark temp-mark temp-string) + (dabbrev-next-in-buffer mark temp-mark temp-string)) + (unless word (return)) + (when (and (< abbrev-len word-len) + (string-equal word abbrev :end1 abbrev-len :end2 abbrev-len)) + (let* ((word (subseq word 0 word-len))) + (unless (find word seq :test #'equal) + (vector-push-extend word seq))))))) + (nreverse seq))) + +(defmethod dabbrev-collect-expansions ((source (eql :this-package)) context) + (let* ((pkg (dabbrev-package context)) + (seq (dabbrev.seq context))) + (when pkg + (when (dabbrev.prefix context) + (if (or (dabbrev-external-symbol-p context) + (eq pkg ccl::*keyword-package*)) + (do-external-symbols (sym pkg) + (when (and (not (find sym seq :test #'eq)) + (dabbrev-match-p context (symbol-name sym))) + (vector-push-extend sym seq))) + (ccl::do-present-symbols (sym pkg) + (when (and (not (find sym seq :test #'eq)) + (dabbrev-match-p context (symbol-name sym))) + (vector-push-extend sym seq))))) + (unless (eq pkg ccl::*keyword-package*) + (do-symbols (sym pkg) + (when (and (not (find sym seq :test #'eq)) + (dabbrev-match-p context (symbol-name sym))) + (vector-push-extend sym seq)))) + (stable-sort seq #'(lambda (s1 s2) + (and (or (boundp s1) (fboundp s1)) + (not (or (boundp s2) (fboundp s2)))))) + ;; Now convert to strings - and downcase for inserting in buffer. + (dotimes (i (length seq)) + (setf (aref seq i) (string-downcase (symbol-name (aref seq i)))))) + seq)) + +(defmethod dabbrev-collect-expansions ((pkg package) context) + ;; For random packages, only need to do present symbols, since imported ones will be + ;; shown in their own package. + (let* ((seq (dabbrev.seq context))) + (ccl::do-present-symbols (sym pkg) + (let* ((name (symbol-name sym))) + (when (dabbrev-match-p context name) + (vector-push-extend (string-downcase name) seq)))) + seq)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; the command + + +(defcommand "Expand Dynamic Abbreviation" (p) + "Treats the symbol before point as an abbreviation and expands it. +It checks the following in order until a suitable expansion is found: + - last accepted expansion for this abbreviation, if any + - symbols in current buffer before point + - symbols in current buffer after point + - symbols in all other editor windows, front to back + - symbols visible in the current package, fbound/bound symbols first + - symbols in all other packages (in no particular order) + +If called repeatedly from the same position, replaces the previous expansion +with the next possible one. + +A symbol is a suitable expansion for an abbreviation if the abbreviation is +a proper prefix of the symbol, or the abbreviation consists of the initials +of the individual words within the symbol (e.g. mvb => multiple-value-bind). +" + (declare (ignore p)) + (let* ((buffer (current-buffer)) + (point (buffer-point buffer)) + (context (dabbrev-command-init buffer)) + (abbrev (dabbrev.abbrev context)) + (abbrev-len (length abbrev)) + (expansion (dabbrev-next-expansion context)) + (expansion-len (length expansion))) + (when (null expansion) + (editor-error "No~:[ more~] expansions for ~s" + (null (dabbrev.expansion context)) + abbrev)) + (push expansion (dabbrev.seen context)) + (setf (dabbrev.expansion context) expansion) + (setf (gethash abbrev *dabbrevs*) expansion) + (if (and (>= expansion-len abbrev-len) + (string= abbrev expansion :end2 abbrev-len)) + (insert-string point (subseq expansion abbrev-len)) + (progn + (delete-characters point (- abbrev-len)) + (insert-string point expansion))) + (move-mark (dabbrev.end-mark context) point) + (setf (dabbrev.signature context) (buffer-signature buffer)))) + +#+gz ;; This tests the generation of completion candidates +;; (time(hemlock::test-completions (cadr hi::*buffer-list*) "dabbrev")) +(defun test-completions (buffer abbrev) + (let* ((hi::*current-buffer* buffer) + (point (buffer-point buffer)) + (context (make-dabbrev-context + :buffer buffer + :abbrev abbrev + ;; Can use a temp mark (i.e. the kind that doesn't automatically + ;; update) because we only use it while buffer is unmodified. + :end-mark (copy-mark point :temporary)))) + (loop as expansion = (dabbrev-next-expansion context) while expansion + do (push expansion (dabbrev.seen context)) + do (setf (dabbrev.expansion context) expansion) + do (setf (gethash abbrev *dabbrevs*) expansion)) + (dabbrev.seen context))) + +;; Reinitialize context to either restart or cycle to next completion. +;; In the latter case, undoes the last completion in the buffer. +(defun dabbrev-command-init (buffer) + (let* ((point (buffer-point buffer)) + (context (variable-value 'dabbrev-context :buffer buffer))) + (if (and context + ;; If buffer not modified since last time + (eql (dabbrev.signature context) (buffer-signature buffer)) + ;; and cursor not moved elsewhere + (mark= (dabbrev.end-mark context) point)) + ;; This means rejected previous attempt, get rid of it. + (let* ((abbrev (dabbrev.abbrev context)) + (abbrev-len (length abbrev)) + (expansion (dabbrev.expansion context)) + (expansion-len (length expansion))) + ;; Sanity check, because I don't totally trust buffer-signature ... + (with-mark ((mark point)) + (assert (and (character-offset mark (- (length expansion))) + (equal (region-to-string (region mark point)) expansion)) + () "Bug! Buffer changed unexpectedly")) + (if (and (>= expansion-len abbrev-len) + (string= abbrev expansion :end2 abbrev-len)) + (delete-characters point (- abbrev-len expansion-len)) + (progn + (delete-characters point (- expansion-len)) + (insert-string point abbrev)))) + ;; Else starting a new attempt, create a new context + (let* ((mark (copy-mark point :temporary))) + (multiple-value-bind (abbrev prefix) (dabbrev-get-abbrev mark point) + (when (and (equal abbrev "") (equal prefix "")) + (editor-error "Nothing to expand")) + (setq context (make-dabbrev-context + :buffer buffer + :abbrev abbrev + :prefix prefix + ;; Can use a temp mark (i.e. the kind that doesn't automatically + ;; update) because we only use it while buffer is unmodified. + :end-mark mark))) + (setf (variable-value 'dabbrev-context :buffer buffer) context))) + (move-mark (dabbrev.end-mark context) point) + context)) + +(defun dabbrev-get-abbrev (mark point) + (declare (values abbrev package-prefix)) + (move-mark mark point) + (unless (reverse-find-not-attribute mark :completion-wordchar) + (buffer-start mark)) + (values (region-to-string (region mark point)) + (when (eql (previous-character mark) #\:) + (with-mark ((temp mark)) + (character-offset temp -1) + (when (eql (previous-character temp) #\:) + (character-offset temp -1)) + (unless (reverse-find-not-attribute temp :completion-wordchar) + (buffer-start temp)) + (region-to-string (region temp mark)))))) + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/syntax.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/syntax.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/syntax.lisp (revision 8058) @@ -0,0 +1,585 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock syntax table routines. +;;; +;;; Written by Rob MacLachlan. +;;; + +(in-package :hemlock-internals) + + + +;;;; Character attribute caching. +;;; +;;; In order to permit the %SP-Find-Character-With-Attribute sub-primitive +;;; to be used for a fast implementation of find-attribute and +;;; reverse-find-attribute, there must be some way of translating +;;; attribute/test-function pairs into a attribute vector and a mask. +;;; What we do is maintain a eq-hash-cache of attribute/test-function +;;; pairs. If the desired pair is not in the cache then we reclaim an old +;;; attribute bit in the bucket we hashed to and stuff it by calling the +;;; test function on the value of the attribute for all characters. + +(defvar *character-attribute-cache* () + "This is the cache used to translate attribute/test-function pairs to + attribute-vector/mask pairs for find-attribute and reverse-find-attribute.") + +(eval-when (:compile-toplevel :execute :load-toplevel) +(defconstant character-attribute-cache-size 13 + "The number of buckets in the *character-attribute-cache*.") +(defconstant character-attribute-bucket-size 3 + "The number of bits to use in each bucket of the + *character-attribute-cache*.") +); eval-when (:compile-toplevel :execute :load-toplevel) + +;;; In addition, since a common pattern in code which uses find-attribute +;;; is to repeatedly call it with the same function and attribute, we +;;; remember the last attribute/test-function pair that was used, and check +;;; if it is the same pair beforehand, thus often avoiding the hastable lookup. +;;; +(defvar *last-find-attribute-attribute* () + "The attribute which we last did a find-attribute on.") +(defvar *last-find-attribute-function* () + "The last test-function used for find-attribute.") +(defvar *last-find-attribute-vector* () + "The %SP-Find-Character-With-Attribute vector corresponding to the last + attribute/function pair used for find-attribute.") +(defvar *last-find-attribute-mask* () + "The the mask to use with *last-find-attribute-vector* to do a search + for the last attribute/test-function pair.") +(defvar *last-find-attribute-end-wins* () + "The the value of End-Wins for the last attribute/test-function pair.") + + +(defvar *character-attributes* (make-hash-table :test #'eq) + "A hash table which translates character attributes to their values.") +(defvar *last-character-attribute-requested* nil + "The last character attribute which was asked for, Do Not Bind.") +(defvar *value-of-last-character-attribute-requested* nil + "The value of the most recent character attribute, Do Not Bind.") + +(declaim (special *character-attribute-names*)) + + +;;; Each bucket contains a list of character-attribute-bucket-size +;;; bit-descriptors. +;;; +(defstruct (bit-descriptor) + function ; The test on the attribute. + attribute ; The attribute this is a test of. + (mask 0 :type fixnum) ; The mask for the corresponding bit. + vector ; The vector the bit is in. + end-wins) ; Is this test true of buffer ends? + +;;; +;;; In a descriptor for an unused bit, the function is nil, preventing a +;;; hit. Whenever we change the value of an attribute for some character, +;;; we need to flush the cache of any entries for that attribute. Currently +;;; we do this by mapping down the list of all bit descriptors. Note that +;;; we don't have to worry about GC, since this is just a hint. +;;; +(defvar *all-bit-descriptors* () "The list of all the bit descriptors.") + + +(eval-when (:compile-toplevel :execute) +(defmacro allocate-bit (vec bit-num) + `(progn + (when (= ,bit-num 8) + (setq ,bit-num 0 ,vec (make-array 256 :element-type '(mod 256)))) + (car (push (make-bit-descriptor + :vector ,vec + :mask (ash 1 (prog1 ,bit-num (incf ,bit-num)))) + *all-bit-descriptors*))))) +;;; +(defun %init-syntax-table () + (let ((tab (make-array character-attribute-cache-size)) + (bit-num 8) vec) + (setq *character-attribute-cache* tab) + (dotimes (c character-attribute-cache-size) + (setf (svref tab c) + (do ((i 0 (1+ i)) + (res ())) + ((= i character-attribute-bucket-size) res) + (push (allocate-bit vec bit-num) res)))))) + + +(eval-when (:compile-toplevel :execute) +#+NIL +(defmacro hash-it (attribute function) + `(abs (rem (logxor (ash (lisp::%sp-make-fixnum ,attribute) -3) + (lisp::%sp-make-fixnum ,function)) + character-attribute-cache-size))) +(defmacro hash-it (attribute function) + `(abs (rem (logxor (ash (sxhash ,attribute) -3) + (sxhash ,function)) + character-attribute-cache-size))) + +;;; CACHED-ATTRIBUTE-LOOKUP -- Internal +;;; +;;; Sets Vector and Mask such that they can be used as arguments +;;; to %sp-find-character-with-attribute to effect a search with attribute +;;; Attribute and test Function. If the function and attribute +;;; are the same as the last ones then we just set them to that, otherwise +;;; we do the hash-cache lookup and update the *last-find-attribute-* +;;; +(defmacro cached-attribute-lookup (attribute function vector mask end-wins) + `(if (and (eq ,function *last-find-attribute-function*) + (eq ,attribute *last-find-attribute-attribute*)) + (setq ,vector *last-find-attribute-vector* + ,mask *last-find-attribute-mask* + ,end-wins *last-find-attribute-end-wins*) + (let ((bit (svref *character-attribute-cache* + (hash-it ,attribute ,function)))) + ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins) + (new-cache-attribute ,attribute ,function)) + `(let ((b (car bit))) + (cond + ((and (eq (bit-descriptor-function b) + ,function) + (eq (bit-descriptor-attribute b) + ,attribute)) + (setq ,vector (bit-descriptor-vector b) + ,mask (bit-descriptor-mask b) + ,end-wins (bit-descriptor-end-wins b))) + (t + (setq bit (cdr bit)) ,res)))) + (count 0 (1+ count))) + ((= count character-attribute-bucket-size) res)) + (setq *last-find-attribute-attribute* ,attribute + *last-find-attribute-function* ,function + *last-find-attribute-vector* ,vector + *last-find-attribute-mask* ,mask + *last-find-attribute-end-wins* ,end-wins)))) +); eval-when (:compile-toplevel :execute) + +;;; NEW-CACHE-ATTRIBUTE -- Internal +;;; +;;; Pick out an old attribute to punt out of the cache and put in the +;;; new one. We pick a bit off of the end of the bucket and pull it around +;;; to the beginning to get a degree of LRU'ness. +;;; +(defun new-cache-attribute (attribute function) + (let* ((hash (hash-it attribute function)) + (values (or (gethash attribute *character-attributes*) + (error "~S is not a defined character attribute." + attribute))) + (bucket (svref *character-attribute-cache* hash)) + (bit (nthcdr (- character-attribute-bucket-size 2) bucket)) + (end-wins (funcall function (attribute-descriptor-end-value values)))) + (shiftf bit (cdr bit) nil) + (setf (svref *character-attribute-cache* hash) bit + (cdr bit) bucket bit (car bit)) + (setf (bit-descriptor-attribute bit) attribute + (bit-descriptor-function bit) function + (bit-descriptor-end-wins bit) end-wins) + (setq values (attribute-descriptor-vector values)) + (do ((mask (bit-descriptor-mask bit)) + (fun (bit-descriptor-function bit)) + (vec (bit-descriptor-vector bit)) + (i 0 (1+ i))) + ((= i syntax-char-code-limit) (values vec mask end-wins)) + (declare (type (simple-array (mod 256)) vec)) + (if (funcall fun (aref (the simple-array values) i)) + (setf (aref vec i) (logior (aref vec i) mask)) + (setf (aref vec i) (logandc2 (aref vec i) mask)))))) + + +(defun %print-attribute-descriptor (object stream depth) + (declare (ignore depth)) + (format stream "#" + (attribute-descriptor-name object))) + +;;; DEFATTRIBUTE -- Public +;;; +;;; Make a new vector of some type and enter it in the table. +;;; +(defun defattribute (name documentation &optional (type '(mod 2)) + (initial-value 0)) + "Define a new Hemlock character attribute with named Name with + the supplied Documentation, Type and Initial-Value. Type + defaults to (mod 2) and Initial-Value defaults to 0." + (setq name (coerce name 'simple-string)) + (let* ((attribute (string-to-keyword name)) + (new (make-attribute-descriptor + :vector (make-array syntax-char-code-limit + :element-type type + :initial-element initial-value) + :name name + :keyword attribute + :documentation documentation + :end-value initial-value))) + (when (gethash attribute *character-attributes*) + (warn "Character Attribute ~S is being redefined." name)) + (setf (getstring name *character-attribute-names*) attribute) + (setf (gethash attribute *character-attributes*) new)) + name) + +;;; WITH-ATTRIBUTE -- Internal +;;; +;;; Bind obj to the attribute descriptor corresponding to symbol, +;;; giving error if it is not a defined attribute. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro with-attribute (symbol &body forms) + `(let ((obj (gethash ,symbol *character-attributes*))) + (unless obj + (error "~S is not a defined character attribute." ,symbol)) + ,@forms)) +); eval-when (:compile-toplevel :execute) + +(defun character-attribute-name (attribute) + "Return the string-name of the character-attribute Attribute." + (with-attribute attribute + (attribute-descriptor-name obj))) + +(defun character-attribute-documentation (attribute) + "Return the documentation for the character-attribute Attribute." + (with-attribute attribute + (attribute-descriptor-documentation obj))) + +(defun character-attribute-hooks (attribute) + "Return the hook-list for the character-attribute Attribute. This can + be set with Setf." + (with-attribute attribute + (attribute-descriptor-hooks obj))) + +(defun %set-character-attribute-hooks (attribute new-value) + (with-attribute attribute + (setf (attribute-descriptor-hooks obj) new-value))) + +(declaim (special *last-character-attribute-requested* + *value-of-last-character-attribute-requested*)) + +;;; CHARACTER-ATTRIBUTE -- Public +;;; +;;; Return the value of a character attribute for some character. +;;; +(declaim (inline character-attribute)) +(defun character-attribute (attribute character) + "Return the value of the the character-attribute Attribute for Character. + If Character is Nil then return the end-value." + (if (and (eq attribute *last-character-attribute-requested*) character) + (aref (the simple-array *value-of-last-character-attribute-requested*) + (syntax-char-code character)) + (sub-character-attribute attribute character))) +;;; +(defun sub-character-attribute (attribute character) + (with-attribute attribute + (setq *last-character-attribute-requested* attribute) + (setq *value-of-last-character-attribute-requested* + (attribute-descriptor-vector obj)) + (if character + (aref (the simple-array *value-of-last-character-attribute-requested*) + (syntax-char-code character)) + (attribute-descriptor-end-value obj)))) + +;;; CHARACTER-ATTRIBUTE-P +;;; +;;; Look up attribute in table. +;;; +(defun character-attribute-p (symbol) + "Return true if Symbol is the symbol-name of a character-attribute, Nil + otherwise." + (not (null (gethash symbol *character-attributes*)))) + + + +;;; %SET-CHARACTER-ATTRIBUTE -- Internal +;;; +;;; Set the value of a character attribute. +;;; +(defun %set-character-attribute (attribute character new-value) + (with-attribute attribute + (invoke-hook hemlock::character-attribute-hook attribute character new-value) + (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value) + (cond + ;; + ;; Setting the value for a real character. + (character + (let ((value (attribute-descriptor-vector obj)) + (code (syntax-char-code character))) + (declare (type (simple-array *) value)) + (dolist (bit *all-bit-descriptors*) + (when (eq (bit-descriptor-attribute bit) attribute) + (let ((vec (bit-descriptor-vector bit))) + (declare (type (simple-array (mod 256)) vec)) + (setf (aref vec code) + (if (funcall (bit-descriptor-function bit) new-value) + (logior (bit-descriptor-mask bit) (aref vec code)) + (logandc1 (bit-descriptor-mask bit) (aref vec code))))))) + (setf (aref value code) new-value))) + ;; + ;; Setting the magical end-value. + (t + (setf (attribute-descriptor-end-value obj) new-value) + (dolist (bit *all-bit-descriptors*) + (when (eq (bit-descriptor-attribute bit) attribute) + (setf (bit-descriptor-end-wins bit) + (funcall (bit-descriptor-function bit) new-value)))) + new-value)))) + + +(eval-when (:compile-toplevel :execute) +;;; swap-one-attribute -- Internal +;;; +;;; Install the mode-local values described by Vals for Attribute, whose +;;; representation vector is Value. +;;; + (defmacro swap-one-attribute (attribute value vals hooks) + `(progn + ;; Fix up any cached attribute vectors. + (dolist (bit *all-bit-descriptors*) + (when (eq ,attribute (bit-descriptor-attribute bit)) + (let ((fun (bit-descriptor-function bit)) + (vec (bit-descriptor-vector bit)) + (mask (bit-descriptor-mask bit))) + (declare (type (simple-array (mod 256)) vec) + (fixnum mask)) + (dolist (char ,vals) + (setf (aref vec (car char)) + (if (funcall fun (cdr char)) + (logior mask (aref vec (car char))) + (logandc1 mask (aref vec (car char))))))))) + ;; Invoke the attribute-hook. + (dolist (hook ,hooks) + (dolist (char ,vals) + (funcall hook ,attribute (code-char (car char)) (cdr char)))) + ;; Fix up the value vector. + (dolist (char ,vals) + (rotatef (aref ,value (car char)) (cdr char))))) +); eval-when (:compile-toplevel :execute) + + +;;; SWAP-CHAR-ATTRIBUTES -- Internal +;;; +;;; Swap the current values of character attributes and the ones +;;;specified by "mode". This is used in Set-Major-Mode. +;;; +(defun swap-char-attributes (mode) + (dolist (attribute (mode-object-character-attributes mode)) + (let* ((obj (car attribute)) + (sym (attribute-descriptor-keyword obj)) + (value (attribute-descriptor-vector obj)) + (hooks (attribute-descriptor-hooks obj))) + (declare (simple-array value)) + (swap-one-attribute sym value (cdr attribute) hooks)))) + + + + +(declaim (special *mode-names* *current-buffer*)) + +;;; SHADOW-ATTRIBUTE -- Public +;;; +;;; Stick mode character attribute information in the mode object. +;;; +(defun shadow-attribute (attribute character value mode) + "Make a mode specific character attribute value. The value of + Attribute for Character when we are in Mode will be Value." + (let ((desc (gethash attribute *character-attributes*)) + (obj (getstring mode *mode-names*))) + (unless desc + (error "~S is not a defined Character Attribute." attribute)) + (unless obj (error "~S is not a defined Mode." mode)) + (let* ((current (assoc desc (mode-object-character-attributes obj))) + (code (syntax-char-code character)) + (hooks (attribute-descriptor-hooks desc)) + (vec (attribute-descriptor-vector desc)) + (cons (cons code value))) + (declare (simple-array vec)) + (if current + (let ((old (assoc code (cdr current)))) + (if old + (setf (cdr old) value cons old) + (push cons (cdr current)))) + (push (list desc cons) + (mode-object-character-attributes obj))) + (when (member obj (buffer-mode-objects *current-buffer*)) + (let ((vals (list cons))) + (swap-one-attribute attribute vec vals hooks))) + (invoke-hook hemlock::shadow-attribute-hook attribute character value mode))) + attribute) + +;;; UNSHADOW-ATTRIBUTE -- Public +;;; +;;; Nuke a mode character attribute. +;;; +(defun unshadow-attribute (attribute character mode) + "Make the value of Attribte for Character no longer shadowed in Mode." + (let ((desc (gethash attribute *character-attributes*)) + (obj (getstring mode *mode-names*))) + (unless desc + (error "~S is not a defined Character Attribute." attribute)) + (unless obj + (error "~S is not a defined Mode." mode)) + (invoke-hook hemlock::shadow-attribute-hook mode attribute character) + (let* ((value (attribute-descriptor-vector desc)) + (hooks (attribute-descriptor-hooks desc)) + (current (assoc desc (mode-object-character-attributes obj))) + (char (assoc (syntax-char-code character) (cdr current)))) + (declare (simple-array value)) + (unless char + (error "Character Attribute ~S is not defined for character ~S ~ + in Mode ~S." attribute character mode)) + (when (member obj (buffer-mode-objects *current-buffer*)) + (let ((vals (list char))) + (swap-one-attribute attribute value vals hooks))) + (setf (cdr current) (delete char (the list (cdr current)))))) + attribute) + + + +;;; NOT-ZEROP, the default test function for find-attribute etc. +;;; +(defun not-zerop (n) + (not (zerop n))) + +;;; find-attribute -- Public +;;; +;;; Do hairy cache lookup to find a find-character-with-attribute style +;;; vector that we can use to do the search. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro normal-find-attribute (line start result vector mask) + `(let ((chars (line-chars ,line))) + (setq ,result (%sp-find-character-with-attribute + chars ,start (strlen chars) ,vector ,mask)))) +;;; +(defmacro cache-find-attribute (start result vector mask) + `(let ((gap (- (current-right-open-pos) (current-left-open-pos)))) + (declare (fixnum gap)) + (cond + ((>= ,start (current-left-open-pos)) + (setq ,result + (%sp-find-character-with-attribute + (current-open-chars) (+ ,start gap) (current-line-cache-length) ,vector ,mask)) + (when ,result (decf ,result gap))) + ((setq ,result (%sp-find-character-with-attribute + (current-open-chars) ,start (current-left-open-pos) ,vector ,mask))) + (t + (setq ,result + (%sp-find-character-with-attribute + (current-open-chars) (current-right-open-pos) (current-line-cache-length) ,vector ,mask)) + (when ,result (decf ,result gap)))))) +); eval-when (:compile-toplevel :execute) +;;; +(defun find-attribute (mark attribute &optional (test #'not-zerop)) + "Find the next character whose attribute value satisfies test." + (let ((charpos (mark-charpos mark)) + (line (mark-line mark)) + (mask 0) + vector end-wins) + (declare (type (or (simple-array (mod 256)) null) vector) (fixnum mask) + (type (or fixnum null) charpos)) + (cached-attribute-lookup attribute test vector mask end-wins) + (cond + ((cond + ((current-open-line-p line) + (when (cache-find-attribute charpos charpos vector mask) + (setf (mark-charpos mark) charpos) mark)) + (t + (when (normal-find-attribute line charpos charpos vector mask) + (setf (mark-charpos mark) charpos) mark)))) + ;; Newlines win and there is one. + ((and (not (zerop (logand mask (aref vector (char-code #\newline))))) + (line-next line)) + (move-to-position mark (line-length line) line)) + ;; We can ignore newlines. + (t + (do (prev) + (()) + (setq prev line line (line-next line)) + (cond + ((null line) + (if end-wins + (return (line-end mark prev)) + (return nil))) + ((current-open-line-p line) + (when (cache-find-attribute 0 charpos vector mask) + (return (move-to-position mark charpos line)))) + (t + (when (normal-find-attribute line 0 charpos vector mask) + (return (move-to-position mark charpos line)))))))))) + +(defun find-not-attribute (mark attribute) + (find-attribute mark attribute #'zerop)) + + +;;; REVERSE-FIND-ATTRIBUTE -- Public +;;; +;;; Line find-attribute, only goes backwards. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro rev-normal-find-attribute (line start result vector mask) + `(let ((chars (line-chars ,line))) + (setq ,result (%sp-reverse-find-character-with-attribute + chars 0 ,(or start '(strlen chars)) ,vector ,mask)))) +;;; +(defmacro rev-cache-find-attribute (start result vector mask) + `(let ((gap (- (current-right-open-pos) (current-left-open-pos)))) + (declare (fixnum gap)) + (cond + ,@(when start + `(((<= ,start (current-left-open-pos)) + (setq ,result + (%sp-reverse-find-character-with-attribute + (current-open-chars) 0 ,start ,vector ,mask))))) + ((setq ,result (%sp-reverse-find-character-with-attribute + (current-open-chars) (current-right-open-pos) + ,(if start `(+ ,start gap) '(current-line-cache-length)) + ,vector ,mask)) + (decf ,result gap)) + (t + (setq ,result + (%sp-reverse-find-character-with-attribute + (current-open-chars) 0 (current-left-open-pos) ,vector ,mask)))))) + +); eval-when (:compile-toplevel :execute) +;;; +;;; This moves the mark so that previous-character satisfies the test. +(defun reverse-find-attribute (mark attribute &optional (test #'not-zerop)) + "Find the previous character whose attribute value satisfies test." + (let* ((charpos (mark-charpos mark)) + (line (mark-line mark)) vector mask end-wins) + (declare (type (or (simple-array (mod 256)) null) vector) + (type (or fixnum null) charpos)) + (cached-attribute-lookup attribute test vector mask end-wins) + (cond + ((cond + ((current-open-line-p line) + (when (rev-cache-find-attribute charpos charpos vector mask) + (setf (mark-charpos mark) (1+ charpos)) mark)) + (t + (when (rev-normal-find-attribute line charpos charpos vector mask) + (setf (mark-charpos mark) (1+ charpos)) mark)))) + ;; Newlines win and there is one. + ((and (line-previous line) + (not (zerop (logand mask (aref vector (char-code #\newline)))))) + (move-to-position mark 0 line)) + (t + (do (next) + (()) + (setq next line line (line-previous line)) + (cond + ((null line) + (if end-wins + (return (line-start mark next)) + (return nil))) + ((current-open-line-p line) + (when (rev-cache-find-attribute nil charpos vector mask) + (return (move-to-position mark (1+ charpos) line)))) + (t + (when (rev-normal-find-attribute line nil charpos vector mask) + (return (move-to-position mark (1+ charpos) line)))))))))) + +(defun reverse-find-not-attribute (mark attribute) + (reverse-find-attribute mark attribute #'zerop)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/table.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/table.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/table.lisp (revision 8058) @@ -0,0 +1,748 @@ +;;; -*- Log: hemlock.log; Package: hemlock-internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Reluctantly written by Christopher Hoover +;;; Supporting cast includes Rob and Bill. +;;; +;;; This file defines a data structure, analogous to a Common Lisp +;;; hashtable, which translates strings to values and facilitates +;;; recognition and completion of these strings. +;;; + +(in-package :hemlock-internals) + + + +;;;; Implementation Details + +;;; String tables are a data structure somewhat analogous to Common Lisp +;;; hashtables. String tables are case-insensitive. Functions are +;;; provided to quickly look up strings, insert strings, disambiguate or +;;; complete strings, and to provide a variety of ``help'' when +;;; disambiguating or completing strings. +;;; +;;; String tables are represented as a series of word tables which form +;;; a tree. Four structures are used to implement this data structure. +;;; The first is a STRING-TABLE. This structure has severals slots one +;;; of which, FIRST-WORD-TABLE, points to the first word table. This +;;; first word table is also the root of tree. The STRING-TABLE +;;; structure also contains slots to keep track of the number of nodes, +;;; the string table separator (which is used to distinguish word or +;;; field boundaries), and a pointer to an array of VALUE-NODE's. +;;; +;;; A WORD-TABLE is simply an array of pointers to WORD-ENTRY's. This +;;; array is kept sorted by the FOLDED slot in each WORD-ENTRY so that a +;;; binary search can be used. Each WORD-ENTRY contains a case-folded +;;; string and a pointer to the next WORD-TABLE in the tree. By +;;; traversing the tree made up by these structures, searching and +;;; completion can easily be done. +;;; +;;; Another structure, a VALUE-NODE, is used to hold each entry in the +;;; string table and contains both a copy of the original string and a +;;; case-folded version of the original string along with the value. +;;; All of these value nodes are stored in a array (pointed at by the +;;; VALUE-NODES slot of the STRING-TABLE structure) and sorted by the +;;; FOLDED slot in the VALUE-NODE structure so that a binary search may +;;; be used to quickly find existing strings. +;;; + + + +;;;; Structure Definitions + +(defparameter initial-string-table-size 20 + "Initial size of string table array for value nodes.") +(defparameter initial-word-table-size 2 + "Inital size of each word table array for each tree node.") + +(defstruct (string-table + (:constructor %make-string-table (separator)) + (:print-function print-string-table)) + "This structure is used to implement the Hemlock string-table type." + ;; Character used to + (separator #\Space :type base-char) ; character used for word separator + (num-nodes 0 :type fixnum) ; number of nodes in string table + (value-nodes (make-array initial-string-table-size)) ; value node array + (first-word-table (make-word-table))) ; pointer to first WORD-TABLE + +(defun print-string-table (table stream depth) + (declare (ignore table depth)) + (format stream "#")) + +(defun make-string-table (&key (separator #\Space) initial-contents) + "Creates and returns a Hemlock string-table. If Intitial-Contents is + supplied in the form of an A-list of string-value pairs, these pairs + will be used to initialize the table. If Separator, which must be a + base-char, is specified then it will be used to distinguish word + boundaries." + (let ((table (%make-string-table separator))) + (dolist (x initial-contents) + (setf (getstring (car x) table) (cdr x))) + table)) + + +(defstruct (word-table + (:print-function print-word-table)) + "This structure is a word-table which is part of a Hemlock string-table." + (num-words 0 :type fixnum) ; Number of words + (words (make-array initial-word-table-size))) ; Array of WORD-ENTRY's + +(defun print-word-table (table stream depth) + (declare (ignore table depth)) + (format stream "#")) + + +(defstruct (word-entry + (:constructor make-word-entry (folded)) + (:print-function print-word-entry)) + "This structure is an entry in a word table which is part of a Hemlock + string-table." + next-table ; Pointer to next WORD-TABLE + folded ; Downcased word + value-node) ; Pointer to value node or NIL + +(defun print-word-entry (entry stream depth) + (declare (ignore depth)) + (format stream "#" (word-entry-folded entry))) + + +(defstruct (value-node + (:constructor make-value-node (proper folded value)) + (:print-function print-value-node)) + "This structure is a node containing a value in a Hemlock string-table." + folded ; Downcased copy of string + proper ; Proper copy of string entry + value) ; Value of entry + +(defun print-value-node (node stream depth) + (declare (ignore depth)) + (format stream "" (value-node-proper node))) + + + +;;;; Bi-SvPosition, String-Compare, String-Compare* + +;;; Much like the CL function POSITION; however, this is a fast binary +;;; search for simple vectors. Vector must be a simple vector and Test +;;; must be a function which returns either :equal, :less, or :greater. +;;; (The vector must be sorted from lowest index to highest index by the +;;; Test function.) Two values are returned: the first is the position +;;; Item was found or if it was not found, where it should be inserted; +;;; the second is a boolean flag indicating whether or not Item was +;;; found. +;;; +(defun bi-svposition (item vector test &key (start 0) end key) + (declare (simple-vector vector) (fixnum start)) + (let ((low start) + (high (if end end (length vector))) + (mid 0)) + (declare (fixnum low high mid)) + (loop + (when (< high low) (return (values low nil))) + (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low)) + (let* ((array-item (svref vector mid)) + (test-item (if key (funcall key array-item) array-item))) + (ecase (funcall test item test-item) + (:equal (return (values mid t))) + (:less (setf high (1- mid))) + (:greater (setf low (1+ mid)))))))) + +;;; A simple-string comparison appropriate for use with BI-SVPOSITION. +;;; +(defun string-compare (s1 s2 &key (start1 0) end1 (start2 0) end2) + (declare (simple-string s1 s2) (fixnum start1 start2)) + (let* ((end1 (or end1 (length s1))) + (end2 (or end2 (length s2))) + (pos1 (string/= s1 s2 + :start1 start1 :end1 end1 :start2 start2 :end2 end2))) + (if (null pos1) + :equal + (let ((pos2 (+ (the fixnum pos1) (- start2 start1)))) + (declare (fixnum pos2)) + (cond ((= pos1 (the fixnum end1)) :less) + ((= pos2 (the fixnum end2)) :greater) + ((char< (schar s1 (the fixnum pos1)) (schar s2 pos2)) :less) + (t :greater)))))) + +;;; Macro to return a closure to call STRING-COMPARE with the given +;;; keys. +;;; +(defmacro string-compare* (&rest keys) + `#'(lambda (x y) (string-compare x y ,@keys))) + + + +;;;; Insert-Element, Nconcf + +;;; Insert-Element is a macro which encapsulates the hairiness of +;;; inserting an element into a simple vector. Vector should be a +;;; simple vector with Num elements (which may be less than or equal to +;;; the length of the vector) and Element is the element to insert at +;;; Pos. The optional argument Grow-Factor may be specified to control +;;; the new size of the array if a new vector is necessary. The result +;;; of INSERT-ELEMENT must be used as a new vector may be created. +;;; (Note that the arguments should probably be lexicals since some of +;;; them are evaluated more than once.) +;;; +;;; We clear out the old vector so that it won't hold on to garbage if it +;;; happens to be in static space. +;;; +(defmacro insert-element (vector pos element num &optional (grow-factor 2)) + `(let ((new-num (1+ ,num)) + (max (length ,vector))) + (declare (fixnum new-num max)) + (cond ((= ,num max) + ;; grow the vector + (let ((new (make-array (truncate (* max ,grow-factor))))) + (declare (simple-vector new)) + ;; Blt the new buggers into place leaving a space for + ;; the new element + (replace new ,vector :end1 ,pos :end2 ,pos) + (replace new ,vector :start1 (1+ ,pos) :end1 new-num + :start2 ,pos :end2 ,num) + (fill ,vector nil) + (setf (svref new ,pos) ,element) + new)) + (t + ;; move the buggers down a slot + (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos) + (setf (svref ,vector ,pos) ,element) + ,vector)))) + +(define-modify-macro nconcf (&rest args) nconc) + + + +;;;; With-Folded-String, Do-Words + +;;; With-Folded-String is a macro which deals with strings from the +;;; user. First, if the original string is not a simple string then it +;;; is coerced to one. Next, the string is trimmed using the separator +;;; character and all separators between words are collapsed to a single +;;; separator. The word boundaries are pushed on to a list so that the +;;; Do-Words macro can be called anywhere within the dynamic extent of a +;;; With-Folded-String to ``do'' over the words. + +(defvar *string-buffer-size* 128) +(defvar *string-buffer* (make-string *string-buffer-size*)) +(declaim (simple-string *string-buffer*)) + +(defvar *separator-positions* nil) + +(defmacro do-words ((start-var end-var) &body body) + (let ((sep-pos (gensym))) + `(dolist (,sep-pos *separator-positions*) + (let ((,start-var (car ,sep-pos)) + (,end-var (cdr ,sep-pos))) + (locally + ,@body))))) + +(defmacro with-folded-string ((str-var len-var orig-str separator) + &body body) + `(let ((,str-var *string-buffer*)) + (declare (simple-string ,str-var)) + ;; make the string simple if it isn't already + (unless (simple-string-p ,orig-str) + (setq ,orig-str (coerce ,orig-str 'simple-string))) + ;; munge it into *string-buffer* and do the body + (let ((,len-var (with-folded-munge-string ,orig-str ,separator))) + ,@body))) + +(defun with-folded-munge-string (str separator) + (declare (simple-string str) (base-char separator)) + (let ((str-len (length str)) + (sep-pos nil) + (buf-pos 0)) + ;; Make sure we have enough room to blt the string into place. + (when (> str-len *string-buffer-size*) + (setq *string-buffer-size* (* str-len 2)) + (setq *string-buffer* (make-string *string-buffer-size*))) + ;; Bash the spaces out of the string remembering where the words are. + (let ((start-pos (position separator str :test-not #'char=))) + (when start-pos + (loop + (let* ((end-pos (position separator str + :start start-pos :test #'char=)) + (next-start-pos (and end-pos (position separator str + :start end-pos + :test-not #'char=))) + (word-len (- (or end-pos str-len) start-pos)) + (new-buf-pos (+ buf-pos word-len))) + (replace *string-buffer* str + :start1 buf-pos :start2 start-pos :end2 end-pos) + (push (cons buf-pos new-buf-pos) sep-pos) + (setf buf-pos new-buf-pos) + (when (or (null end-pos) (null next-start-pos)) + (return)) + (setf start-pos next-start-pos) + (setf (schar *string-buffer* buf-pos) separator) + (incf buf-pos))))) + (nstring-downcase *string-buffer* :end buf-pos) + (setf *separator-positions* (nreverse sep-pos)) + buf-pos)) + + + +;;;; Getstring, Setf Method for Getstring + +(defun getstring (string string-table) + "Looks up String in String-Table. Returns two values: the first is + the value of String or NIL if it does not exist; the second is a + boolean flag indicating whether or not String was found in + String-Table." + (with-folded-string (folded len string (string-table-separator string-table)) + (let ((nodes (string-table-value-nodes string-table)) + (num-nodes (string-table-num-nodes string-table))) + (declare (simple-vector nodes) (fixnum num-nodes)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded nodes (string-compare* :end1 len) + :end (1- num-nodes) :key #'value-node-folded) + (if found-p + (values (value-node-value (svref nodes pos)) t) + (values nil nil)))))) + +(defun %set-string-table (string table value) + "Sets the value of String in Table to Value. If necessary, creates + a new entry in the string table." + (with-folded-string (folded len string (string-table-separator table)) + (when (zerop len) + (error "An empty string cannot be inserted into a string-table.")) + (let ((nodes (string-table-value-nodes table)) + (num-nodes (string-table-num-nodes table))) + (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded nodes (string-compare* :end1 len) + :end (1- num-nodes) :key #'value-node-folded) + (cond (found-p + (setf (value-node-value (svref nodes pos)) value)) + (t + ;; Note that a separator collapsed copy of string is NOT + ;; used here ... + ;; + (let ((node (make-value-node string (subseq folded 0 len) value)) + (word-table (string-table-first-word-table table))) + ;; put in the value nodes array + (setf (string-table-value-nodes table) + (insert-element nodes pos node num-nodes)) + (incf (string-table-num-nodes table)) + ;; insert it into the word tree + (%set-insert-words folded word-table node)))))) + value)) + +(defun %set-insert-words (folded first-word-table value-node) + (declare (simple-string folded)) + (let ((word-table first-word-table) + (entry nil)) + (do-words (word-start word-end) + (let ((word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table))) + (declare (simple-vector word-array) (fixnum num-words)) + ;; find the entry or create a new one and insert it + (multiple-value-bind + (pos found-p) + (bi-svposition folded word-array + (string-compare* :start1 word-start :end1 word-end) + :end (1- num-words) :key #'word-entry-folded) + (declare (fixnum pos)) + (cond (found-p + (setf entry (svref word-array pos))) + (t + (setf entry (make-word-entry + (subseq folded word-start word-end))) + (setf (word-table-words word-table) + (insert-element word-array pos entry num-words)) + (incf (word-table-num-words word-table))))) + (let ((next-table (word-entry-next-table entry))) + (unless next-table + (setf next-table (make-word-table)) + (setf (word-entry-next-table entry) next-table)) + (setf word-table next-table)))) + (setf (word-entry-value-node entry) value-node))) + + + +;;;; Find-Bound-Entries + +(defun find-bound-entries (word-entries) + (let ((res nil)) + (dolist (entry word-entries) + (nconcf res (sub-find-bound-entries entry))) + res)) + +(defun sub-find-bound-entries (entry) + (let ((bound-entries nil)) + (when (word-entry-value-node entry) (push entry bound-entries)) + (let ((next-table (word-entry-next-table entry))) + (when next-table + (let ((word-array (word-table-words next-table)) + (num-words (word-table-num-words next-table))) + (declare (simple-vector word-array) (fixnum num-words)) + (dotimes (i num-words) + (declare (fixnum i)) + (nconcf bound-entries + (sub-find-bound-entries (svref word-array i))))))) + bound-entries)) + + + +;;;; Find-Ambiguous + +(defun find-ambiguous (string string-table) + "Returns a list, in alphabetical order, of all the strings in String-Table + which String matches." + (with-folded-string (folded len string (string-table-separator string-table)) + (find-ambiguous* folded len string-table))) + +(defun find-ambiguous* (folded len table) + (let ((word-table (string-table-first-word-table table)) + (word-entries nil)) + (cond ((zerop len) + (setf word-entries (find-ambiguous-entries "" 0 0 word-table))) + (t + (let ((word-tables (list word-table))) + (do-words (start end) + (setf word-entries nil) + (dolist (wt word-tables) + (nconcf word-entries + (find-ambiguous-entries folded start end wt))) + (unless word-entries (return)) + (let ((next-word-tables nil)) + (dolist (entry word-entries) + (let ((next-word-table (word-entry-next-table entry))) + (when next-word-table + (push next-word-table next-word-tables)))) + (unless next-word-tables (return)) + (setf word-tables (nreverse next-word-tables))))))) + (let ((bound-entries (find-bound-entries word-entries)) + (res nil)) + (dolist (be bound-entries) + (push (value-node-proper (word-entry-value-node be)) res)) + (nreverse res)))) + +(defun find-ambiguous-entries (folded start end word-table) + (let ((word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table)) + (res nil)) + (declare (simple-vector word-array) (fixnum num-words)) + (unless (zerop num-words) + (multiple-value-bind + (pos found-p) + (bi-svposition folded word-array + (string-compare* :start1 start :end1 end) + :end (1- num-words) :key #'word-entry-folded) + (declare (ignore found-p)) + ;; + ;; Find last ambiguous string, checking for the end of the table. + (do ((i pos (1+ i))) + ((= i num-words)) + (declare (fixnum i)) + (let* ((entry (svref word-array i)) + (str (word-entry-folded entry)) + (str-len (length str)) + (index (string/= folded str :start1 start :end1 end + :end2 str-len))) + (declare (simple-string str) (fixnum str-len)) + (when (and index (/= index end)) (return nil)) + (push entry res))) + (setf res (nreverse res)) + ;; + ;; Scan back to the first string, checking for the beginning. + (do ((i (1- pos) (1- i))) + ((minusp i)) + (declare (fixnum i)) + (let* ((entry (svref word-array i)) + (str (word-entry-folded entry)) + (str-len (length str)) + (index (string/= folded str :start1 start :end1 end + :end2 str-len))) + (declare (simple-string str) (fixnum str-len)) + (when (and index (/= index end)) (return nil)) + (push entry res))))) + res)) + + + +;;;; Find-Containing + +(defun find-containing (string string-table) + "Return a list in alphabetical order of all the strings in Table which + contain String as a substring." + (with-folded-string (folded len string (string-table-separator string-table)) + (declare (ignore len)) + (let ((word-table (string-table-first-word-table string-table)) + (words nil)) + ;; cons up a list of the words + (do-words (start end) + (push (subseq folded start end) words)) + (setf words (nreverse words)) + (let ((entries (sub-find-containing words word-table)) + (res nil)) + (dolist (e entries) + (push (value-node-proper (word-entry-value-node e)) res)) + (nreverse res))))) + +(defun sub-find-containing (words word-table) + (let ((res nil) + (word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table))) + (declare (simple-vector word-array) (fixnum num-words)) + (dotimes (i num-words) + (declare (fixnum i)) + (let* ((entry (svref word-array i)) + (word (word-entry-folded entry)) + (found (find word words + :test #'(lambda (y x) + (let ((lx (length x)) + (ly (length y))) + (and (<= lx ly) + (string= x y :end2 lx)))))) + (rest-words (if found + (remove found words :test #'eq :count 1) + words))) + (declare (simple-string word)) + (cond (rest-words + (let ((next-table (word-entry-next-table entry))) + (when next-table + (nconcf res (sub-find-containing rest-words next-table))))) + (t + (nconcf res (sub-find-bound-entries entry)))))) + res)) + + + +;;;; Complete-String + +(defvar *complete-string-buffer-size* 128) +(defvar *complete-string-buffer* (make-string *complete-string-buffer-size*)) +(declaim (simple-string *complete-string-buffer*)) + +(defun complete-string (string tables) + "Attempts to complete the string String against the string tables in the + list Tables. Tables must all use the same separator character. See the + manual for details on return values." + (let ((separator (string-table-separator (car tables)))) + #|(when (member separator (cdr tables) + :key #'string-table-separator :test-not #'char=) + (error "All tables must have the same separator."))|# + (with-folded-string (folded len string separator) + (let ((strings nil)) + (dolist (table tables) + (nconcf strings (find-ambiguous* folded len table))) + ;; pick off easy case + (when (null strings) + (return-from complete-string (values nil :none nil nil nil))) + ;; grow complete-string buffer if necessary + (let ((size-needed (1+ len))) + (when (> size-needed *complete-string-buffer-size*) + (let* ((new-size (* size-needed 2)) + (new-buffer (make-string new-size))) + (setf *complete-string-buffer* new-buffer) + (setf *complete-string-buffer-size* new-size)))) + (multiple-value-bind + (str ambig-pos unique-p) + (find-longest-completion strings separator) + (multiple-value-bind (value found-p) (find-values str tables) + (let ((field-pos (compute-field-pos string str separator))) + (cond ((not found-p) + (values str :ambiguous nil field-pos ambig-pos)) + (unique-p + (values str :unique value field-pos nil)) + (t + (values str :complete value field-pos ambig-pos)))))))))) + +(defun find-values (string tables) + (dolist (table tables) + (multiple-value-bind (value found-p) (getstring string table) + (when found-p + (return-from find-values (values value t))))) + (values nil nil)) + +(defun compute-field-pos (given best separator) + (declare (simple-string given best) (base-char separator)) + (let ((give-pos 0) + (best-pos 0)) + (loop + (setf give-pos (position separator given :start give-pos :test #'char=)) + (setf best-pos (position separator best :start best-pos :test #'char=)) + (unless (and give-pos best-pos) (return best-pos)) + (incf (the fixnum give-pos)) + (incf (the fixnum best-pos))))) + + + +;;;; Find-Longest-Completion + +(defun find-longest-completion (strings separator) + (declare (base-char separator)) + (let ((first (car strings)) + (rest-strings (cdr strings)) + (punt-p nil) + (buf-pos 0) + (first-start 0) + (first-end -1) + (ambig-pos nil) + (maybe-unique-p nil)) + (declare (simple-string first) (fixnum buf-pos first-start)) + ;; + ;; Make room to store each string's next separator index. + (do ((l rest-strings (cdr l))) + ((endp l)) + (setf (car l) (cons (car l) -1))) + ;; + ;; Compare the rest of the strings to the first one. + ;; It's our de facto standard for how far we can go. + (loop + (setf first-start (1+ first-end)) + (setf first-end + (position separator first :start first-start :test #'char=)) + (unless first-end + (setf first-end (length first)) + (setf punt-p t) + (setf maybe-unique-p t)) + (let ((first-max first-end) + (word-ambiguous-p nil)) + (declare (fixnum first-max)) + ;; + ;; For each string, store the separator's next index. + ;; If there's no separator, store nil and prepare to punt. + ;; If the string's field is not equal to the first's, shorten the max + ;; expectation for this field, and declare ambiguity. + (dolist (s rest-strings) + (let* ((str (car s)) + (str-last-pos (cdr s)) + (str-start (1+ str-last-pos)) + (str-end (position separator str + :start str-start :test #'char=)) + (index (string-not-equal first str + :start1 first-start :end1 first-max + :start2 str-start :end2 str-end))) + (declare (simple-string str) (fixnum str-last-pos str-start)) + (setf (cdr s) str-end) + (unless str-end + (setf punt-p t) + (setf str-end (length str))) + (when index + (setf word-ambiguous-p t) ; not equal for some reason + (when (< index first-max) + (setf first-max index))))) + ;; + ;; Store what we matched into the result buffer and save the + ;; ambiguous position if its the first ambiguous field. + (let ((length (- first-max first-start))) + (declare (fixnum length)) + (unless (zerop length) + (unless (zerop buf-pos) + (setf (schar *complete-string-buffer* buf-pos) separator) + (incf buf-pos)) + (replace *complete-string-buffer* first + :start1 buf-pos :start2 first-start :end2 first-max) + (incf buf-pos length)) + (when (and (null ambig-pos) word-ambiguous-p) + (setf ambig-pos buf-pos)) + (when (or punt-p (zerop length)) (return))))) + (values + (subseq *complete-string-buffer* 0 buf-pos) + ;; If every corresponding field in each possible completion was equal, + ;; our result string is an initial substring of some other completion, + ;; so we're ambiguous at the end. + (or ambig-pos buf-pos) + (and (null ambig-pos) + maybe-unique-p + (every #'(lambda (x) (null (cdr x))) rest-strings))))) + + + +;;;; Clrstring + +(defun clrstring (string-table) + "Delete all the entries in String-Table." + (fill (the simple-vector (string-table-value-nodes string-table)) nil) + (setf (string-table-num-nodes string-table) 0) + (let ((word-table (string-table-first-word-table string-table))) + (fill (the simple-vector (word-table-words word-table)) nil) + (setf (word-table-num-words word-table) 0)) + t) + + + +;;;; Delete-String + +(defun delete-string (string string-table) + (with-folded-string (folded len string (string-table-separator string-table)) + (when (plusp len) + (let* ((nodes (string-table-value-nodes string-table)) + (num-nodes (string-table-num-nodes string-table)) + (end (1- num-nodes))) + (declare (simple-string folded) (simple-vector nodes) + (fixnum num-nodes end)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded nodes (string-compare* :end1 len) + :end end :key #'value-node-folded) + (cond (found-p + (replace nodes nodes + :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes) + (setf (svref nodes end) nil) + (setf (string-table-num-nodes string-table) end) + (sub-delete-string folded string-table) + t) + (t nil))))))) + +(defun sub-delete-string (folded string-table) + (let ((next-table (string-table-first-word-table string-table)) + (word-table nil) + (node nil) + (entry nil) + (level -1) + last-table last-table-level last-table-pos + last-entry last-entry-level) + (declare (fixnum level)) + (do-words (start end) + (when node + (setf last-entry entry) + (setf last-entry-level level)) + (setf word-table next-table) + (incf level) + (let ((word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table))) + (declare (simple-vector word-array) (fixnum num-words)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded word-array + (string-compare* :start1 start :end1 end) + :end (1- num-words) :key #'word-entry-folded) + (declare (fixnum pos) (ignore found-p)) + (setf entry (svref word-array pos)) + (setf next-table (word-entry-next-table entry)) + (setf node (word-entry-value-node entry)) + (when (or (null last-table) (> num-words 1)) + (setf last-table word-table) + (setf last-table-pos pos) + (setf last-table-level level))))) + (cond (next-table + (setf (word-entry-value-node entry) nil)) + ((and last-entry-level + (>= last-entry-level last-table-level)) + (setf (word-entry-next-table last-entry) nil)) + (t + (let* ((del-word-array (word-table-words last-table)) + (del-num-words (word-table-num-words last-table)) + (del-end (1- del-num-words))) + (declare (simple-vector del-word-array) + (fixnum del-num-words del-end)) + (replace del-word-array del-word-array + :start1 last-table-pos :end1 del-end + :start2 (1+ last-table-pos) + :end2 del-num-words) + (setf (svref del-word-array del-end) nil) + (setf (word-table-num-words last-table) del-end)))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/text.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/text.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/text.lisp (revision 8058) @@ -0,0 +1,581 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains stuff that operates on units of texts, such as +;;; paragraphs, sentences, lines, and words. +;;; + +(in-package :hemlock) + +;;;; -- New Variables -- + +(defhvar "Paragraph Delimiter Function" + "The function that returns whether or not the current line should break the + paragraph." + :value 'default-para-delim-function) + +;;; The standard paragraph delimiting function is DEFAULT-PARA-DELIM-FUNCTION +(defun default-para-delim-function (mark) + "Return whether or not to break on this line." + (paragraph-delimiter-attribute-p (next-character mark))) + + +;;;; -- Paragraph Commands -- + +(defcommand "Forward Paragraph" (p) + "moves point to the end of the current (next) paragraph." + "moves point to the end of the current (next) paragraph." + (let ((point (current-point))) + (unless (paragraph-offset point (or p 1)) + (buffer-end point) + (editor-error)))) + +(defcommand "Backward Paragraph" (p) + "moves point to the start of the current (previous) paragraph." + "moves point to the start of the current (previous) paragraph." + (let ((point (current-point))) + (unless (paragraph-offset point (- (or p 1))) + (buffer-start point) + (editor-error)))) + +(defcommand "Mark Paragraph" (p) + "Put mark and point around current or next paragraph. + A paragraph is delimited by a blank line, a line beginning with a + special character (@,\,-,',and .), or it is begun with a line with at + least one whitespace character starting it. Prefixes are ignored or + skipped over before determining if a line starts or delimits a + paragraph." + "Put mark and point around current or next paragraph." + (declare (ignore p)) + (let* ((point (current-point)) + (mark (copy-mark point :temporary))) + (if (mark-paragraph point mark) + (push-buffer-mark mark t) + (editor-error)))) + +(defun mark-paragraph (mark1 mark2) + "Mark the next or current paragraph, setting mark1 to the beginning and mark2 + to the end. This uses \"Fill Prefix\", and mark1 is always on the first + line of the paragraph. If no paragraph is found, then the marks are not + moved, and nil is returned." + (with-mark ((tmark1 mark1) + (tmark2 mark2)) + (let* ((prefix (value fill-prefix)) + (prefix-len (length prefix)) + (paragraphp (paragraph-offset tmark2 1))) + (when (or paragraphp + (and (last-line-p tmark2) + (end-line-p tmark2) + (not (blank-line-p (mark-line tmark2))))) + (mark-before (move-mark tmark1 tmark2)) + (%fill-paragraph-start tmark1 prefix prefix-len) + (move-mark mark1 tmark1) + (move-mark mark2 tmark2))))) + + + +(eval-when (:compile-toplevel :execute) + +;;; %MARK-TO-PARAGRAPH moves mark to next immediate (current) +;;; paragraph in the specified direction. Nil is returned when no +;;; paragraph is found. NOTE: the order of the arguments to OR within the +;;; first branch of the COND must be as it is, and mark must be at the +;;; beginning of the line it is on. +(defmacro %mark-to-paragraph (mark prefix prefix-length + &optional (direction :forward)) + `(do ((skip-prefix-p) + (paragraph-delim-function (value paragraph-delimiter-function))) + (nil) + (setf skip-prefix-p + (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length))) + (if skip-prefix-p (character-offset ,mark ,prefix-length)) + (let ((next-char (next-character ,mark))) + (cond ((and (not (blank-after-p ,mark)) + (or (whitespace-attribute-p next-char) + (not (funcall paragraph-delim-function ,mark)))) + (return (if skip-prefix-p (line-start ,mark) ,mark))) + (,(if (eq direction :forward) + `(last-line-p ,mark) + `(first-line-p ,mark)) + (if skip-prefix-p (line-start ,mark)) + (return nil))) + (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0)))) + + +;;; %PARAGRAPH-OFFSET-AUX is the inner loop of PARAGRAPH-OFFSET. It +;;; moves over a paragraph to find the beginning or end depending on +;;; direction. Prefixes on a line are ignored or skipped over before it +;;; is determined if the line is a paragraph boundary. +(defmacro %paragraph-offset-aux (mark prefix prefix-length + &optional (direction :forward)) + `(do ((paragraph-delim-function (value paragraph-delimiter-function)) + (skip-prefix-p)) + (nil) + (setf skip-prefix-p + (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length))) + (if skip-prefix-p (character-offset ,mark ,prefix-length)) + (cond ((or (blank-after-p ,mark) + (funcall paragraph-delim-function ,mark)) + (return (line-start ,mark))) + (,(if (eq direction :forward) + `(last-line-p ,mark) + `(first-line-p ,mark)) + (return ,(if (eq direction :forward) + `(line-end ,mark) + `(line-start ,mark))))) + (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0))) + +); eval-when + + + + +;;; PARAGRAPH-OFFSET takes a mark and a number of paragraphs to +;;; move over. If the specified number of paragraphs does not exist in +;;; the direction indicated by the sign of number, then nil is +;;; returned, otherwise the mark is returned. + +(defun paragraph-offset (mark number &optional (prefix (value fill-prefix))) + "moves mark past the specified number of paragraph, forward if the number + is positive and vice versa. If the specified number of paragraphs do + not exist in the direction indicated by the sign of the number, then nil + is returned, otherwise the mark is returned." + (if (plusp number) + (%paragraph-offset-forward mark number prefix) + (%paragraph-offset-backward mark number prefix))) + + + +;;; %PARAGRAPH-OFFSET-FORWARD moves mark forward over number +;;; paragraphs. The first branch of the COND is necessary for the side +;;; effect provided by LINE-OFFSET. If %MARK-TO-PARAGRAPH left tmark at +;;; the beginning of some paragraph %PARAGRAPH-OFFSET-AUX will think it has +;;; moved mark past a paragraph, so we make sure tmark is inside the +;;; paragraph or after it. + +(defun %paragraph-offset-forward (mark number prefix) + (do* ((n number (1- n)) + (tmark (line-start (copy-mark mark :temporary))) + (prefix-length (length prefix)) + (paragraphp (%mark-to-paragraph tmark prefix prefix-length) + (if (plusp n) + (%mark-to-paragraph tmark prefix prefix-length)))) + ((zerop n) (move-mark mark tmark)) + (cond ((and paragraphp (not (line-offset tmark 1))) ; + (if (or (> n 1) (and (last-line-p mark) (end-line-p mark))) + (return nil)) + (return (line-end (move-mark mark tmark)))) + (paragraphp (%paragraph-offset-aux tmark prefix prefix-length)) + (t (return nil))))) + + + +(defun %paragraph-offset-backward (mark number prefix) + (with-mark ((tmark1 mark) + (tmark2 mark)) + (do* ((n (abs number) (1- n)) + (prefix-length (length prefix)) + (paragraphp (%para-offset-back-find-para tmark1 prefix + prefix-length mark) + (if (plusp n) + (%para-offset-back-find-para tmark1 prefix + prefix-length tmark2)))) + ((zerop n) (move-mark mark tmark1)) + (cond ((and paragraphp (first-line-p tmark1)) + (if (and (first-line-p mark) (start-line-p mark)) + (return nil) + (if (> n 1) (return nil)))) + (paragraphp + (%paragraph-offset-aux tmark1 prefix prefix-length :backward) + (%para-offset-back-place-mark tmark1 prefix prefix-length)) + (t (return nil)))))) + + + + +;;; %PARA-OFFSET-BACK-PLACE-MARK makes sure that mark is in +;;; the right place when it has been moved backward over a paragraph. The +;;; "right place" is defined to be where EMACS leaves it for a given +;;; situation or where it is necessary to ensure the mark's skipping +;;; backward over another paragraph if PARAGRAPH-OFFSET was given an +;;; argument with a greater magnitude than one. I believe these two +;;; constraints are equivalent; that is, neither changes what the other +;;; would dictate. + +(defun %para-offset-back-place-mark (mark prefix prefix-length) + (skip-prefix-if-here mark prefix prefix-length) + (cond ((text-blank-line-p mark) (line-start mark)) + ((not (first-line-p mark)) + (line-offset mark -1 0) + (skip-prefix-if-here mark prefix prefix-length) + (if (text-blank-line-p mark) + (line-start mark) + (line-offset mark 1 0))))) + + + +(defun %para-offset-back-find-para (mark1 prefix prefix-length mark2) + (move-mark mark2 mark1) + (line-start mark1) + (let ((para-p (%mark-to-paragraph mark1 prefix prefix-length :backward))) + (cond ((and para-p (same-line-p mark1 mark2)) + (skip-prefix-if-here mark1 prefix prefix-length) + (find-attribute mark1 :whitespace #'zerop) + (cond ((mark<= mark2 mark1) + (line-offset mark1 -1 0) + (%mark-to-paragraph mark1 prefix prefix-length :backward)) + (t (line-start mark1)))) + (t para-p)))) + + + + +;;;; -- Sentence Commands -- + +(defcommand "Forward Sentence" (p) + "Moves forward one sentence or the specified number. + A sentence terminates with a .,?, or ! followed by any number of closing + delimiters (such as \",',),],>,|) which are followed by either two + spaces or a newline." + "Moves forward one sentence or the specified number." + (unless (sentence-offset (current-point) (or p 1)) + (editor-error))) + + + +(defcommand "Backward Sentence" (p) + "Moves backward one sentence or the specified number. + A sentence terminates with a .,?, or ! followed by any number of closing + delimiters (such as \",',),],>,|) which are followed by either two + spaces or a newline." + "Moves backward one sentence or the specified number." + (unless (sentence-offset (current-point) (- (or p 1))) + (editor-error))) + + + +(defcommand "Mark Sentence" (p) + "Put mark and point around current or next sentence. + A sentence terminates with a .,?, or ! followed by any number of closing + delimiters (such as \",',),],>,|) which are followed by either two + spaces or a newline." + "Put mark and point around current or next sentence." + (declare (ignore p)) + (let* ((point (current-point)) + (end (copy-mark point :temporary))) + (unless (sentence-offset end 1) (editor-error)) + (move-mark point end) + (sentence-offset point -1) + (push-buffer-mark end t))) + + +(defcommand "Forward Kill Sentence" (p) + "Kill forward to end of sentence." + "Kill forward to end of sentence." + (let ((point (current-point)) + (offset (or p 1))) + (with-mark ((mark point)) + (if (sentence-offset mark offset) + (if (plusp offset) + (kill-region (region point mark) :kill-forward) + (kill-region (region mark point) :kill-backward)) + (editor-error))))) + +(defcommand "Backward Kill Sentence" (p) + "Kill backward to beginning of sentence." + "Kill backward to beginning of sentence." + (forward-kill-sentence-command (- (or p 1)))) + + +;;; SENTENCE-OFFSET-END-P returns true if mark is at the end of a +;;; sentence. If that the end of a sentence, it leaves mark at an +;;; appropriate position with respect to the sentence-terminator character, +;;; the beginning of the next sentence, and direction. See the commands +;;; "Forward Sentence" and "Backward Sentence" for a definition of a sentence. + +(eval-when (:compile-toplevel :execute) +(defmacro sentence-offset-end-p (mark &optional (direction :forward)) + `(let ((start (mark-charpos ,mark))) + (do () + ((not (sentence-closing-char-attribute-p (next-character ,mark)))) + (mark-after ,mark)) + (let ((next (next-character ,mark))) + (cond ((or (not next) + (char= next #\newline)) + ,(if (eq direction :forward) mark `(mark-after ,mark))) + ((and (char= next #\space) + (member (next-character (mark-after ,mark)) + '(nil #\space #\newline))) + ,(if (eq direction :forward) + `(mark-before ,mark) + `(mark-after ,mark))) + (t (move-to-position ,mark start) + nil))))) +); eval-when + + + + +;;; SENTENCE-OFFSET-FIND-END moves in the direction direction stopping +;;; at sentence terminating characters until either there are not any more +;;; such characters or one is found that defines the end of a sentence. +;;; When looking backwards, we may be at the beginning of some sentence, +;;; and if we are, then we must move mark before the sentence terminator; +;;; otherwise, we would find the immediately preceding sentence terminator +;;; and end up right where we started. + +(eval-when (:compile-toplevel :execute) +(defmacro sentence-offset-find-end (mark &optional (direction :forward)) + `(progn + ,@(if (eq direction :backward) + `((reverse-find-attribute ,mark :whitespace #'zerop) + (when (fill-region-insert-two-spaces-p ,mark) + (reverse-find-attribute ,mark :sentence-terminator) + (mark-before ,mark)))) + (do ((foundp) (endp)) (nil) + (setf foundp ,(if (eq direction :forward) + `(find-attribute ,mark :sentence-terminator) + `(reverse-find-attribute ,mark :sentence-terminator))) + (setf endp ,(if (eq direction :forward) + `(if foundp (progn (mark-after ,mark) + (sentence-offset-end-p ,mark))) + `(if foundp (sentence-offset-end-p ,mark :backward)))) + (if endp (return ,mark)) + ,(if (eq direction :forward) + `(unless foundp (return nil)) + `(if foundp (mark-before ,mark) (return nil)))))) +); eval-when + + + +;;; SENTENCE-OFFSET takes a mark and a number of paragraphs to move +;;; over. If the specified number of paragraphs does not exist in +;;; the direction indicated by the sign of the number, then nil is returned, +;;; otherwise the mark is returned. + +(defun sentence-offset (mark number) + (if (plusp number) + (sentence-offset-forward mark number) + (sentence-offset-backward mark (abs number)))) + + + + +;;; SENTENCE-OFFSET-FORWARD tries to move mark forward over number +;;; sentences. If it can, then mark is moved and returned; otherwise, mark +;;; remains unmoved, and nil is returned. When tmark2 is moved to the end +;;; of a new paragraph, we reverse find for a non-whitespace character to +;;; bring tmark2 to the end of the previous line. This is necessary to +;;; detect if tmark1 is at the end of the paragraph, in which case tmark2 +;;; wants to be moved over another paragraph. + +(defun sentence-offset-forward (mark number) + (with-mark ((tmark1 mark) + (tmark2 mark)) + (do ((n number (1- n)) + (found-paragraph-p)) + ((zerop n) (move-mark mark tmark1)) + (when (and (mark<= tmark2 tmark1) + (setf found-paragraph-p (paragraph-offset tmark2 1))) + (reverse-find-attribute tmark2 :whitespace #'zerop) + (when (mark>= tmark1 tmark2) + (line-offset tmark2 1 0) + (setf found-paragraph-p (paragraph-offset tmark2 1)) + (reverse-find-attribute tmark2 :whitespace #'zerop))) + (cond ((sentence-offset-find-end tmark1) + (if (mark> tmark1 tmark2) (move-mark tmark1 tmark2))) + (found-paragraph-p (move-mark tmark1 tmark2)) + (t (return nil)))))) + + + +(defun sentence-offset-backward (mark number) + (with-mark ((tmark1 mark) + (tmark2 mark) + (tmark3 mark)) + (do* ((n number (1- n)) + (prefix (value fill-prefix)) + (prefix-length (length prefix)) + (found-paragraph-p + (cond ((paragraph-offset tmark2 -1) + (sent-back-place-para-start tmark2 prefix prefix-length) + t)))) + ((zerop n) (move-mark mark tmark1)) + (move-mark tmark3 tmark1) + (when (and (sent-back-para-start-p tmark1 tmark3 prefix prefix-length) + (setf found-paragraph-p + (paragraph-offset (move-mark tmark2 tmark3) -1))) + (paragraph-offset (move-mark tmark1 tmark2) 1) + (sent-back-place-para-start tmark2 prefix prefix-length)) + (cond ((sentence-offset-find-end tmark1 :backward) + (if (mark< tmark1 tmark2) (move-mark tmark1 tmark2))) + (found-paragraph-p (move-mark tmark1 tmark2)) + (t (return nil)))))) + + + +(defun sent-back-para-start-p (mark1 mark2 prefix prefix-length) + (skip-prefix-if-here (line-start mark2) prefix prefix-length) + (cond ((text-blank-line-p mark2) + (line-start mark2)) + ((whitespace-attribute-p (next-character mark2)) + (find-attribute mark2 :whitespace #'zerop) + (if (mark= mark1 mark2) (line-offset mark2 -1 0))) + ((and (mark= mark2 mark1) (line-offset mark2 -1 0)) + (skip-prefix-if-here mark2 prefix prefix-length) + (if (text-blank-line-p mark2) + (line-start mark2))))) + + + +(defun sent-back-place-para-start (mark2 prefix prefix-length) + (skip-prefix-if-here mark2 prefix prefix-length) + (when (text-blank-line-p mark2) + (line-offset mark2 1 0) + (skip-prefix-if-here mark2 prefix prefix-length)) + (find-attribute mark2 :whitespace #'zerop)) + + + + +;;;; -- Transposing Stuff -- + +(defcommand "Transpose Words" (p) + "Transpose the words before and after the cursor. + With a positive argument it transposes the words before and after the + cursor, moves right, and repeats the specified number of times, + dragging the word to the left of the cursor right. With a negative + argument, it transposes the two words to the left of the cursor, moves + between them, and repeats the specified number of times, exactly undoing + the positive argument form." + "Transpose the words before and after the cursor." + (let ((num (or p 1)) + (point (current-point-unless-selection))) + (when point + (with-mark ((mark point :left-inserting) + (start point :left-inserting)) + (let ((mark-prev (previous-character mark)) + (mark-next (next-character mark))) + (cond ((plusp num) + (let ((forwardp (word-offset point num)) + (backwardp (if (or (word-delimiter-attribute-p mark-next) + (word-delimiter-attribute-p mark-prev)) + (word-offset mark -1) + (word-offset mark -2)))) + (if (and forwardp backwardp) + (transpose-words-forward mark point start) + (editor-error)))) + ((minusp num) + (let ((enoughp (word-offset point (1- num)))) + (if (word-delimiter-attribute-p mark-prev) + (reverse-find-attribute mark :word-delimiter #'zerop) + (find-attribute mark :word-delimiter)) + (if enoughp + (transpose-words-backward point mark start) + (editor-error)))) + (t (editor-error)))))))) + + +(defun transpose-words-forward (mark1 end mark2) + (with-mark ((tmark1 mark1 :left-inserting) + (tmark2 mark2 :left-inserting)) + (find-attribute tmark1 :word-delimiter) + (do ((region1 (delete-and-save-region (region mark1 tmark1)))) + ((mark= tmark2 end) (ninsert-region end region1)) + (word-offset tmark2 1) + (reverse-find-attribute (move-mark tmark1 tmark2) :word-delimiter) + (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2))) + (move-mark mark1 tmark1)))) + + +(defun transpose-words-backward (start mark1 mark2) + (with-mark ((tmark1 mark1 :left-inserting) + (tmark2 mark2 :left-inserting)) + (reverse-find-attribute tmark1 :word-delimiter) + (move-mark mark2 mark1) + (do ((region1 (delete-and-save-region (region tmark1 mark1)))) + ((mark= tmark1 start) (ninsert-region start region1)) + (word-offset tmark1 -1) + (find-attribute (move-mark tmark2 tmark1) :word-delimiter) + (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2))) + (move-mark mark1 tmark1)))) + + +(defcommand "Transpose Lines" (p) + "Transpose the current line with the line before the cursor. + With a positive argument it transposes the current line with the one + before, moves down a line, and repeats the specified number of times, + dragging the originally current line down. With a negative argument, it + transposes the two lines to the prior to the current, moves up a line, + and repeats the specified number of times, exactly undoing the positive + argument form. With a zero argument, it transposes the lines at point + and mark." + "Transpose the current line with the line before the cursor." + (let ((num (or p 1)) + (point (current-point-unless-selection))) + (when point + (with-mark ((mark point :left-inserting)) + (cond ((plusp num) + (if (and (line-offset mark -1 0) + (line-offset point num 0)) + (transpose-lines mark point) + (editor-error))) + ((minusp num) + (cond ((and (line-offset mark (1- num) 0) + (line-offset point -1 0)) + (transpose-lines point mark) + (move-mark point mark)) + (t (editor-error)))) + (t + (rotatef (line-string (mark-line point)) + (line-string (mark-line (current-mark)))) + (line-start point))))))) + + +(defun transpose-lines (mark1 mark2) + (with-mark ((tmark1 mark1)) + (line-offset tmark1 1) + (ninsert-region mark2 (delete-and-save-region (region mark1 tmark1))))) + + + +;;;; -- Utilities -- + +(defun skip-prefix-if-here (mark prefix prefix-length) + (if (and prefix (%line-has-prefix-p mark prefix prefix-length)) + (character-offset mark prefix-length))) + + + +(defun text-blank-line-p (mark) + (let ((next-char (next-character mark))) + (or (blank-after-p mark) + (and (funcall (value paragraph-delimiter-function) mark) + (not (whitespace-attribute-p next-char)))))) + + + +(defun whitespace-attribute-p (char) + (= (character-attribute :whitespace char) 1)) + +(defun sentence-terminator-attribute-p (char) + (= (character-attribute :sentence-terminator char) 1)) + +(defun sentence-closing-char-attribute-p (char) + (= (character-attribute :sentence-closing-char char) 1)) + +(defun paragraph-delimiter-attribute-p (char) + (= (character-attribute :paragraph-delimiter char) 1)) + +(defun word-delimiter-attribute-p (char) + (= (character-attribute :word-delimiter char) 1)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/undo.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/undo.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/undo.lisp (revision 8058) @@ -0,0 +1,223 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains the implementation of the undo mechanism. + +(in-package :hemlock) + + + +;;;; -- Constants -- + +(defvar undo-name "Undo") + + + +;;;; -- Variables -- + +(defvar *undo-info* nil + "Structure containing necessary info to undo last undoable operation.") + + + +;;;; -- Structures -- + +(defstruct (undo-info (:print-function %print-undo-info) + (:constructor %make-undo-info + (name method cleanup method-undo buffer)) + (:copier nil)) + name ; string displayed for user to know what's being undone -- + ; typically a command's name. + (hold-name undo-name) ; holds a name for successive invocations of the + ; "Undo" command. + method ; closure stored by command that undoes the command when invoked. + method-undo ; closure stored by command that undoes what method does. + cleanup ; closure stored by command that cleans up any data for method, + ; such as permanent marks. + buffer) ; buffer the command was invoked in. + +(setf (documentation 'undo-info-name 'function) + "Return the string indicating what would be undone for given undo info.") +(setf (documentation 'undo-info-method 'function) + "Return the closure that undoes a command when invoked.") +(setf (documentation 'undo-info-cleanup 'function) + "Return the closure that cleans up data necessary for an undo method.") +(setf (documentation 'undo-info-buffer 'function) + "Return the buffer that the last undoable command was invoked in.") +(setf (documentation 'undo-info-hold-name 'function) + "Return the name being held since the last invocation of \"Undo\"") +(setf (documentation 'undo-info-method-undo 'function) + "Return the closure that undoes what undo-info-method does.") + + +(defun %print-undo-info (obj s depth) + (declare (ignore depth)) + (format s "#" (undo-info-name obj))) + + + +;;;; -- Commands -- + +(defcommand "Undo" (p) + "Undo last major change, kill, etc. + Simple insertions and deletions cannot be undone. If you change the buffer + in this way before you undo, you may get slightly wrong results, but this + is probably still useful." + "This is not intended to be called in Lisp code." + (declare (ignore p)) + (if (not *undo-info*) (editor-error "No currently undoable command.")) + (let ((buffer (undo-info-buffer *undo-info*)) + (cleanup (undo-info-cleanup *undo-info*)) + (method-undo (undo-info-method-undo *undo-info*))) + (if (not (eq buffer (current-buffer))) + (editor-error "Undo info is for buffer ~S." (buffer-name buffer))) + (when (prompt-for-y-or-n :prompt (format nil "Undo the last ~A? " + (undo-info-name *undo-info*)) + :must-exist t) + (funcall (undo-info-method *undo-info*)) + (cond (method-undo + (rotatef (undo-info-name *undo-info*) + (undo-info-hold-name *undo-info*)) + (rotatef (undo-info-method *undo-info*) + (undo-info-method-undo *undo-info*))) + (t (if cleanup (funcall cleanup)) + (setf *undo-info* nil)))))) + + + +;;;; -- Primitives -- + +(defun save-for-undo (name method + &optional cleanup method-undo (buffer (current-buffer))) + "Stashes information for next \"Undo\" command invocation. If there is + an undo-info object, it is cleaned up first." + (cond (*undo-info* + (let ((old-cleanup (undo-info-cleanup *undo-info*))) + (if old-cleanup (funcall old-cleanup)) + (setf (undo-info-name *undo-info*) name) + (setf (undo-info-hold-name *undo-info*) undo-name) + (setf (undo-info-method *undo-info*) method) + (setf (undo-info-method-undo *undo-info*) method-undo) + (setf (undo-info-cleanup *undo-info*) cleanup) + (setf (undo-info-buffer *undo-info*) buffer) + *undo-info*)) + (t (setf *undo-info* + (%make-undo-info name method cleanup method-undo buffer))))) + + + +(eval-when (:compile-toplevel :execute) + +;;; MAKE-TWIDDLE-REGION-UNDO sets up an undo method that deletes region1, +;;; saving the deleted region and eventually storing it in region2. After +;;; deleting region1, its start and end are made :right-inserting and +;;; :left-inserting, so it will contain region2 when it is inserted at region1's +;;; end. This results in a method that takes region1 with permanent marks +;;; into some buffer and results with the contents of region2 in region1 (with +;;; permanent marks into a buffer) and the contents of region1 (from the buffer) +;;; in region2 (a region without marks into any buffer). +;;; +(defmacro make-twiddle-region-undo (region1 region2) + `#'(lambda () + (let* ((tregion (delete-and-save-region ,region1)) + (mark (region-end ,region1))) + (setf (mark-kind (region-start ,region1)) :right-inserting) + (setf (mark-kind mark) :left-inserting) + (ninsert-region mark ,region2) + (setf ,region2 tregion)))) + +;;; MAKE-DELETE-REGION-UNDO sets up an undo method that deletes region with +;;; permanent marks into a buffer, saving the region in region without any +;;; marks into a buffer, deleting one of the permanent marks, and saving one +;;; permanent mark in the variable mark. This is designed to work with +;;; MAKE-INSERT-REGION-UNDO, so mark results in the location in a buffer where +;;; region will be inserted if this method is undone. +;;; +(defmacro make-delete-region-undo (region mark) + `#'(lambda () + (let ((tregion (delete-and-save-region ,region))) + (delete-mark (region-start ,region)) + (setf ,mark (region-end ,region)) + (setf ,region tregion)))) + +;;; MAKE-INSERT-REGION-UNDO sets up an undo method that inserts region at mark, +;;; saving in the variable region a region with permanent marks in a buffer. +;;; This is designed to work with MAKE-DELETE-REGION-UNDO, so region can later +;;; be deleted. +;;; +(defmacro make-insert-region-undo (region mark) + `#'(lambda () + (let ((tregion (region (copy-mark ,mark :right-inserting) ,mark))) + (setf (mark-kind ,mark) :left-inserting) + (ninsert-region ,mark ,region) + (setf ,region tregion)))) + +) ;eval-when + +;;; MAKE-REGION-UNDO handles three common cases that undo'able commands often +;;; need. This function sets up three closures via SAVE-FOR-UNDO that do +;;; an original undo, undo the original undo, and clean up any permanent marks +;;; the next time SAVE-FOR-UNDO is called. Actually, the original undo and +;;; the undo for the original undo setup here are reversible in that each +;;; invocation of "Undo" switches these, so an undo setup by the function is +;;; undo'able, and the undo of the undo is undo'able, and the .... +;;; +;;; :twiddle +;;; Region has permanent marks into a buffer. Mark-or-region is a region +;;; not connected to any buffer. A first undo deletes region, saving it and +;;; inserting mark-or-region. This also sets region around the inserted +;;; region in the buffer and sets mark-or-region to be the deleted and saved +;;; region. Thus the undo and the undo of the undo are the same action. +;;; :insert +;;; Region is not connected to any buffer. Mark-or-region is a permanent +;;; mark into a buffer where region is to be inserted on a first undo, and +;;; this mark is used to form a region on the first undo that will be +;;; deleted upon a subsequent undo. The cleanup method knows mark-or-region +;;; is a permanent mark into a buffer, but it has to determine if region +;;; has marks into a buffer because if a subsequent undo does occur, region +;;; does point into a buffer. +;;; :delete +;;; Region has permanent marks into a buffer. Mark-or-region should not +;;; have been supplied. A first undo deletes region, saving the deleted +;;; region in region and creating a permanent mark that indicates where to +;;; put region back. The permanent mark is stored in mark-or-region. The +;;; cleanup method has to check that mark-or-region is a mark since it won't +;;; be unless there was a subsequent undo. +;;; +(defun make-region-undo (kind name region &optional mark-or-region) + (case kind + (:twiddle + (save-for-undo name + (make-twiddle-region-undo region mark-or-region) + #'(lambda () + (delete-mark (region-start region)) + (delete-mark (region-end region))) + (make-twiddle-region-undo region mark-or-region))) + (:insert + (save-for-undo name + (make-insert-region-undo region mark-or-region) + #'(lambda () + (let ((mark (region-start region))) + (delete-mark mark-or-region) + (when (line-buffer (mark-line mark)) + (delete-mark mark) + (delete-mark (region-end region))))) + (make-delete-region-undo region mark-or-region))) + (:delete + (save-for-undo name + (make-delete-region-undo region mark-or-region) + #'(lambda () + (delete-mark (region-start region)) + (delete-mark (region-end region)) + (if (markp mark-or-region) (delete-mark mark-or-region))) + (make-insert-region-undo region mark-or-region))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/src/vars.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/src/vars.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/src/vars.lisp (revision 8058) @@ -0,0 +1,293 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; The file contains the routines which define Hemlock variables. +;;; + +(in-package :hemlock-internals) + +(defstruct (binding + (:type vector) + (:copier nil) + (:constructor make-binding (cons object across symbol))) + cons ; The cons which holds the value for the property. + object ; The variable-object for the binding. + across ; The next binding in this place. + symbol) ; The symbol name for the variable bound. + + + +;;; UNDEFINED-VARIABLE-ERROR -- Internal +;;; +;;; Complain about an undefined Hemlock variable in a helpful fashion. +;;; +(defun undefined-variable-error (name) + (if (eq (symbol-package name) (find-package :hemlock)) + (error "Undefined Hemlock variable ~A." name) + (error "Hemlock variables must be in the \"HEMLOCK\" package, but~%~ + ~S is in the ~S package." + name (package-name (symbol-package name))))) + +;;; GET-MODE-OBJECT -- Internal +;;; +;;; Get the mode-object corresponding to name or die trying. +;;; +(defun get-mode-object (name) + (unless (stringp name) (error "Mode name ~S is not a string." name)) + (let ((res (getstring name *mode-names*))) + (unless res (error "~S is not a defined mode." name)) + res)) + +;;; FIND-BINDING -- Internal +;;; +;;; Return the Binding object corresponding to Name in the collection +;;; of binding Binding, or NIL if none. +;;; +(defun find-binding (name binding) + (do ((b binding (binding-across b))) + ((null b) nil) + (when (eq (binding-symbol b) name) (return b)))) + +;;; GET-VARIABLE-OBJECT -- Internal +;;; +;;; Get the variable-object with the specified symbol-name, kind and where, +;;; or die trying. +;;; +(defun get-variable-object (name kind where) + (case kind + (:current + (let ((obj (get name 'hemlock-variable-value))) + (if obj obj (undefined-variable-error name)))) + (:buffer + (check-type where buffer) + (let ((binding (find-binding name (buffer-var-values where)))) + (unless binding + (error "~S is not a defined Hemlock variable in buffer ~S." name where)) + (binding-object binding))) + (:global + (do ((obj (get name 'hemlock-variable-value) + (variable-object-down obj)) + (prev nil obj)) + ((symbolp obj) + (unless prev (undefined-variable-error name)) + (unless (eq obj :global) + (error "Hemlock variable ~S is not globally defined." name)) + prev))) + (:mode + (let ((binding (find-binding name (mode-object-var-values + (get-mode-object where))))) + (unless binding + (error "~S is not a defined Hemlock variable in mode ~S." name where)) + (binding-object binding))) + (t + (error "~S is not a defined value for Kind." kind)))) + +;;; VARIABLE-VALUE -- Public +;;; +;;; Get the value of the Hemlock variable "name". +;;; +(defun variable-value (name &optional (kind :current) where) + "Return the value of the Hemlock variable given." + (variable-object-value (get-variable-object name kind where))) + +;;; %VALUE -- Internal +;;; +;;; This function is called by the expansion of Value. +;;; +(defun %value (name) + (let ((obj (get name 'hemlock-variable-value))) + (unless obj (undefined-variable-error name)) + (variable-object-value obj))) + +;;; %SET-VALUE -- Internal +;;; +;;; The setf-inverse of Value, set the current value. +;;; +(defun %set-value (var new-value) + (let ((obj (get var 'hemlock-variable-value))) + (unless obj (undefined-variable-error var)) + (invoke-hook (variable-object-hooks obj) var :current nil new-value) + (setf (variable-object-value obj) new-value))) + +;;; %SET-VARIABLE-VALUE -- Internal +;;; +;;; Set the Hemlock variable with the symbol name "name". +;;; +(defun %set-variable-value (name kind where new-value) + (let ((obj (get-variable-object name kind where))) + (invoke-hook (variable-object-hooks obj) name kind where new-value) + (setf (variable-object-value obj) new-value))) + +;;; VARIABLE-HOOKS -- Public +;;; +;;; Return the list of hooks for "name". +;;; +(defun variable-hooks (name &optional (kind :current) where) + "Return the list of hook functions for the Hemlock variable given." + (variable-object-hooks (get-variable-object name kind where))) + +;;; %SET-VARIABLE-HOOKS -- Internal +;;; +;;; Set the hook-list for Hemlock variable Name. +;;; +(defun %set-variable-hooks (name kind where new-value) + (setf (variable-object-hooks (get-variable-object name kind where)) new-value)) + +;;; VARIABLE-DOCUMENTATION -- Public +;;; +;;; Return the documentation for "name". +;;; +(defun variable-documentation (name &optional (kind :current) where) + "Return the documentation for the Hemlock variable given." + (variable-object-documentation (get-variable-object name kind where))) + +;;; %SET-VARIABLE-DOCUMENTATION -- Internal +;;; +;;; Set a variables documentation. +;;; +(defun %set-variable-documentation (name kind where new-value) + (setf (variable-object-documentation (get-variable-object name kind where)) + new-value)) + +;;; VARIABLE-NAME -- Public +;;; +;;; Return the String Name for a Hemlock variable. +;;; +(defun variable-name (name &optional (kind :current) where) + "Return the string name of a Hemlock variable." + (variable-object-name (get-variable-object name kind where))) + +;;; HEMLOCK-BOUND-P -- Public +;;; +(defun hemlock-bound-p (name &optional (kind :current) where) + "Returns T Name is a Hemlock variable defined in the specifed place, or + NIL otherwise." + (case kind + (:current (not (null (get name 'hemlock-variable-value)))) + (:buffer + (check-type where buffer) + (not (null (find-binding name (buffer-var-values where))))) + (:global + (do ((obj (get name 'hemlock-variable-value) + (variable-object-down obj))) + ((symbolp obj) (eq obj :global)))) + (:mode + (not (null (find-binding name (mode-object-var-values + (get-mode-object where)))))))) + +(declaim (special *global-variable-names*)) + +;;; DEFHVAR -- Public +;;; +;;; Define a Hemlock variable somewhere. +;;; +(defun defhvar (name documentation &key mode buffer (hooks nil hook-p) + (value nil value-p)) + (let* ((symbol-name (string-to-variable name)) + (new-binding (make-variable-object documentation name)) + (plist (symbol-plist symbol-name)) + (prop (cdr (or (member 'hemlock-variable-value plist) + (setf (symbol-plist symbol-name) + (list* 'hemlock-variable-value nil plist))))) + (kind :global) where string-table) + (cond + (mode + (setq kind :mode where mode) + (let* ((obj (get-mode-object where)) + (vars (mode-object-var-values obj))) + (setq string-table (mode-object-variables obj)) + (unless (find-binding symbol-name vars) + (let ((binding (make-binding prop new-binding vars symbol-name))) + (cond ((member obj (buffer-mode-objects *current-buffer*)) + (let ((l (unwind-bindings obj))) + (setf (mode-object-var-values obj) binding) + (wind-bindings l))) + (t + (setf (mode-object-var-values obj) binding))))))) + (buffer + (check-type buffer buffer) + (setq kind :buffer where buffer string-table (buffer-variables buffer)) + (let ((vars (buffer-var-values buffer))) + (unless (find-binding symbol-name vars) + (let ((binding (make-binding prop new-binding vars symbol-name))) + (setf (buffer-var-values buffer) binding) + (when (eq buffer *current-buffer*) + (setf (variable-object-down new-binding) (car prop) + (car prop) new-binding)))))) + (t + (setq string-table *global-variable-names*) + (unless (hemlock-bound-p symbol-name :global) + (setf (variable-object-down new-binding) :global) + (let ((l (unwind-bindings nil))) + (setf (car prop) new-binding) + (wind-bindings l))))) + (setf (getstring name string-table) symbol-name) + (when hook-p + (setf (variable-hooks symbol-name kind where) hooks)) + (when value-p + (setf (variable-value symbol-name kind where) value))) + name) + +;;; DELETE-BINDING -- Internal +;;; +;;; Delete a binding from a list of bindings. +;;; +(defun delete-binding (binding bindings) + (do ((b bindings (binding-across b)) + (prev nil b)) + ((eq b binding) + (cond (prev + (setf (binding-across prev) (binding-across b)) + bindings) + (t + (binding-across bindings)))))) + +;;; DELETE-VARIABLE -- Public +;;; +;;; Make a Hemlock variable no longer bound, fixing up the saved +;;;binding values as necessary. +;;; +(defun delete-variable (name &optional (kind :global) where) + "Delete a Hemlock variable somewhere." + (let* ((obj (get-variable-object name kind where)) + (sname (variable-object-name obj))) + (case kind + (:buffer + (let* ((values (buffer-var-values where)) + (binding (find-binding name values))) + (invoke-hook hemlock::delete-variable-hook name :buffer where) + (delete-string sname (buffer-variables where)) + (setf (buffer-var-values where) (delete-binding binding values)) + (when (eq where *current-buffer*) + (setf (car (binding-cons binding)) (variable-object-down obj))))) + (:mode + (let* ((mode (get-mode-object where)) + (values (mode-object-var-values mode)) + (binding (find-binding name values))) + (invoke-hook hemlock::delete-variable-hook name :mode where) + (delete-string sname (mode-object-variables mode)) + (if (member mode (buffer-mode-objects *current-buffer*)) + (let ((l (unwind-bindings mode))) + (setf (mode-object-var-values mode) + (delete-binding binding values)) + (wind-bindings l)) + (setf (mode-object-var-values mode) + (delete-binding binding values))))) + (:global + (invoke-hook hemlock::delete-variable-hook name :global nil) + (delete-string sname *global-variable-names*) + (let ((l (unwind-bindings nil))) + (setf (get name 'hemlock-variable-value) nil) + (wind-bindings l))) + (t (error "Invalid variable kind: ~S" kind))) + nil)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/abbrev.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/abbrev.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/abbrev.lisp (revision 8058) @@ -0,0 +1,690 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock Word Abbreviation Mode +;;; by Jamie W. Zawinski +;;; 24 September 1985 +;;; +(in-package :hemlock) + +;;;; These Things are Here: + +;;; C-X C-A Add Mode Word Abbrev +;;; Define a mode abbrev for the word before point. +;;; C-X + Add Global Word Abbrev +;;; Define a global abbrev for the word before point. +;;; C-X C-H Inverse Add Mode Word Abbrev +;;; Define expansion for mode abbrev before point. +;;; C-X - Inverse Add Global Word Abbrev +;;; Define expansion for global abbrev before point. +;;; Alt Space Abbrev Expand Only +;;; Expand abbrev without inserting anything. +;;; M-' Word Abbrev Prefix Mark +;;; Mark a prefix to be glued to an abbrev following. +;;; C-X U Unexpand Last Word +;;; Unexpands last abbrev or undoes C-X U. + +;;; List Word Abbrevs Shows definitions of all word abbrevs. +;;; Edit Word Abbrevs Lets you edit the definition list directly. +;;; Read Word Abbrev File Define word abbrevs from a definition file. +;;; Write Word Abbrev File Make a definition file from current abbrevs. + +;;; Make Word Abbrev More General form of C-X C-A, etc. +;;; Delete All Word Abbrevs Wipes them all. +;;; Delete Mode Word Abbrev Kills all Mode abbrev. +;;; Delete Global Word Abbrev Kills all Global abbrev. + +;;; Insert Word Abbrevs Inserts a list of current definitions in the +;;; format that Define Word Abbrevs uses. +;;; Define Word Abbrevs Defines set of abbrevs from a definition list in +;;; the buffer. +;;; Word Abbrev Apropos Shows definitions containing in abbrev, +;;; definition, or mode. + +;;; Append Incremental Word Abbrev File Appends to a file changed abbrev +;;; definitions since last dumping. + +(defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0) + + +(defvar *global-abbrev-table* (make-hash-table :test #'equal) + "Hash table holding global abbrev definitions.") + +(defhvar "Abbrev Pathname Defaults" + "Holds the name of the last Abbrev-file written." + :value (pathname "abbrev.defns")) + +(defvar *new-abbrevs* () + "holds a list of abbrevs (and their definitions and modes) changed since saving.") + + + +;;; C-X C-H Inverse Add Mode Word Abbrev +;;; Define a mode expansion for the word before point. + +(defcommand "Inverse Add Mode Word Abbrev" (p) + "Defines a mode word abbrev expansion for the word before the point." + "Defines a mode word abbrev expansion for the word before the point." + (declare (ignore p)) + (let ((word (prev-word 1 (current-point))) + (mode (buffer-major-mode (current-buffer)))) + (make-word-abbrev-command nil word nil mode))) + + +;;; C-X C-A Add Mode Word Abbrev +;;; Define mode abbrev for word before point. + +(defcommand "Add Mode Word Abbrev" (p) + "Defines a mode word abbrev for the word before the point. + With a positive argument, uses that many preceding words as the expansion. + With a zero argument, uses the region as the expansion. With a negative + argument, prompts for a word abbrev to delete in the current mode." + "Defines or deletes a mode word abbrev." + (if (and p (minusp p)) + (delete-mode-word-abbrev-command nil) + (let* ((val (if (eql p 0) + (region-to-string (current-region nil)) + (prev-word (or p 1) (current-point)))) + (mode (buffer-major-mode (current-buffer)))) + (make-word-abbrev-command nil nil val mode)))) + + + +;;; C-X - Inverse Add Global Word Abbrev +;;; Define global expansion for word before point. + +(defcommand "Inverse Add Global Word Abbrev" (p) + "Defines a Global expansion for the word before point." + "Defines a Global expansion for the word before point." + (declare (ignore p)) + (let ((word (prev-word 1 (current-point)))) + (make-word-abbrev-command nil word nil "Global"))) + + + +;;; C-X + Add Global Word Abbrev +;;; Define global Abbrev for word before point. + +(defcommand "Add Global Word Abbrev" (p) + "Defines a global word abbrev for the word before the point. + With a positive argument, uses that many preceding words as the expansion. + With a zero argument, uses the region as the expansion. With a negative + argument, prompts for a global word abbrev to delete." + "Defines or deletes a global word abbrev." + (if (and p (minusp p)) + (delete-global-word-abbrev-command nil) + (let ((val (if (eql p 0) + (region-to-string (current-region nil)) + (prev-word (or p 1) (current-point))))) + (make-word-abbrev-command nil nil val "Global")))) + + + +;;;; Defining Abbrevs + +;;; Make Word Abbrev More General form of C-X C-A, etc. + +(defvar *global-abbrev-string-table* + (make-string-table :initial-contents '(("Global" . nil)))) + +(defcommand "Make Word Abbrev" (p &optional abbrev expansion mode) + "Defines an arbitrary word abbreviation. + Prompts for abbrev, expansion, and mode." + "Makes Abbrev be a word abbreviation for Expansion when in Mode. If + mode is \"Global\" then make a global abbrev." + (declare (ignore p)) + (unless mode + (setq mode + (prompt-for-keyword + (list *mode-names* *global-abbrev-string-table*) + :prompt "Mode of abbrev to add: " + :default "Global" + :help + "Type the mode of the Abbrev you want to add, or confirm for Global."))) + (let ((globalp (string-equal mode "Global"))) + (unless (or globalp (mode-major-p mode)) + (editor-error "~A is not a major mode." mode)) + (unless abbrev + (setq abbrev + (prompt-for-string + :trim t + :prompt + (list "~A abbreviation~@[ of ~S~]: " mode expansion) + :help + (list "Define a ~A word abbrev." mode)))) + (when (zerop (length abbrev)) + (editor-error "Abbreviation must be at least one character long.")) + (unless (every #'(lambda (ch) + (zerop (character-attribute :word-delimiter ch))) + (the simple-string abbrev)) + (editor-error "Word Abbrevs must be a single word.")) + (unless expansion + (setq expansion + (prompt-for-string + :prompt (list "~A expansion for ~S: " mode abbrev) + :help (list "Define the ~A expansion of ~S." mode abbrev)))) + (setq abbrev (string-downcase abbrev)) + (let* ((table (cond (globalp *global-abbrev-table*) + ((hemlock-bound-p 'Mode-Abbrev-Table :mode mode) + (variable-value 'Mode-Abbrev-Table :mode mode)) + (t + (let ((new (make-hash-table :test #'equal))) + (defhvar "Mode Abbrev Table" + "Hash Table of Mode Abbrevs" + :value new :mode mode) + new)))) + (old (gethash abbrev table))) + (when (or (not old) + (prompt-for-y-or-n + :prompt + (list "Current ~A definition of ~S is ~S.~%Redefine?" + mode abbrev old) + :default t + :help (list "Redefine the expansion of ~S." abbrev))) + (setf (gethash abbrev table) expansion) + (push (list abbrev expansion (if globalp nil mode)) + *new-abbrevs*))))) + + + +;;; Alt Space Abbrev Expand Only +;;; Expand abbrev without inserting anything. + +(defcommand "Abbrev Expand Only" (p) + "This command expands the word before point into its abbrev definition + (if indeed it has one)." + "This command expands the word before point into its abbrev definition + (if indeed it has one)." + (declare (ignore p)) + (let* ((word (prev-word 1 (current-point))) + (glob (gethash (string-downcase word) *global-abbrev-table*)) + (mode (if (hemlock-bound-p 'Mode-Abbrev-Table) + (gethash (string-downcase word) + (value Mode-Abbrev-Table)))) + (end-word (reverse-find-attribute (copy-mark (current-point) + :right-inserting) + :word-delimiter #'zerop)) + (result (if mode mode glob))) + (when (or mode glob) + (delete-characters end-word (- (length word))) + (cond ((equal word (string-capitalize word)) + (setq result (string-capitalize result))) + ((equal word (string-upcase word)) + (setq result (string-upcase result)))) + (insert-string end-word result) + (unless (hemlock-bound-p 'last-expanded) + (defhvar "last expanded" + "Holds a mark, the last expanded abbrev, and its expansion in a list." + :buffer (current-buffer))) + (setf (value last-expanded) + (list (copy-mark (current-point) :right-inserting) + word result))) + (delete-mark end-word)) + (when (and (hemlock-bound-p 'prefix-mark) + (value prefix-mark)) + (delete-characters (value prefix-mark) 1) + (delete-mark (value prefix-mark)) + (setf (value prefix-mark) nil))) + + + +;;; This function returns the n words immediately before the mark supplied. + +(defun prev-word (n mark) + (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary) + :word-delimiter #'zerop)) + (mark-2 (copy-mark mark-1))) + (dotimes (x n (region-to-string (region mark-2 mark-1))) + (reverse-find-attribute (mark-before mark-2) :word-delimiter)))) + + + +;;; M-' Word Abbrev Prefix Mark +;;; Mark a prefix to be glued to an abbrev following. + +;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander) +;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately +;;; after prefix-mark. + +(defcommand "Word Abbrev Prefix Mark" (p) + "Marks a prefix to be glued to an abbrev following." + "Marks a prefix to be glued to an abbrev following." + (declare (ignore p)) + (unless (hemlock-bound-p 'prefix-mark) + (defhvar "prefix mark" + "Holds a mark (or not) pointing to the current Prefix Mark." + :buffer (current-buffer))) + (when (value prefix-mark) + (delete-mark (value prefix-mark))) + (setf (value prefix-mark) (copy-mark (current-point) :right-inserting)) + (insert-character (value prefix-mark) #\-)) + + + +;;; C-X U Unexpand Last Word +;;; Unexpands last abbrev or undoes last C-X U. + +(defcommand "Unexpand Last Word" (p) + "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\". + Only one abbrev may be undone." + "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"." + (declare (ignore p)) + (unless (or (not (hemlock-bound-p 'last-expanded)) + (value last-expanded)) + (editor-error "Nothing to Undo.")) + (let ((mark (car (value last-expanded))) + (word1 (second (value last-expanded))) + (word2 (third (value last-expanded)))) + (unless (string= word2 + (region-to-string + (region (character-offset (copy-mark mark :temporary) + (- (length word2))) + mark))) + (editor-error "The last expanded Abbrev has been altered in the text.")) + (delete-characters mark (- (length word2))) + (insert-string mark word1) + (character-offset mark (length word1)) + (setf (value last-expanded) (list mark word2 word1)))) + + + +;;; Delete Mode Word Abbrev Kills some Mode abbrevs. + +(defcommand "Delete Mode Word Abbrev" + (p &optional abbrev + (mode (buffer-major-mode (current-buffer)))) + "Prompts for a word abbrev and deletes the mode expansion in the current mode. + If called with a prefix argument, deletes all word abbrevs define in the + current mode." + "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true." + (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode))) + (if p + (when boundp + (delete-variable 'Mode-Abbrev-Table :mode mode)) + (let ((down + (string-downcase + (or abbrev + (prompt-for-string + :prompt (list "~A abbrev to delete: " mode) + :help + (list "Give the name of a ~A mode word abbrev to delete." mode) + :trim t)))) + (table (and boundp (variable-value 'mode-abbrev-table :mode mode)))) + (unless (and table (gethash down table)) + (editor-error "~S is not the name of an abbrev in ~A mode." + down mode)) + (remhash down table))))) + + +;;; Delete Global Word Abbrevs Kills some Global abbrevs. + +(defcommand "Delete Global Word Abbrev" (p &optional abbrev) + "Prompts for a word abbrev and delete the global expansion. + If called with a prefix argument, deletes all global abbrevs." + "Deletes the global word abbreviation named Abbrev. If P is true, + deletes all global abbrevs." + (if p + (setq *global-abbrev-table* (make-hash-table :test #'equal)) + (let ((down + (string-downcase + (or abbrev + (prompt-for-string + :prompt "Global abbrev to delete: " + :help "Give the name of a global word abbrev to delete." + :trim t))))) + (unless (gethash down *global-abbrev-table*) + (editor-error "~S is not the name of a global word abbrev." down)) + (remhash down *global-abbrev-table*)))) + +;;; Delete All Word Abbrevs Wipes them all. + +(defcommand "Delete All Word Abbrevs" (p) + "Deletes all currently defined Word Abbrevs" + "Deletes all currently defined Word Abbrevs" + (declare (ignore p)) + (Delete-Global-Word-Abbrev-Command 1) + (Delete-Mode-Word-Abbrev-Command 1)) + + + +;;;; Abbrev I/O + +;;; List Word Abbrevs Shows definitions of all word abbrevs. + +(defcommand "List Word Abbrevs" (p) + "Lists all of the currently defined Word Abbrevs." + "Lists all of the currently defined Word Abbrevs." + (word-abbrev-apropos-command p "")) + + +;;; Word Abbrev Apropos Shows definitions containing in abbrev, +;;; definition, or mode. + +(defcommand "Word Abbrev Apropos" (p &optional search-string) + "Lists all of the currently defined Word Abbrevs which contain a given string + in their abbrev. definition, or mode." + "Lists all of the currently defined Word Abbrevs which contain a given string + in their abbrev. definition, or mode." + (declare (ignore p)) + (unless search-string + (setq search-string + (string-downcase + (prompt-for-string + :prompt "Apropos string: " + :help "The string to search word abbrevs and definitions for.")))) + (multiple-value-bind (count mode-tables) (count-abbrevs) + (with-pop-up-display (s :height (min (1+ count) 30)) + (unless (zerop (hash-table-count *global-abbrev-table*)) + (maphash #'(lambda (key val) + (when (or (search search-string (string-downcase key)) + (search search-string (string-downcase val))) + (write-abbrev key val nil s t))) + *global-abbrev-table*)) + (dolist (modename mode-tables) + (let ((table (variable-value 'Mode-Abbrev-Table :mode modename))) + (if (search search-string (string-downcase modename)) + (maphash #'(lambda (key val) + (write-abbrev key val modename s t)) + table) + (maphash #'(lambda (key val) + (when (or (search search-string (string-downcase key)) + (search search-string (string-downcase val))) + (write-abbrev key val modename s t))) + table)))) + (terpri s)))) + + + +(defun count-abbrevs () + (let* ((count (hash-table-count *global-abbrev-table*)) + (mode-tables nil)) + (do-strings (which x *mode-names*) + (declare (ignore x)) + (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which) + (let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table + :mode which)))) + (unless (zerop table-count) + (incf count table-count) + (push which mode-tables))))) + (values count mode-tables))) + + + +;;; Edit Word Abbrevs Lets you edit the definition list directly. + +(defcommand "Edit Word Abbrevs" (p) + "Allows direct editing of currently defined Word Abbrevs." + "Allows direct editing of currently defined Word Abbrevs." + (declare (ignore p)) + (when (getstring "Edit Word Abbrevs" *buffer-names*) + (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*))) + (let ((old-buf (current-buffer)) + (new-buf (make-buffer "Edit Word Abbrevs"))) + (change-to-buffer new-buf) + (unwind-protect + (progn + (insert-word-abbrevs-command nil) + (do-recursive-edit) + (unless (equal #\newline (previous-character (buffer-end (current-point)))) + (insert-character (current-point) #\newline)) + (delete-all-word-abbrevs-command nil) + (define-word-abbrevs-command nil)) + (progn + (change-to-buffer old-buf) + (delete-buffer new-buf))))) + + + +;;; Insert Word Abbrevs Inserts a list of current definitions in the +;;; format that Define Word Abbrevs uses. + +(defcommand "Insert Word Abbrevs" (p) + "Inserts into the current buffer a list of all currently defined abbrevs in the + format used by \"Define Word Abbrevs\"." + "Inserts into the current buffer a list of all currently defined abbrevs in the + format used by \"Define Word Abbrevs\"." + + (declare (ignore p)) + (multiple-value-bind (x mode-tables) + (count-abbrevs) + (declare (ignore x)) + (with-output-to-mark (stream (current-point) :full) + (maphash #'(lambda (key val) + (write-abbrev key val nil stream)) + *global-abbrev-table*) + + (dolist (mode mode-tables) + (let ((modename (if (listp mode) (car mode) mode))) + (maphash #'(lambda (key val) + (write-abbrev key val modename stream)) + (variable-value 'Mode-Abbrev-Table :mode modename))))))) + + + +;;; Define Word Abbrevs Defines set of abbrevs from a definition list in +;;; the buffer. + +(defcommand "Define Word Abbrevs" (p) + "Defines Word Abbrevs from the definition list in the current buffer. The + definition list must be in the format produced by \"Insert Word Abbrevs\"." + "Defines Word Abbrevs from the definition list in the current buffer. The + definition list must be in the format produced by \"Insert Word Abbrevs\"." + + (declare (ignore p)) + (with-input-from-region (file (buffer-region (current-buffer))) + (read-abbrevs file))) + + + +;;; Read Word Abbrev file Define word abbrevs from a definition file. + +;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is +;;; the minimum number of characters possible to define an abbrev. It thinks the +;;; current abbrev "wraps" if there is no #\" at the end of the line or there are +;;; two #\"s at the end of the line (unless that is the entire definition string, +;;; i.e, a null-abbrev). + +;;; The format of the Abbrev files is +;;; +;;; ABBREV"ABBREV DEFINITION" +;;; +;;; for Global Abbrevs, and +;;; +;;; ABBREV(MODE)"ABBREV DEFINITION" +;;; +;;; for Modal Abbrevs. +;;; Double-quotes contained within the abbrev definition are doubled. If the first +;;; line of an abbrev definition is not closed by a single double-quote, then +;;; the subsequent lines are read in until a single double-quote is found. + +(defcommand "Read Word Abbrev File" (p &optional filename) + "Reads in a file of previously defined abbrev definitions." + "Reads in a file of previously defined abbrev definitions." + (declare (ignore p)) + (setf (value abbrev-pathname-defaults) + (if filename + filename + (prompt-for-file + :prompt "Name of abbrev file: " + :help "The name of the abbrev file to load." + :default (value abbrev-pathname-defaults) + :must-exist nil))) + (with-open-file (file (value abbrev-pathname-defaults) :direction :input + :element-type 'base-char :if-does-not-exist :error) + (read-abbrevs file))) + + +;;; Does the actual defining of abbrevs from a given stream, expecting tabs and +;;; doubled double-quotes. + +(defun read-abbrevs (file) + (do ((line (read-line file nil nil) + (read-line file nil nil))) + ((null line)) + (unless (< (length line) 4) + (let* ((tab (position #\tab line)) + (tab2 (position #\tab line :start (1+ tab))) + (abbrev (subseq line 0 tab)) + (modename (subseq line (1+ tab) tab2)) + (expansion (do* ((last (1+ (position #\" line)) + (if found (min len (1+ found)) 0)) + (len (length line)) + (found (if (position #\" line :start last) + (1+ (position #\" line :start last))) + (if (position #\" line :start last) + (1+ (position #\" line :start last)))) + (expansion (subseq line last (if found found len)) + (concatenate 'simple-string expansion + (subseq line last + (if found found + len))))) + ((and (or (null found) (= found len)) + (equal #\" (char line (1- len))) + (or (not (equal #\" (char line (- len 2)))) + (= (- len 3) tab2))) + (subseq expansion 0 (1- (length expansion)))) + + (when (null found) + (setq line (read-line file nil nil) + last 0 + len (length line) + found (if (position #\" line) + (1+ (position #\" line))) + expansion (format nil "~A~%~A" expansion + (subseq line 0 (if found + found + 0)))))))) + + (cond ((equal modename "") + (setf (gethash abbrev *global-abbrev-table*) + expansion)) + (t (setq modename (subseq modename 1 (1- (length modename)))) + (unless (hemlock-bound-p 'Mode-Abbrev-Table + :mode modename) + (defhvar "Mode Abbrev Table" + "Hash Table of Mode Abbrevs" + :value (make-hash-table :test #'equal) + :mode modename)) + (setf (gethash abbrev (variable-value + 'Mode-Abbrev-Table :mode modename)) + expansion))))))) + + +;;; Write Word Abbrev File Make a definition file from current abbrevs. + +(defcommand "Write Word Abbrev File" (p &optional filename) + "Saves the currently defined Abbrevs to a file." + "Saves the currently defined Abbrevs to a file." + (declare (ignore p)) + (unless filename + (setq filename + (prompt-for-file + :prompt "Write abbrevs to file: " + :default (value abbrev-pathname-defaults) + :help "Name of the file to write current abbrevs to." + :must-exist nil))) + (with-open-file (file filename :direction :output + :element-type 'base-char :if-exists :supersede + :if-does-not-exist :create) + (multiple-value-bind (x mode-tables) (count-abbrevs) + (declare (ignore x)) + (maphash #'(lambda (key val) + (write-abbrev key val nil file)) + *global-abbrev-table*) + + (dolist (modename mode-tables) + (let ((mode (if (listp modename) (car modename) modename))) + (maphash #'(lambda (key val) + (write-abbrev key val mode file)) + (variable-value 'Mode-Abbrev-Table :mode mode)))))) + (let ((tn (truename filename))) + (setf (value abbrev-pathname-defaults) tn) + (message "~A written." (namestring tn)))) + + + +;;; Append to Word Abbrev File Appends to a file changed abbrev +;;; definitions since last dumping. + +(defcommand "Append to Word Abbrev File" (p &optional filename) + "Appends Abbrevs defined or redefined since the last save to a file." + "Appends Abbrevs defined or redefined since the last save to a file." + (declare (ignore p)) + (cond + (*new-abbrevs* + (unless filename + (setq filename + (prompt-for-file + :prompt + "Append incremental abbrevs to file: " + :default (value abbrev-pathname-defaults) + :must-exist nil + :help "Filename to append recently defined Abbrevs to."))) + (write-incremental :append filename)) + (t + (message "No Abbrev definitions have been changed since the last write.")))) + + +(defun write-incremental (mode filename) + (with-open-file (file filename :direction :output + :element-type 'base-char + :if-exists mode :if-does-not-exist :create) + (dolist (def *new-abbrevs*) + (let ((abb (car def)) + (val (second def)) + (mode (third def))) + (write-abbrev abb val mode file)))) + (let ((tn (truename filename))) + (setq *new-abbrevs* nil) + (setf (value abbrev-pathname-defaults) tn) + (message "~A written." (namestring tn)))) + + +;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function +;;; writes to the stream with doubled double-quotes and stuff. +;;; If the flag is true, then the output is in a pretty format (like "List Word +;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word +;;; Abbrev File" uses). + +(defun write-abbrev (abbrev expansion modename file &optional flag) + (if flag + (if modename + (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format + (format file "~5t~A~35t\"" abbrev)) ; pretty format + (cond (modename + (write-string abbrev file) + (write-char #\tab file) + (format file "(~A)" modename) ; "~A(~A)\"" + (write-char #\tab file) + (write-char #\" file)) + (t + (write-string abbrev file) + (write-char #\tab file) ; "~A\"" + (write-char #\tab file) + (write-char #\" file)))) + (do* ((prev 0 found) + (found (position #\" expansion) + (position #\" expansion :start found))) + ((not found) + (write-string expansion file :start prev) + (write-char #\" file) + (terpri file)) + (incf found) + (write-string expansion file :start prev :end found) + (write-char #\" file))) + + +(defcommand "Abbrev Mode" (p) + "Put current buffer in Abbrev mode." + "Put current buffer in Abbrev mode." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Abbrev") + (not (buffer-minor-mode (current-buffer) "Abbrev")))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/auto-save.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/auto-save.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/auto-save.lisp (revision 8058) @@ -0,0 +1,401 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Auto-Save Mode +;;; Written by Christopher Hoover +;;; + +(in-package :hemlock) + + + +;;;; Per Buffer State Information + +;;; +;;; The auto-save-state structure is used to store the state information for +;;; a particular buffer in "Save" mode, namely the buffer-signature at the last +;;; key stroke, the buffer-signature at the time of the last checkpoint, a count +;;; of the number of destructive keystrokes which have occured since the time of +;;; the last checkpoint, and the pathname used to write the last checkpoint. It +;;; is generally kept in a buffer-local hvar called "Auto Save State". +;;; +(defstruct (auto-save-state + (:conc-name save-state-) + (:print-function print-auto-save-state)) + "Per buffer state for auto-save" + (buffer nil) ; buffer this state is for; for printing + (key-signature 0 :type fixnum) ; buffer-signature at last keystroke + (last-ckp-signature 0 :type fixnum) ; buffer-signature at last checkpoint + (key-count 0 :type fixnum) ; # destructive keystrokes since ckp + (pathname nil)) ; pathname used to write last ckp file + +(defun print-auto-save-state (auto-save-state stream depth) + (declare (ignore depth)) + (format stream "#" + (buffer-name (save-state-buffer auto-save-state)))) + + +;;; GET-AUTO-SAVE-STATE tries to get the auto-save-state for the buffer. If +;;; the buffer is not in "Save" mode then this function returns NIL. +;;; +(defun get-auto-save-state (buffer) + (if (hemlock-bound-p 'auto-save-state :buffer buffer) + (variable-value 'auto-save-state :buffer buffer))) + +;;; RESET-AUTO-SAVE-STATE resets the auto-save-state of the buffer making it +;;; look as if the buffer was just checkpointed. This is in fact how +;;; checkpoint-buffer updates the state. If the buffer is not in "Save" mode +;;; this function punts the attempt and does nothing. +;;; +(defun reset-auto-save-state (buffer) + (let ((state (get-auto-save-state buffer))) + (when state + (let ((signature (buffer-signature buffer))) + (setf (save-state-key-signature state) + signature) + (setf (save-state-last-ckp-signature state) + signature) + (setf (save-state-key-count state) + 0))))) + + + + +;;;; Checkpoint Pathname Interface/Internal Routines + +;;; GET-CHECKPOINT-PATHNAME -- Interface +;;; +;;; Returns the pathname of the checkpoint file for the specified +;;; buffer; Returns NIL if no checkpoints have been written thus +;;; far or if the buffer isn't in "Save" mode. +;;; +(defun get-checkpoint-pathname (buffer) + "Returns the pathname of the checkpoint file for the specified buffer. + If no checkpoints have been written thus far, or if the buffer is not in + \"Save\" mode, return nil." + (let ((state (get-auto-save-state buffer))) + (if state + (save-state-pathname state)))) + +;;; MAKE-UNIQUE-SAVE-PATHNAME is used as the default value for "Auto Save +;;; Pathname Hook" and is mentioned in the User's manual, so it gets a doc +;;; doc string. +;;; +(defun make-unique-save-pathname (buffer) + "Returns a pathname for a non-existing file in DEFAULT-DIRECTORY. Uses + GENSYM to for a file name: save-GENSYM.CKP." + (declare (ignore buffer)) + (let ((def-dir (hemlock-ext:default-directory))) + (loop + (let* ((sym (gensym)) + (f (merge-pathnames (format nil "save-~A.CKP" sym) def-dir))) + (unless (probe-file f) + (return f)))))) + +(defhvar "Auto Save Pathname Hook" + "This hook is called by Auto Save to get a checkpoint pathname when there + is no pathname associated with a buffer. If this value is NIL, then + \"Save\" mode is turned off in the buffer. Otherwise, the function + will be called. It should take a buffer as its argument and return either + NIL or a pathname. If NIL is returned, then \"Save\" mode is turned off + in the buffer; else the pathname returned is used as the checkpoint + pathname for the buffer." + :value #'make-unique-save-pathname) + + +;;; MAKE-BUFFER-CKP-PATHNAME attempts to form a pathname by using the buffer's +;;; associated pathname (from buffer-pathname). If there isn't a pathname +;;; associated with the buffer, the function returns nil. Otherwise, it uses +;;; the "Auto Save Filename Pattern" and FORMAT to make the checkpoint +;;; pathname. +;;; +(defun make-buffer-ckp-pathname (buffer) + (let ((buffer-pn (buffer-pathname buffer))) + (if buffer-pn + (pathname (format nil + (value auto-save-filename-pattern) + (directory-namestring buffer-pn) + (file-namestring buffer-pn)))))) + + + + +;;;; Buffer-level Checkpoint Routines + +;;; +;;; write-checkpoint-file -- Internal +;;; +;;; Does the low-level write of the checkpoint. Returns T if it succeeds +;;; and NIL if it fails. Echoes winnage or lossage to the luser. +;;; +(defun write-checkpoint-file (pathname buffer) + (let ((ns (namestring pathname))) + (cond ((hemlock-ext:file-writable pathname) + (message "Saving ~A" ns) + (handler-case (progn + (write-file (buffer-region buffer) pathname + :keep-backup nil + :access #o600) ;read/write by owner. + t) + (error (condition) + (loud-message "Auto Save failure: ~A" condition) + nil))) + (t + (message "Can't write ~A" ns) + nil)))) + + +;;; +;;; To save, or not to save... and to save as what? +;;; +;;; First, make-buffer-ckp-pathname is called. It will return either NIL or +;;; a pathname formed by using buffer-pathname in conjunction with the hvar +;;; "Auto Save Filename Pattern". If there isn't an associated pathname or +;;; make-buffer-ckp-pathname returns NIL, then we use the pathname we used +;;; the last time we checkpointed the buffer. If we've never checkpointed +;;; the buffer, then we check "Auto Save Pathname Hook". If it is NIL then +;;; we turn Save mode off for the buffer, else we funcall the function on +;;; the hook with the buffer as an argument. The function on the hook should +;;; return either NIL or a pathname. If it returns NIL, we toggle Save mode +;;; off for the buffer; otherwise, we use the pathname it returned. +;;; + +;;; +;;; checkpoint-buffer -- Internal +;;; +;;; This functions takes a buffer as its argument and attempts to write a +;;; checkpoint for that buffer. See the notes at the beginning of this page +;;; for how it determines what pathname to use as the checkpoint pathname. +;;; Note that a checkpoint is not necessarily written -- instead "Save" +;;; mode may be turned off for the buffer. +;;; +(defun checkpoint-buffer (buffer) + (let* ((state (get-auto-save-state buffer)) + (buffer-ckp-pn (make-buffer-ckp-pathname buffer)) + (last-pathname (save-state-pathname state))) + (cond (buffer-ckp-pn + (when (write-checkpoint-file buffer-ckp-pn buffer) + (reset-auto-save-state buffer) + (setf (save-state-pathname state) buffer-ckp-pn) + (when (and last-pathname + (not (equal last-pathname buffer-ckp-pn)) + (probe-file last-pathname)) + (delete-file last-pathname)))) + (last-pathname + (when (write-checkpoint-file last-pathname buffer) + (reset-auto-save-state buffer))) + (t + (let* ((save-pn-hook (value auto-save-pathname-hook)) + (new-pn (if save-pn-hook + (funcall save-pn-hook buffer)))) + (cond ((or (not new-pn) + (zerop (length + (the simple-string (namestring new-pn))))) + (setf (buffer-minor-mode buffer "Save") nil)) + (t + (when (write-checkpoint-file new-pn buffer) + (reset-auto-save-state buffer) + (setf (save-state-pathname state) new-pn))))))))) + +;;; +;;; checkpoint-all-buffers -- Internal +;;; +;;; This function looks through the buffer list and checkpoints +;;; each buffer that is in "Save" mode that has been modified since +;;; its last checkpoint. +;;; +(defun checkpoint-all-buffers (elapsed-time) + (declare (ignore elapsed-time)) + (dolist (buffer *buffer-list*) + (let ((state (get-auto-save-state buffer))) + (when (and state + (buffer-modified buffer) + (not (eql + (save-state-last-ckp-signature state) + (buffer-signature buffer)))) + (checkpoint-buffer buffer))))) + + + +;;;; Random Hooks: cleanup, buffer-modified, change-save-freq. + +;;; +;;; cleanup-checkpoint -- Internal +;;; +;;; Cleans up checkpoint file for a given buffer if Auto Save Cleanup +;;; Checkpoints is non-NIL. This is called via "Write File Hook" +;;; +(defun cleanup-checkpoint (buffer) + (let ((ckp-pathname (get-checkpoint-pathname buffer))) + (when (and (value auto-save-cleanup-checkpoints) + ckp-pathname + (probe-file ckp-pathname)) + (delete-file ckp-pathname)))) + +(add-hook write-file-hook 'cleanup-checkpoint) + +;;; +;;; notice-buffer-modified -- Internal +;;; +;;; This function is called on "Buffer Modified Hook" to reset +;;; the Auto Save state. It makes the buffer look like it has just +;;; been checkpointed. +;;; +(defun notice-buffer-modified (buffer flag) + ;; we care only when the flag has gone to false + (when (not flag) + (reset-auto-save-state buffer))) + +(add-hook buffer-modified-hook 'notice-buffer-modified) + +;;; +;;; change-save-frequency -- Internal +;;; +;;; This keeps us scheduled at the proper interval. It is stuck on +;;; the hook list for the hvar "Auto Save Checkpoint Frequency" and +;;; is therefore called whenever this value is set. +;;; +(defun change-save-frequency (name kind where new-value) + (declare (ignore name kind where)) + (setq new-value (truncate new-value)) + (remove-scheduled-event 'checkpoint-all-buffers) + (when (and new-value + (plusp new-value)) + (schedule-event new-value 'checkpoint-all-buffers t))) + + +;;; "Save" mode is in "Default Modes", so turn it off in these modes. +;;; + +(defun interactive-modes (buffer on) + (when on (setf (buffer-minor-mode buffer "Save") nil))) + +#+GBNIL (add-hook typescript-mode-hook 'interactive-modes) +#+GBNIL (add-hook eval-mode-hook 'interactive-modes) + + + + +;;;; Key Count Routine for Input Hook + +;;; +;;; auto-save-count-keys -- Internal +;;; +;;; This function sits on the Input Hook to eat cycles. If the current +;;; buffer is not in Save mode or if the current buffer is the echo area +;;; buffer, it does nothing. Otherwise, we check to see if we have exceeded +;;; the key count threshold (and write a checkpoint if we have) and we +;;; increment the key count for the buffer. +;;; +(defun auto-save-count-keys () + #.*fast* + (let ((buffer (current-buffer))) + (unless (eq buffer *echo-area-buffer*) + (let ((state (value auto-save-state)) + (threshold (value auto-save-key-count-threshold))) + (when (and state threshold) + (let ((signature (buffer-signature buffer))) + (declare (fixnum signature)) + (when (not (eql signature + (save-state-key-signature state))) + ;; see if we exceeded threshold last time... + (when (>= (save-state-key-count state) + (the fixnum threshold)) + (checkpoint-buffer buffer)) + ;; update state + (setf (save-state-key-signature state) signature) + (incf (save-state-key-count state))))))))) + +(add-hook input-hook 'auto-save-count-keys) + + + +;;;; Save Mode Hemlock Variables + +;;; +;;; Hemlock variables/parameters for Auto-Save Mode +;;; + +(defhvar "Auto Save Filename Pattern" + "This control-string is used with format to make the filename of the + checkpoint file. Format is called with two arguments, the first + being the directory namestring and the second being the file + namestring of the default buffer pathname." + :value "~A~A.CKP") + +(defhvar "Auto Save Key Count Threshold" + "This value is the number of destructive/modifying keystrokes that will + automatically trigger an checkpoint. This value may be NIL to turn this + feature off." + :value 256) + +(defhvar "Auto Save Cleanup Checkpoints" + "This variable controls whether or not \"Save\" mode will delete the + checkpoint file for a buffer after it is saved. If this value is + non-NIL then cleanup will occur." + :value t) + +(defhvar "Auto Save Checkpoint Frequency" + "All modified buffers (in \"Save\" mode) will be checkpointed after this + amount of time (in seconds). This value may be NIL (or non-positive) + to turn this feature off." + :value (* 2 60) + :hooks '(change-save-frequency)) + +(defhvar "Auto Save State" + "Shadow magic. This variable is seen when in buffers that are not + in \"Save\" mode. Do not change this value or you will lose." + :value nil) + + + +;;;; "Save" mode + +(defcommand "Auto Save Mode" (p) + "If the argument is zero or negative, turn \"Save\" mode off. If it + is positive turn \"Save\" mode on. If there is no argument, toggle + \"Save\" mode in the current buffer. When in \"Save\" mode, files + are automatically checkpointed every \"Auto Save Checkpoint Frequency\" + seconds or every \"Auto Save Key Count Threshold\" destructive + keystrokes. If there is a pathname associated with the buffer, the + filename used for the checkpoint file is controlled by the hvar \"Auto + Save Filename Pattern\". Otherwise, the hook \"Auto Save Pathname Hook\" + is used to generate a checkpoint pathname. If the buffer's pathname + changes between checkpoints, the checkpoint file will be written under + the new name and the old checkpoint file will be deleted if it exists. + When a buffer is written out, the checkpoint will be deleted if the + hvar \"Auto Save Cleanup Checkpoints\" is non-NIL." + "Turn on, turn off, or toggle \"Save\" mode in the current buffer." + (setf (buffer-minor-mode (current-buffer) "Save") + (if p + (plusp p) + (not (buffer-minor-mode (current-buffer) "Save"))))) + +(defun setup-auto-save-mode (buffer) + (let* ((signature (buffer-signature buffer)) + (state (make-auto-save-state + :buffer buffer + :key-signature (the fixnum signature) + :last-ckp-signature (the fixnum signature)))) + ;; shadow the global value with a variable which will + ;; contain our per buffer state information + (defhvar "Auto Save State" + "This is the \"Save\" mode state information for this buffer." + :buffer buffer + :value state))) + +(defun cleanup-auto-save-mode (buffer) + (delete-variable 'auto-save-state + :buffer buffer)) + +(defmode "Save" + :setup-function 'setup-auto-save-mode + :cleanup-function 'cleanup-auto-save-mode) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bit-display.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bit-display.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bit-display.lisp (revision 8058) @@ -0,0 +1,292 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; Modified by Bill Chiles to run under X on IBM RT's. +;;; + +(in-package :hemlock-internals) + + + +;;; prepare-window-for-redisplay -- Internal +;;; +;;; Called by make-window to do whatever redisplay wants to set up +;;; a new window. +;;; +(defun prepare-window-for-redisplay (window) + (setf (window-old-lines window) 0)) + + + + +;;;; Dumb window redisplay. + +;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay. +;;; This assumes the cursor has been lifted if necessary. +;;; +(defun dumb-window-redisplay (window) + (let* ((hunk (window-hunk window)) + (first (window-first-line window))) + (hunk-reset hunk) + (do ((i 0 (1+ i)) + (dl (cdr first) (cdr dl))) + ((eq dl *the-sentinel*) + (setf (window-old-lines window) (1- i))) + (dumb-line-redisplay hunk (car dl))) + (setf (window-first-changed window) *the-sentinel* + (window-last-changed window) first) + (when (window-modeline-buffer window) + (hunk-replace-modeline hunk) + (setf (dis-line-flags (window-modeline-dis-line window)) + unaltered-bits)) + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))))) + + +;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already. +;;; +(defun dumb-line-redisplay (hunk dl) + (hunk-write-line hunk dl) + (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) + + + + +;;;; Smart window redisplay. + +;;; We scan through the changed dis-lines, and condense the information +;;; obtained into five categories: Unchanged lines moved down, unchanged +;;; lines moved up, lines that need to be cleared, lines that are in the +;;; same place (but changed), and new or moved-and-changed lines to write. +;;; Each such instance of a thing that needs to be done is remembered be +;;; throwing needed information on a stack specific to the thing to be +;;; done. We cannot do any of these things right away because each may +;;; confict with the previous. +;;; +;;; Each stack is represented by a simple-vector big enough to hold the +;;; worst-case number of entries and a pointer to the next free entry. The +;;; pointers are local variables returned from COMPUTE-CHANGES and used by +;;; SMART-WINDOW-REDISPLAY. Note that the order specified in these tuples +;;; is the order in which they were pushed. +;;; +(defvar *display-down-move-stack* (make-array (* hunk-height-limit 2)) + "This is the vector that we stash info about which lines moved down in + as (Start, End, Count) triples.") +(defvar *display-up-move-stack* (make-array (* hunk-height-limit 2)) + "This is the vector that we stash info about which lines moved up in + as (Start, End, Count) triples.") +(defvar *display-erase-stack* (make-array hunk-height-limit) + "This is the vector that we stash info about which lines need to be erased + as (Start, Count) pairs.") +(defvar *display-write-stack* (make-array hunk-height-limit) + "This is the vector that we stash dis-lines in that need to be written.") +(defvar *display-rewrite-stack* (make-array hunk-height-limit) + "This is the vector that we stash dis-lines in that need to be written. + with clear-to-end.") + +;;; Accessor macros to push and pop on the stacks: +;;; +(eval-when (:compile-toplevel :execute) + +(defmacro spush (thing stack stack-pointer) + `(progn + (setf (svref ,stack ,stack-pointer) ,thing) + (incf ,stack-pointer))) + +(defmacro spop (stack stack-pointer) + `(svref ,stack (decf ,stack-pointer))) + +(defmacro snext (stack stack-pointer) + `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer))) + +); eval-when + + +;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed, +;;; and updates them with smart-line-redisplay if not very much has changed. +;;; Lines which have moved are copied. We must be careful not to redisplay +;;; the window with the cursor down since it is not guaranteed to be out of +;;; the way just because we are in redisplay; LIFT-CURSOR is called just before +;;; the screen may be altered, and it takes care to know whether the cursor +;;; is lifted already or not. At the end, if the cursor had been down, +;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called +;;; since it does nothing if the cursor is already down. +;;; +(defun smart-window-redisplay (window) + ;; This isn't actually called --GB + (let* ((hunk (window-hunk window)) + (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) + (when (bitmap-hunk-trashed hunk) + (when liftp (lift-cursor)) + (dumb-window-redisplay window) + (when liftp (drop-cursor)) + (return-from smart-window-redisplay nil)) + (let ((first-changed (window-first-changed window)) + (last-changed (window-last-changed window))) + ;; Is there anything to do? + (unless (eq first-changed *the-sentinel*) + (when liftp (lift-cursor)) + (if (and (eq first-changed last-changed) + (zerop (dis-line-delta (car first-changed)))) + ;; One line changed. + (smart-line-redisplay hunk (car first-changed)) + ;; More than one line changed. + (multiple-value-bind (up down erase write rewrite) + (compute-changes first-changed last-changed) + (do-down-moves hunk down) + (do-up-moves hunk up) + (do-erases hunk erase) + (do-writes hunk write) + (do-rewrites hunk rewrite))) + ;; Set the bounds so we know we displayed... + (setf (window-first-changed window) *the-sentinel* + (window-last-changed window) (window-first-line window)))) + ;; + ;; Clear any extra lines at the end of the window. + (let ((pos (dis-line-position (car (window-last-line window))))) + (when (< pos (window-old-lines window)) + (when liftp (lift-cursor)) + (hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1))) + (setf (window-old-lines window) pos)) + ;; + ;; Update the modeline if needed. + (when (window-modeline-buffer window) + (when (/= (dis-line-flags (window-modeline-dis-line window)) + unaltered-bits) + (hunk-replace-modeline hunk) + (setf (dis-line-flags (window-modeline-dis-line window)) + unaltered-bits))) + ;; + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) + (when liftp (drop-cursor)))) + +;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans +;;; through the changed dis-lines in a window, computes the changes needed +;;; to bring the screen into corespondence, and throws the information +;;; needed to do the change onto the apropriate stack. The pointers into +;;; the stacks (up, down, erase, write, and rewrite) are returned. +;;; +;;; The algorithm is as follows: +;;; 1] If the line is moved-and-changed or new then throw the line on +;;; the write stack and increment the clear count. Repeat until no more +;;; such lines are found. +;;; 2] If the line is moved then flush any pending clear, find how many +;;; consecutive lines are moved the same amount, and put the numbers +;;; on the correct move stack. +;;; 3] If the line is changed and unmoved throw it on a write stack. +;;; If a clear is pending throw it in the write stack and bump the clear +;;; count, otherwise throw it on the rewrite stack. +;;; 4] The line is unchanged, do nothing. +;;; +(defun compute-changes (first-changed last-changed) + (let* ((dl first-changed) + (flags (dis-line-flags (car dl))) + (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values. + (clear-count 0) + prev clear-start) + (declare (fixnum up down erase write rewrite clear-count)) + (loop + (cond + ;; Line moved-and-changed or new. + ((> flags moved-bit) + (when (zerop clear-count) + (setq clear-start (dis-line-position (car dl)))) + (loop + (setf (dis-line-delta (car dl)) 0) + (spush (car dl) *display-write-stack* write) + (incf clear-count) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) + (when (<= flags moved-bit) (return nil)))) + ;; Line moved, unchanged. + ((= flags moved-bit) + (unless (zerop clear-count) + (spush clear-count *display-erase-stack* erase) + (spush clear-start *display-erase-stack* erase) + (setq clear-count 0)) + (do ((delta (dis-line-delta (car dl))) + (end (dis-line-position (car dl))) + (count 1 (1+ count))) + (()) + (setf (dis-line-delta (car dl)) 0 + (dis-line-flags (car dl)) unaltered-bits) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))) + (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit)) + ;; We push in different order because we pop in different order. + (cond + ((minusp delta) + (spush (- end delta) *display-up-move-stack* up) + (spush end *display-up-move-stack* up) + (spush count *display-up-move-stack* up)) + (t + (spush count *display-down-move-stack* down) + (spush end *display-down-move-stack* down) + (spush (- end delta) *display-down-move-stack* down))) + (return nil)))) + ;; Line changed, unmoved. + ((= flags changed-bit) + (cond ((zerop clear-count) + (spush (car dl) *display-rewrite-stack* rewrite)) + (t + (spush (car dl) *display-write-stack* write) + (incf clear-count))) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl)))) + ;; Line unmoved, unchanged. + (t + (unless (zerop clear-count) + (spush clear-count *display-erase-stack* erase) + (spush clear-start *display-erase-stack* erase) + (setq clear-count 0)) + (setq prev dl dl (cdr dl) flags (dis-line-flags (car dl))))) + + (when (eq prev last-changed) + ;; If done flush any pending clear. + (unless (zerop clear-count) + (spush clear-count *display-erase-stack* erase) + (spush clear-start *display-erase-stack* erase)) + (return (values up down erase write rewrite)))))) + +(defun do-up-moves (hunk up) + (do ((i 0)) + ((= i up)) + (hunk-copy-lines hunk (snext *display-up-move-stack* i) + (snext *display-up-move-stack* i) + (snext *display-up-move-stack* i)))) + +(defun do-down-moves (hunk down) + (do () + ((zerop down)) + (hunk-copy-lines hunk (spop *display-down-move-stack* down) + (spop *display-down-move-stack* down) + (spop *display-down-move-stack* down)))) + +(defun do-erases (hunk erase) + (do () + ((zerop erase)) + (hunk-clear-lines hunk (spop *display-erase-stack* erase) + (spop *display-erase-stack* erase)))) + +(defun do-writes (hunk write) + (do ((i 0)) + ((= i write)) + (dumb-line-redisplay hunk (snext *display-write-stack* i)))) + +(defun do-rewrites (hunk rewrite) + (do () + ((zerop rewrite)) + (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite)))) + + +;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same, +;;; clear to eol after we write it to avoid annoying flicker. +;;; +(defun smart-line-redisplay (hunk dl) + (hunk-replace-line hunk dl) + (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bit-screen.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bit-screen.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bit-screen.lisp (revision 8058) @@ -0,0 +1,1873 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Screen allocation functions. +;;; +;;; This is the screen management and event handlers for Hemlock under X. +;;; +;;; Written by Bill Chiles, Rob MacLachlan, and Blaine Burks. +;;; + +(in-package :hemlock-internals) + +(declaim (special *echo-area-window*)) + +;;; We have an internal notion of window groups on bitmap devices. Every +;;; Hemlock window has a hunk slot which holds a structure with information +;;; about physical real-estate on some device. Bitmap-hunks have an X window +;;; and a window-group. The X window is a child of the window-group's window. +;;; The echo area, pop-up display window, and the initial window are all in +;;; their own group. +;;; +;;; MAKE-WINDOW splits the current window which is some child window in a group. +;;; If the user supplied an X window, it becomes the parent window of some new +;;; group, and we make a child for the Hemlock window. If the user supplies +;;; ask-user, we prompt for a group/parent window. We link the hunks for +;;; NEXT-WINDOW and PREVIOUS-WINDOW only within a group, so the group maintains +;;; a stack of windows that always fill the entire group window. +;;; + +;;; This is the object set for Hemlock windows. All types of incoming +;;; X events on standard editing windows have the same handlers via this set. +;;; We also include the group/parent windows in here, but they only handle +;;; :configure-notify events. +;;; +(defvar *hemlock-windows* + #+clx + (hemlock-ext:make-object-set "Hemlock Windows" #'hemlock-ext:default-clx-event-handler)) + + + + +;;;; Some window making parameters. + +;;; These could be parameters, but they have to be set after the display is +;;; opened. These are set in INIT-BITMAP-SCREEN-MANAGER. + +(defvar *default-background-pixel* nil + "Default background color. It defaults to white.") + +(defvar *default-foreground-pixel* nil + "Default foreground color. It defaults to black.") + +(defvar *foreground-background-xor* nil + "The LOGXOR of *default-background-pixel* and *default-foreground-pixel*.") + +(defvar *default-border-pixmap* nil + "This is the default color of X window borders. It defaults to a + grey pattern.") + +(defvar *highlight-border-pixmap* nil + "This is the color of the border of the current window when the mouse + cursor is over any Hemlock window.") + + + + +;;;; Exposed region handling. + +;;; :exposure events are sent because we selected them. :graphics-exposure +;;; events are generated because of a slot in our graphics contexts. These are +;;; generated from using XLIB:COPY-AREA when the source could not be generated. +;;; Also, :no-exposure events are sent when a :graphics-exposure event could +;;; have been sent but wasn't. +;;; +#| +;;; This is an old handler that doesn't do anything clever about multiple +;;; exposures. +(defun hunk-exposed-region (hunk &key y height &allow-other-keys) + (if (bitmap-hunk-lock hunk) + (setf (bitmap-hunk-trashed hunk) t) + (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))) + (when liftp (lift-cursor)) + ;; (hunk-draw-top-border hunk) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-height (font-family-height font-family)) + (co (font-family-cursor-y-offset font-family)) + (start (truncate (- y hunk-top-border) font-height)) + (end (ceiling (- (+ y height) hunk-top-border) font-height)) + (start-bit (+ (* start font-height) co hunk-top-border)) + (nheight (- (* (- end start) font-height) co)) + (end-line (bitmap-hunk-end hunk))) + (declare (fixnum font-height co start end start-bit nheight)) + (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit + :width (bitmap-hunk-width hunk) :height nheight) + (do ((dl (bitmap-hunk-start hunk) (cdr dl)) + (i 0 (1+ i))) + ((or (eq dl end-line) (= i start)) + (do ((i i (1+ i)) + (dl dl (cdr dl))) + ((or (eq dl end-line) (= i end))) + (declare (fixnum i)) + (hunk-write-line hunk (car dl) i))) + (declare (fixnum i))) + (when (and (bitmap-hunk-modeline-pos hunk) + (>= (the fixnum (+ nheight start-bit)) + (the fixnum (bitmap-hunk-modeline-pos hunk)))) + (hunk-replace-modeline hunk))) + (when liftp (drop-cursor))))) +|# + +;;; HUNK-EXPOSED-REGION redisplays the appropriate rectangle from the hunk +;;; dis-lines. Don't do anything if the hunk is trashed since redisplay is +;;; probably about to fix everything; specifically, this keeps new windows +;;; from getting drawn twice (once for the exposure and once for being trashed). +;;; +;;; Exposure and graphics-exposure events pass in a different number of +;;; arguments, with some the same but in a different order, so we just bind +;;; and ignore foo, bar, baz, and quux. +;;; +#+clx +(defun hunk-exposed-region (hunk event-key event-window x y width height + foo bar &optional baz quux) + (declare (ignore event-key event-window x width foo bar baz quux)) + (unless (bitmap-hunk-trashed hunk) + (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)) + (display (bitmap-device-display (device-hunk-device hunk)))) + (when liftp (lift-cursor)) + (multiple-value-bind (y-peek height-peek) + (exposed-region-peek-event display + (bitmap-hunk-xwindow hunk)) + (if y-peek + (let ((n (coelesce-exposed-regions hunk display + y height y-peek height-peek))) + (write-n-exposed-regions hunk n)) + (write-one-exposed-region hunk y height))) + (xlib:display-force-output display) + (when liftp (drop-cursor))))) +;;; +#+clx (hemlock-ext:serve-exposure *hemlock-windows* #'hunk-exposed-region) +#+clx (hemlock-ext:serve-graphics-exposure *hemlock-windows* #'hunk-exposed-region) + + +;;; HUNK-NO-EXPOSURE handles this bullshit event that gets sent without its +;;; being requested. +;;; +(defun hunk-no-exposure (hunk event-key event-window major minor send-event-p) + (declare (ignore hunk event-key event-window major minor send-event-p)) + t) +;;; +#+clx (hemlock-ext:serve-no-exposure *hemlock-windows* #'hunk-no-exposure) + + +;;; EXPOSED-REGION-PEEK-EVENT returns the position and height of an :exposure +;;; or :graphics-exposure event on win if one exists. If there are none, then +;;; nil and nil are returned. +;;; +#+clx +(defun exposed-region-peek-event (display win) + (xlib:display-finish-output display) + (let ((result-y nil) + (result-height nil)) + (xlib:process-event + display :timeout 0 + :handler #'(lambda (&key event-key event-window window y height + &allow-other-keys) + (cond ((and (or (eq event-key :exposure) + (eq event-key :graphics-exposure)) + (or (eq event-window win) (eq window win))) + (setf result-y y) + (setf result-height height) + t) + (t nil)))) + (values result-y result-height))) + +;;; COELESCE-EXPOSED-REGIONS insert sorts exposed region events from the X +;;; input queue into *coelesce-buffer*. Then the regions are merged into the +;;; same number or fewer regions that are vertically distinct +;;; (non-overlapping). When this function is called, one event has already +;;; been popped from the queue, the first event that caused HUNK-EXPOSED-REGION +;;; to be called. That information is passed in as y1 and height1. There is +;;; a second event that also has already been popped from the queue, the +;;; event resulting from peeking for multiple "exposure" events. That info +;;; is passed in as y2 and height2. +;;; +(defun coelesce-exposed-regions (hunk display y1 height1 y2 height2) + (let ((len 0)) + (declare (fixnum len)) + ;; + ;; Insert sort the exposeevents as we pick them off the event queue. + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-height (font-family-height font-family)) + (co (font-family-cursor-y-offset font-family)) + (xwindow (bitmap-hunk-xwindow hunk))) + ;; + ;; Insert the region the exposedregion handler was called on. + (multiple-value-bind (start-line start-bit end-line expanded-height) + (exposed-region-bounds y1 height1 co font-height) + (setf len + (coelesce-buffer-insert start-bit start-line + expanded-height end-line len))) + ;; + ;; Peek for exposedregion events on xwindow, inserting them into + ;; the buffer. + (let ((y y2) + (height height2)) + (loop + (multiple-value-bind (start-line start-bit end-line expanded-height) + (exposed-region-bounds y height co font-height) + (setf len + (coelesce-buffer-insert start-bit start-line + expanded-height end-line len))) + (multiple-value-setq (y height) + (exposed-region-peek-event display xwindow)) + (unless y (return))))) + (coelesce-exposed-regions-merge len))) + +;;; *coelesce-buffer* is a vector of records used to sort exposure events on a +;;; single hunk, so we can merge them into fewer, larger regions of exposure. +;;; COELESCE-BUFFER-INSERT places elements in this buffer, and each element +;;; is referenced with COELESCE-BUFFER-ELT. Each element of the coelescing +;;; buffer has the following accessors defined: +;;; COELESCE-BUFFER-ELT-START in pixels. +;;; COELESCE-BUFFER-ELT-START-LINE in dis-lines. +;;; COELESCE-BUFFER-ELT-HEIGHT in pixels. +;;; COELESCE-BUFFER-ELT-END-LINE in dis-lines. +;;; These are used by COELESCE-BUFFER-INSERT, COELESCE-EXPOSED-REGIONS-MERGE, +;;; and WRITE-N-EXPOSED-REGIONS. + +(defvar *coelesce-buffer-fill-ptr* 25) +(defvar *coelesce-buffer* (make-array *coelesce-buffer-fill-ptr*)) +(dotimes (i *coelesce-buffer-fill-ptr*) + (setf (svref *coelesce-buffer* i) (make-array 4))) + +(defmacro coelesce-buffer-elt-start (elt) + `(svref ,elt 0)) +(defmacro coelesce-buffer-elt-start-line (elt) + `(svref ,elt 1)) +(defmacro coelesce-buffer-elt-height (elt) + `(svref ,elt 2)) +(defmacro coelesce-buffer-elt-end-line (elt) + `(svref ,elt 3)) +(defmacro coelesce-buffer-elt (i) + `(svref *coelesce-buffer* ,i)) + +;;; COELESCE-BUFFER-INSERT inserts an exposed region record into +;;; *coelesce-buffer* such that start is less than all successive +;;; elements. Returns the new length of the buffer. +;;; +(defun coelesce-buffer-insert (start start-line height end-line len) + (declare (fixnum start start-line height end-line len)) + ;; + ;; Add element if len is to fill pointer. If fill pointer is to buffer + ;; length, then grow buffer. + (when (= len (the fixnum *coelesce-buffer-fill-ptr*)) + (when (= (the fixnum *coelesce-buffer-fill-ptr*) + (the fixnum (length (the simple-vector *coelesce-buffer*)))) + (let ((new (make-array (ash (length (the simple-vector *coelesce-buffer*)) + 1)))) + (replace (the simple-vector new) (the simple-vector *coelesce-buffer*) + :end1 *coelesce-buffer-fill-ptr* + :end2 *coelesce-buffer-fill-ptr*) + (setf *coelesce-buffer* new))) + (setf (coelesce-buffer-elt len) (make-array 4)) + (incf *coelesce-buffer-fill-ptr*)) + ;; + ;; Find point to insert record: start, start-line, height, and end-line. + (do ((i 0 (1+ i))) + ((= i len) + ;; Start is greater than all previous starts. Add it to the end. + (let ((region (coelesce-buffer-elt len))) + (setf (coelesce-buffer-elt-start region) start) + (setf (coelesce-buffer-elt-start-line region) start-line) + (setf (coelesce-buffer-elt-height region) height) + (setf (coelesce-buffer-elt-end-line region) end-line))) + (declare (fixnum i)) + (when (< start (the fixnum + (coelesce-buffer-elt-start (coelesce-buffer-elt i)))) + ;; + ;; Insert new element at i, using storage allocated at element len. + (let ((last (coelesce-buffer-elt len))) + (setf (coelesce-buffer-elt-start last) start) + (setf (coelesce-buffer-elt-start-line last) start-line) + (setf (coelesce-buffer-elt-height last) height) + (setf (coelesce-buffer-elt-end-line last) end-line) + ;; + ;; Shift elements after i (inclusively) to the right. + (do ((j (1- len) (1- j)) + (k len j) + (terminus (1- i))) + ((= j terminus)) + (declare (fixnum j k terminus)) + (setf (coelesce-buffer-elt k) (coelesce-buffer-elt j))) + ;; + ;; Stash element to insert at i. + (setf (coelesce-buffer-elt i) last)) + (return))) + (1+ len)) + + +;;; COELESCE-EXPOSED-REGIONS-MERGE merges/coelesces the regions in +;;; *coelesce-buffer*. It takes the number of elements and returns the new +;;; number of elements. The regions are examined one at a time relative to +;;; the current one. The current region remains so, with next advancing +;;; through the buffer, until a next region is found that does not overlap +;;; and is not adjacent. When this happens, the current values are stored +;;; in the current region, and the buffer's element after the current element +;;; becomes current. The next element that was found not to be in contact +;;; the old current element is stored in the new current element by copying +;;; its values there. The buffer's elements always stay in place, and their +;;; storage is re-used. After this process which makes the next region be +;;; the current region, the next pointer is incremented. +;;; +(defun coelesce-exposed-regions-merge (len) + (let* ((current 0) + (next 1) + (current-region (coelesce-buffer-elt 0)) + (current-height (coelesce-buffer-elt-height current-region)) + (current-end-line (coelesce-buffer-elt-end-line current-region)) + (current-end-bit (+ (the fixnum + (coelesce-buffer-elt-start current-region)) + current-height))) + (declare (fixnum current next current-height + current-end-line current-end-bit)) + (loop + (let* ((next-region (coelesce-buffer-elt next)) + (next-start (coelesce-buffer-elt-start next-region)) + (next-height (coelesce-buffer-elt-height next-region)) + (next-end-bit (+ next-start next-height))) + (declare (fixnum next-start next-height next-end-bit)) + (cond ((<= next-start current-end-bit) + (let ((extra-height (- next-end-bit current-end-bit))) + (declare (fixnum extra-height)) + ;; Maybe the next region is contained in the current. + (when (plusp extra-height) + (incf current-height extra-height) + (setf current-end-bit next-end-bit) + (setf current-end-line + (coelesce-buffer-elt-end-line next-region))))) + (t + ;; + ;; Update current record since next does not overlap + ;; with current. + (setf (coelesce-buffer-elt-height current-region) + current-height) + (setf (coelesce-buffer-elt-end-line current-region) + current-end-line) + ;; + ;; Move to new distinct region, copying data from next region. + (incf current) + (setf current-region (coelesce-buffer-elt current)) + (setf (coelesce-buffer-elt-start current-region) next-start) + (setf (coelesce-buffer-elt-start-line current-region) + (coelesce-buffer-elt-start-line next-region)) + (setf current-height next-height) + (setf current-end-bit next-end-bit) + (setf current-end-line + (coelesce-buffer-elt-end-line next-region))))) + (incf next) + (when (= next len) + (setf (coelesce-buffer-elt-height current-region) current-height) + (setf (coelesce-buffer-elt-end-line current-region) current-end-line) + (return))) + (1+ current))) + +;;; EXPOSED-REGION-BOUNDS returns as multiple values the first line affected, +;;; the first possible bit affected (accounting for the cursor), the end line +;;; affected, and the height of the region. +;;; +(defun exposed-region-bounds (y height cursor-offset font-height) + (declare (fixnum y height cursor-offset font-height)) + (let* ((start (truncate (the fixnum (- y hunk-top-border)) + font-height)) + (end (ceiling (the fixnum (- (the fixnum (+ y height)) + hunk-top-border)) + font-height))) + (values + start + (+ (the fixnum (* start font-height)) cursor-offset hunk-top-border) + end + (- (the fixnum (* (the fixnum (- end start)) font-height)) + cursor-offset)))) + +#+clx +(defun write-n-exposed-regions (hunk n) + (declare (fixnum n)) + (let* (;; Loop constants. + (end-dl (bitmap-hunk-end hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (hunk-width (bitmap-hunk-width hunk)) + ;; Loop variables. + (dl (bitmap-hunk-start hunk)) + (i 0) + (region (coelesce-buffer-elt 0)) + (start-line (coelesce-buffer-elt-start-line region)) + (start (coelesce-buffer-elt-start region)) + (height (coelesce-buffer-elt-height region)) + (end-line (coelesce-buffer-elt-end-line region)) + (region-idx 0)) + (declare (fixnum i start start-line height end-line region-idx)) + (loop + (xlib:clear-area xwindow :x 0 :y start :width hunk-width :height height) + ;; Find this regions first line. + (loop + (when (or (eq dl end-dl) (= i start-line)) + (return)) + (incf i) + (setf dl (cdr dl))) + ;; Write this region's lines. + (loop + (when (or (eq dl end-dl) (= i end-line)) + (return)) + (hunk-write-line hunk (car dl) i) + (incf i) + (setf dl (cdr dl))) + ;; Get next region unless we're done. + (when (= (incf region-idx) n) (return)) + (setf region (coelesce-buffer-elt region-idx)) + (setf start (coelesce-buffer-elt-start region)) + (setf start-line (coelesce-buffer-elt-start-line region)) + (setf height (coelesce-buffer-elt-height region)) + (setf end-line (coelesce-buffer-elt-end-line region))) + ;; + ;; Check for modeline exposure. + (setf region (coelesce-buffer-elt (1- n))) + (setf start (coelesce-buffer-elt-start region)) + (setf height (coelesce-buffer-elt-height region)) + (when (and (bitmap-hunk-modeline-pos hunk) + (> (+ start height) + (- (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-bottom-border hunk)))) + (hunk-replace-modeline hunk) + (hunk-draw-bottom-border hunk)))) + +#+clx +(defun write-one-exposed-region (hunk y height) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-height (font-family-height font-family)) + (co (font-family-cursor-y-offset font-family)) + (start-line (truncate (- y hunk-top-border) font-height)) + (end-line (ceiling (- (+ y height) hunk-top-border) font-height)) + (start-bit (+ (* start-line font-height) co hunk-top-border)) + (nheight (- (* (- end-line start-line) font-height) co)) + (hunk-end-line (bitmap-hunk-end hunk))) + (declare (fixnum font-height co start-line end-line start-bit nheight)) + (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit + :width (bitmap-hunk-width hunk) :height nheight) + (do ((dl (bitmap-hunk-start hunk) (cdr dl)) + (i 0 (1+ i))) + ((or (eq dl hunk-end-line) (= i start-line)) + (do ((i i (1+ i)) + (dl dl (cdr dl))) + ((or (eq dl hunk-end-line) (= i end-line))) + (declare (fixnum i)) + (hunk-write-line hunk (car dl) i))) + (declare (fixnum i))) + (when (and (bitmap-hunk-modeline-pos hunk) + (> (+ start-bit nheight) + (- (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-bottom-border hunk)))) + (hunk-replace-modeline hunk) + (hunk-draw-bottom-border hunk)))) + + + + +;;;; Resized window handling. + +;;; :configure-notify events are sent because we select :structure-notify. +;;; This buys us a lot of events we have to write dummy handlers to ignore. +;;; + +;;; HUNK-RECONFIGURED -- Internal. +;;; +;;; This must note that the hunk changed to prevent certain redisplay problems +;;; with recentering the window that caused bogus lines to be drawn after the +;;; actual visible text in the window. We must also indicate the hunk is +;;; trashed to eliminate exposure event handling that comes after resizing. +;;; This also causes a full redisplay on the window which is the easiest and +;;; generally best looking thing. +;;; +(defun hunk-reconfigured (object event-key event-window window x y width + height border-width above-sibling + override-redirect-p send-event-p) + (declare (ignore event-key event-window window x y border-width + above-sibling override-redirect-p send-event-p)) + (typecase object + (bitmap-hunk + (when (or (/= width (bitmap-hunk-width object)) + (/= height (bitmap-hunk-height object))) + (hunk-changed object width height nil) + ;; Under X11, don't redisplay since an exposure event is coming next. + (setf (bitmap-hunk-trashed object) t))) + (window-group + (let ((old-width (window-group-width object)) + (old-height (window-group-height object))) + (when (or (/= width old-width) (/= height old-height)) + (window-group-changed object width height)))))) +;;; +#+clx (hemlock-ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured) + + +;;; HUNK-IGNORE-EVENT ignores the following unrequested events. They all take +;;; at least five arguments, but then there are up to four more optional. +;;; +(defun hunk-ignore-event (hunk event-key event-window window one + &optional two three four five) + (declare (ignore hunk event-key event-window window one two three four five)) + t) +;;; +#+clx (hemlock-ext:serve-destroy-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-unmap-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-map-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-reparent-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-gravity-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-circulate-notify *hemlock-windows* #'hunk-ignore-event) +#+clx (hemlock-ext:serve-client-message *hemlock-windows* #'hunk-ignore-event) + + + +;;;; Interface to X input events. + +;;; HUNK-KEY-INPUT and HUNK-MOUSE-INPUT. +;;; Each key and mouse event is turned into a character via +;;; HEMLOCK-EXT:TRANSLATE-CHARACTER or HEMLOCK-EXT:TRANSLATE-MOUSE-CHARACTER, either of which +;;; may return nil. Nil is returned for input that is considered uninteresting +;;; input; for example, shift and control. +;;; + +(defun hunk-key-input (hunk event-key event-window root child same-screen-p x y + root-x root-y modifiers time key-code send-event-p) + (declare (ignore event-key event-window root child same-screen-p root-x + root-y time send-event-p)) + (hunk-process-input hunk + (hemlock-ext:translate-key-event + (bitmap-device-display (device-hunk-device hunk)) + key-code modifiers) + x y)) +;;; +#+clx (hemlock-ext:serve-key-press *hemlock-windows* #'hunk-key-input) + +(defun hunk-mouse-input (hunk event-key event-window root child same-screen-p x y + root-x root-y modifiers time key-code send-event-p) + (declare (ignore event-window root child same-screen-p root-x root-y + time send-event-p)) + (hunk-process-input hunk + (hemlock-ext:translate-mouse-key-event key-code modifiers + event-key) + x y)) +;;; +#+clx (hemlock-ext:serve-button-press *hemlock-windows* #'hunk-mouse-input) +#+clx (hemlock-ext:serve-button-release *hemlock-windows* #'hunk-mouse-input) + +(defun hunk-process-input (hunk char x y) + (when char + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-width (font-family-width font-family)) + (font-height (font-family-height font-family)) + (ml-pos (bitmap-hunk-modeline-pos hunk)) + (height (bitmap-hunk-height hunk)) + (width (bitmap-hunk-width hunk)) + (handler (bitmap-hunk-input-handler hunk)) + (char-width (bitmap-hunk-char-width hunk))) + (cond ((not (and (< -1 x width) (< -1 y height))) + (funcall handler hunk char nil nil)) + ((and ml-pos (> y (- ml-pos (bitmap-hunk-bottom-border hunk)))) + (funcall handler hunk char + ;; (/ width x) doesn't handle ends of thumb bar + ;; and eob right, so do a bunch of truncating. + (min (truncate x (truncate width char-width)) + (1- char-width)) + nil)) + (t + (let* ((cx (truncate (- x hunk-left-border) font-width)) + (temp (truncate (- y hunk-top-border) font-height)) + (char-height (bitmap-hunk-char-height hunk)) + ;; Extra bits below bottom line and above modeline and + ;; thumb bar are considered part of the bottom line since + ;; we have already picked off the y=nil case. + (cy (if (< temp char-height) temp (1- char-height)))) + (if (and (< -1 cx char-width) + (< -1 cy)) + (funcall handler hunk char cx cy) + (funcall handler hunk char nil nil)))))))) + + + + +;;;; Handling boundary crossing events. + +;;; Entering and leaving a window are handled basically the same except that it +;;; is possible to get an entering event under X without getting an exiting +;;; event; specifically, when the mouse is in a Hemlock window that is over +;;; another window, and someone buries the top window, Hemlock only gets an +;;; entering event on the lower window (no exiting event for the buried +;;; window). +;;; +;;; :enter-notify and :leave-notify events are sent because we select +;;; :enter-window and :leave-window events. +;;; + +#+clx +(defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (declare (ignore event-key event-window child root same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (when (and *cursor-dropped* (not *hemlock-listener*)) + (cursor-invert-center)) + (setf *hemlock-listener* t) + (let ((current-hunk (window-hunk (current-window)))) + (unless (and *current-highlighted-border* + (eq *current-highlighted-border* current-hunk)) + (setf (xlib:window-border (window-group-xparent + (bitmap-hunk-window-group current-hunk))) + *highlight-border-pixmap*) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device current-hunk))) + (setf *current-highlighted-border* current-hunk))) + (let ((window (bitmap-hunk-window hunk))) + (when window (invoke-hook hemlock::enter-window-hook window)))) +;;; +#+clx (hemlock-ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered) + +#+clx +(defun hunk-mouse-left (hunk event-key event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (declare (ignore event-key event-window child root same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (setf *hemlock-listener* nil) + (when *cursor-dropped* (cursor-invert-center)) + (when *current-highlighted-border* + (setf (xlib:window-border (window-group-xparent + (bitmap-hunk-window-group + *current-highlighted-border*))) + *default-border-pixmap*) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *current-highlighted-border*))) + (setf *current-highlighted-border* nil)) + (let ((window (bitmap-hunk-window hunk))) + (when window (invoke-hook hemlock::exit-window-hook window)))) +;;; +#+clx (hemlock-ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left) + + + + +;;;; Making a Window. + +(defparameter minimum-window-height 100 + "If the window created by splitting a window would be shorter than this, + then we create an overlapped window the same size instead.") + +;;; The width must be that of a tab for the screen image builder, and the +;;; height must be one line (two with a modeline). +;;; +(defconstant minimum-window-lines 2 + "Windows must have at least this many lines.") +(defconstant minimum-window-columns 10 + "Windows must be at least this many characters wide.") + +(eval-when (:compile-toplevel :execute :load-toplevel) +(defconstant xwindow-border-width 2 "X border around X windows") +(defconstant xwindow-border-width*2 (* xwindow-border-width 2)) +); eval-when + +;;; We must name windows (set the "name" property) to get around a bug in +;;; awm and twm. They will not handle menu clicks without a window having +;;; a name. We set the name to this silly thing. +;;; +(defvar *hemlock-window-count* 0) +;;; +(defun new-hemlock-window-name () + (let ((*print-base* 10)) + (format nil "Hemlock ~S" (incf *hemlock-window-count*)))) + +(declaim (inline surplus-window-height surplus-window-height-w/-modeline)) +;;; +(defun surplus-window-height (thumb-bar-p) + (+ hunk-top-border (if thumb-bar-p + hunk-thumb-bar-bottom-border + hunk-bottom-border))) +;;; +(defun surplus-window-height-w/-modeline (thumb-bar-p) + (+ (surplus-window-height thumb-bar-p) + hunk-modeline-top + hunk-modeline-bottom)) + + +;;; DEFAULT-CREATE-WINDOW-HOOK -- Internal. +;;; +;;; This is the default value for *create-window-hook*. It makes an X window +;;; for a new group/parent on the given display possibly prompting the user. +;;; +#+clx +(defun default-create-window-hook (display x y width height name font-family + &optional modelinep thumb-bar-p) + (maybe-prompt-user-for-window + (xlib:screen-root (xlib:display-default-screen display)) + x y width height font-family modelinep thumb-bar-p name)) + +#-clx +(defun default-create-window-hook (display x y width height name font-family + &optional modelinep thumb-bar-p) + (declare (ignore display x y width height name font-family + modelinep thumb-bar-p))) + +;;; MAYBE-PROMPT-USER-FOR-WINDOW -- Internal. +;;; +;;; This makes an X window and sets its standard properties according to +;;; supplied values. When some of these are nil, the window manager should +;;; prompt the user for those missing values when the window gets mapped. We +;;; use this when making new group/parent windows. Returns the window without +;;; mapping it. +;;; +(defun maybe-prompt-user-for-window (root x y width height font-family + modelinep thumb-bar-p icon-name) + (let ((font-height (font-family-height font-family)) + (font-width (font-family-width font-family)) + (extra-y (surplus-window-height thumb-bar-p)) + (extra-y-w/-modeline (surplus-window-height-w/-modeline thumb-bar-p))) + (create-window-with-properties + root x y + (if width (+ (* width font-width) hunk-left-border)) + (if height + (if modelinep + (+ (* (1+ height) font-height) extra-y-w/-modeline) + (+ (* height font-height) extra-y))) + font-width font-height icon-name + (+ (* minimum-window-columns font-width) hunk-left-border) + (if modelinep + (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline) + (+ (* minimum-window-lines font-height) extra-y)) + t))) + +(defvar *create-window-hook* #'default-create-window-hook + "Hemlock calls this function when it makes a new X window for a new group. + It passes as arguments the X display, x (from MAKE-WINDOW), y (from + MAKE-WINDOW), width (from MAKE-WINDOW), height (from MAKE-WINDOW), a name + for the window's icon-name, font-family (from MAKE-WINDOW), modelinep (from + MAKE-WINDOW), and whether the window will have a thumb-bar meter. The + function returns a window or nil.") + +;;; BITMAP-MAKE-WINDOW -- Internal. +;;; +#+clx +(defun bitmap-make-window (device start modelinep window font-family + ask-user x y width-arg height-arg proportion) + (let* ((display (bitmap-device-display device)) + (thumb-bar-p (value hemlock::thumb-bar-meter)) + (hunk (make-bitmap-hunk + :font-family font-family + :end *the-sentinel* :trashed t + :input-handler #'window-input-handler + :device device + :thumb-bar-p (and modelinep thumb-bar-p)))) + (multiple-value-bind + (xparent xwindow) + (maybe-make-x-window-and-parent window display start ask-user x y + width-arg height-arg font-family + modelinep thumb-bar-p proportion) + (unless xwindow (return-from bitmap-make-window nil)) + (let ((window-group (make-window-group xparent + (xlib:drawable-width xparent) + (xlib:drawable-height xparent)))) + (setf (bitmap-hunk-xwindow hunk) xwindow) + (setf (bitmap-hunk-window-group hunk) window-group) + (setf (bitmap-hunk-gcontext hunk) + (default-gcontext xwindow font-family)) + ;; + ;; Select input and enable event service before showing the window. + (setf (xlib:window-event-mask xwindow) child-interesting-xevents-mask) + (setf (xlib:window-event-mask xparent) group-interesting-xevents-mask) + (add-xwindow-object xwindow hunk *hemlock-windows*) + (add-xwindow-object xparent window-group *hemlock-windows*)) + (when xparent (xlib:map-window xparent)) + (xlib:map-window xwindow) + (xlib:display-finish-output display) + ;; A window is not really mapped until it is viewable. It is said to be + ;; mapped if a map request has been sent whether it is handled or not. + (loop (when (and (eq (xlib:window-map-state xwindow) :viewable) + (eq (xlib:window-map-state xparent) :viewable)) + (return))) + ;; + ;; Find out how big it is... + (xlib:with-state (xwindow) + (set-hunk-size hunk (xlib:drawable-width xwindow) + (xlib:drawable-height xwindow) modelinep))) + (setf (bitmap-hunk-window hunk) + (window-for-hunk hunk start modelinep)) + ;; If window is non-nil, then it is a new group/parent window, so don't + ;; link it into the current window's group. When ask-user is non-nil, + ;; we make a new group too. + (cond ((or window ask-user) + ;; This occurs when we make the world's first Hemlock window. + (unless *current-window* + (setq *current-window* (bitmap-hunk-window hunk))) + (setf (bitmap-hunk-previous hunk) hunk) + (setf (bitmap-hunk-next hunk) hunk)) + (t + (let ((h (window-hunk *current-window*))) + (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk) + (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk) + (setf (bitmap-hunk-previous hunk) h)))) + (push hunk (device-hunks device)) + (bitmap-hunk-window hunk))) + +;;; MAYBE-MAKE-X-WINDOW-AND-PARENT -- Internal. +;;; +;;; BITMAP-MAKE-WINDOW calls this. If xparent is non-nil, we clear it and +;;; return it with a child that fills it. If xparent is nil, and ask-user is +;;; non-nil, then we invoke *create-window-hook* to get a parent window and +;;; return it with a child that fills it. By default, we make a child in the +;;; CURRENT-WINDOW's parent. +;;; +#+clx +(defun maybe-make-x-window-and-parent (xparent display start ask-user x y width + height font-family modelinep thumb-p + proportion) + (let ((icon-name (buffer-name (line-buffer (mark-line start))))) + (cond (xparent + (check-type xparent xlib:window) + (let ((width (xlib:drawable-width xparent)) + (height (xlib:drawable-height xparent))) + (xlib:clear-area xparent :width width :height height) + (modify-parent-properties :set xparent modelinep thumb-p + (font-family-width font-family) + (font-family-height font-family)) + (values xparent (xwindow-for-xparent xparent icon-name)))) + (ask-user + (let ((xparent (funcall *create-window-hook* + display x y width height icon-name + font-family modelinep thumb-p))) + (values xparent (xwindow-for-xparent xparent icon-name)))) + (t + (let ((xparent (window-group-xparent + (bitmap-hunk-window-group + (window-hunk (current-window)))))) + (values xparent + (create-window-from-current + proportion font-family modelinep thumb-p xparent + icon-name))))))) + +;;; XWINDOW-FOR-XPARENT -- Internal. +;;; +;;; This returns a child of xparent that completely fills that parent window. +;;; We supply the font-width and font-height as nil because these are useless +;;; for child windows. +;;; +#+clx +(defun xwindow-for-xparent (xparent icon-name) + (xlib:with-state (xparent) + (create-window-with-properties xparent 0 0 + (xlib:drawable-width xparent) + (xlib:drawable-height xparent) + nil nil icon-name))) + +;;; CREATE-WINDOW-FROM-CURRENT -- Internal. +;;; +;;; This makes a child window on parent by splitting the current window. If +;;; the result will be too small, this returns nil. If the current window's +;;; height is odd, the extra pixel stays with it, and the new window is one +;;; pixel smaller. +;;; +#+clx +(defun create-window-from-current (proportion font-family modelinep thumb-p + parent icon-name) + (let* ((cur-hunk (window-hunk *current-window*)) + (cwin (bitmap-hunk-xwindow cur-hunk))) + ;; Compute current window's height and take a proportion of it. + (xlib:with-state (cwin) + (let* ((cw (xlib:drawable-width cwin)) + (ch (xlib:drawable-height cwin)) + (cy (xlib:drawable-y cwin)) + (new-ch (truncate (* ch (- 1 proportion)))) + (font-height (font-family-height font-family)) + (font-width (font-family-width font-family)) + (cwin-min (minimum-window-height + (font-family-height + (bitmap-hunk-font-family cur-hunk)) + (bitmap-hunk-modeline-pos cur-hunk) + (bitmap-hunk-thumb-bar-p cur-hunk))) + (new-min (minimum-window-height font-height modelinep + thumb-p))) + (declare (fixnum cw cy ch new-ch)) + ;; See if we have room for a new window. This should really + ;; check the current window and the new one against their + ;; relative fonts and the minimal window columns and line + ;; (including whether there is a modeline). + (if (and (> new-ch cwin-min) + (> (- ch new-ch) new-min)) + (let ((win (create-window-with-properties + parent 0 (+ cy new-ch) + cw (- ch new-ch) font-width font-height + icon-name))) + ;; No need to reshape current Hemlock window structure here + ;; since this call will send an appropriate event. + (setf (xlib:drawable-height cwin) new-ch) + ;; Set hints on parent, so the user can't resize it to be + ;; smaller than what will hold the current number of + ;; children. + (modify-parent-properties :add parent modelinep + thumb-p + (font-family-width font-family) + font-height) + win) + nil))))) + + +;;; MAKE-XWINDOW-LIKE-HWINDOW -- Interface. +;;; +;;; The window name is set to get around an awm and twm bug that inhibits menu +;;; clicks unless the window has a name; this could be used better. +;;; +#+clx +(defun make-xwindow-like-hwindow (window) + "This returns an group/parent xwindow with dimensions suitable for making a + Hemlock window like the argument window. The new window's position should + be the same as the argument window's position relative to the root. When + setting standard properties, we set x, y, width, and height to tell window + managers to put the window where we intend without querying the user." + (let* ((hunk (window-hunk window)) + (font-family (bitmap-hunk-font-family hunk)) + (xwin (bitmap-hunk-xwindow hunk))) + (multiple-value-bind (x y) + (window-root-xy xwin) + (create-window-with-properties + (xlib:screen-root (xlib:display-default-screen + (bitmap-device-display (device-hunk-device hunk)))) + x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk) + (font-family-width font-family) + (font-family-height font-family) + (buffer-name (window-buffer window)) + ;; When the user hands this window to MAKE-WINDOW, it will set the + ;; minimum width and height properties. + nil nil + t)))) + + + + +;;;; Deleting a window. + +;;; DEFAULT-DELETE-WINDOW-HOOK -- Internal. +;;; +#+clx +(defun default-delete-window-hook (xparent) + (xlib:destroy-window xparent)) +#-clx +(defun default-delete-window-hook (xparent) + (declare (ignore xparent))) +;;; +(defvar *delete-window-hook* #'default-delete-window-hook + "Hemlock calls this function to delete an X group/parent window. It passes + the X window as an argument.") + + +;;; BITMAP-DELETE-WINDOW -- Internal +;;; +;;; +#+clx +(defun bitmap-delete-window (window) + (let* ((hunk (window-hunk window)) + (xwindow (bitmap-hunk-xwindow hunk)) + (xparent (window-group-xparent (bitmap-hunk-window-group hunk))) + (display (bitmap-device-display (device-hunk-device hunk)))) + (remove-xwindow-object xwindow) + (setq *window-list* (delete window *window-list*)) + (when (eq *current-highlighted-border* hunk) + (setf *current-highlighted-border* nil)) + (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor)) + (xlib:display-force-output display) + (bitmap-delete-and-reclaim-window-space xwindow window) + (loop (unless (deleting-window-drop-event display xwindow) (return))) + (let ((device (device-hunk-device hunk))) + (setf (device-hunks device) (delete hunk (device-hunks device)))) + (cond ((eq hunk (bitmap-hunk-next hunk)) + ;; Is this the last window in the group? + (remove-xwindow-object xparent) + (xlib:display-force-output display) + (funcall *delete-window-hook* xparent) + (loop (unless (deleting-window-drop-event display xparent) + (return))) + (let ((window (find-if-not #'(lambda (window) + (eq window *echo-area-window*)) + *window-list*))) + (setf (current-buffer) (window-buffer window) + (current-window) window))) + (t + (modify-parent-properties :delete xparent + (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-thumb-bar-p hunk) + (font-family-width + (bitmap-hunk-font-family hunk)) + (font-family-height + (bitmap-hunk-font-family hunk))) + (let ((next (bitmap-hunk-next hunk)) + (prev (bitmap-hunk-previous hunk))) + (setf (bitmap-hunk-next prev) next) + (setf (bitmap-hunk-previous next) prev)))) + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))))) + nil) + +;;; BITMAP-DELETE-AND-RECLAIM-WINDOW-SPACE -- Internal. +;;; +;;; This destroys the X window after obtaining its necessary state information. +;;; If the previous or next window (in that order) is "stacked" over or under +;;; the target window, then it is grown to fill in the newly opened space. We +;;; fetch all the necessary configuration data up front, so we don't have to +;;; call XLIB:DESTROY-WINDOW while in the XLIB:WITH-STATE. +;;; +#+clx +(defun bitmap-delete-and-reclaim-window-space (xwindow hwindow) + (multiple-value-bind (y height) + (xlib:with-state (xwindow) + (values (xlib:drawable-y xwindow) + (xlib:drawable-height xwindow))) + (xlib:destroy-window xwindow) + (let ((hunk (window-hunk hwindow))) + (xlib:free-gcontext (bitmap-hunk-gcontext hunk)) + (unless (eq hunk (bitmap-hunk-next hunk)) + (unless (maybe-merge-with-previous-window hunk y height) + (merge-with-next-window hunk y height)))))) + +;;; MAYBE-MERGE-WITH-PREVIOUS-WINDOW -- Internal. +;;; +;;; This returns non-nil when it grows the previous hunk to include the +;;; argument hunk's screen space. +;;; +#+clx +(defun maybe-merge-with-previous-window (hunk y h) + (declare (fixnum y h)) + (let* ((prev (bitmap-hunk-previous hunk)) + (prev-xwin (bitmap-hunk-xwindow prev))) + (xlib:with-state (prev-xwin) + (if (< (xlib:drawable-y prev-xwin) y) + (incf (xlib:drawable-height prev-xwin) h))))) + +;;; MERGE-WITH-NEXT-WINDOW -- Internal. +;;; +;;; This trys to grow the next hunk's window to make use of the space created +;;; by deleting hunk's window. If this is possible, then we must also move the +;;; next window up to where hunk's window was. +;;; +;;; When we reconfigure the window, we must set the hunk trashed. This is a +;;; hack since twm is broken again and is sending exposure events before +;;; reconfigure notifications. Hemlock relies on the protocol's statement that +;;; reconfigures come before exposures to set the hunk trashed before getting +;;; the exposure. For now, we'll do it here too. +;;; +#+clx +(defun merge-with-next-window (hunk y h) + (declare (fixnum y h)) + (let* ((next (bitmap-hunk-next hunk)) + (next-xwin (bitmap-hunk-xwindow next))) + ;; Fetch height before setting y to save an extra round trip to the X + ;; server. + (let ((next-h (xlib:drawable-height next-xwin))) + (setf (xlib:drawable-y next-xwin) y) + (setf (xlib:drawable-height next-xwin) (+ next-h h))) + (setf (bitmap-hunk-trashed next) t) + (let ((hints (xlib:wm-normal-hints next-xwin))) + (setf (xlib:wm-size-hints-y hints) y) + (setf (xlib:wm-normal-hints next-xwin) hints)))) + + +;;; DELETING-WINDOW-DROP-EVENT -- Internal. +;;; +;;; This checks for any events on win. If there is one, remove it from the +;;; queue and return t. Otherwise, return nil. +;;; +#+clx +(defun deleting-window-drop-event (display win) + (xlib:display-finish-output display) + (let ((result nil)) + (xlib:process-event + display :timeout 0 + :handler #'(lambda (&key event-window window &allow-other-keys) + (if (or (eq event-window win) (eq window win)) + (setf result t) + nil))) + result)) + + +;;; MODIFY-PARENT-PROPERTIES -- Internal. +;;; +;;; This adds or deletes from xparent's min-height and min-width hints, so the +;;; window manager will hopefully prevent users from making a window group too +;;; small to hold all the windows in it. We add to the height when we split +;;; windows making additional ones, and we delete from it when we delete a +;;; window. +;;; +;;; NOTE, THIS FAILS TO MAINTAIN THE WIDTH CORRECTLY. We need to maintain the +;;; width as the MAX of all the windows' minimal widths. A window's minimal +;;; width is its font's width multiplied by minimum-window-columns. +;;; +#+clx +(defun modify-parent-properties (type xparent modelinep thumb-p + font-width font-height) + (let ((hints (xlib:wm-normal-hints xparent))) + (xlib:set-wm-properties + xparent + :resource-name "Hemlock" + :x (xlib:wm-size-hints-x hints) + :y (xlib:wm-size-hints-y hints) + :width (xlib:drawable-width xparent) + :height (xlib:drawable-height xparent) + :user-specified-position-p t + :user-specified-size-p t + :width-inc (xlib:wm-size-hints-width-inc hints) + :height-inc (xlib:wm-size-hints-height-inc hints) + :min-width (or (xlib:wm-size-hints-min-width hints) + (+ (* minimum-window-columns font-width) hunk-left-border)) + :min-height + (let ((delta (minimum-window-height font-height modelinep thumb-p))) + (ecase type + (:delete (- (xlib:wm-size-hints-min-height hints) delta)) + (:add (+ (or (xlib:wm-size-hints-min-height hints) 0) + delta)) + (:set delta)))))) + +;;; MINIMUM-WINDOW-HEIGHT -- Internal. +;;; +;;; This returns the minimum height necessary for a window given some of its +;;; parameters. This is the number of lines times font-height plus any extra +;;; pixels for aesthetics. +;;; +(defun minimum-window-height (font-height modelinep thumb-p) + (if modelinep + (+ (* (1+ minimum-window-lines) font-height) + (surplus-window-height-w/-modeline thumb-p)) + (+ (* minimum-window-lines font-height) + (surplus-window-height thumb-p)))) + + + + +;;;; Next and Previous windows. + +(defun bitmap-next-window (window) + "Return the next window after Window, wrapping around if Window is the + bottom window." + (check-type window window) + (bitmap-hunk-window (bitmap-hunk-next (window-hunk window)))) + +(defun bitmap-previous-window (window) + "Return the previous window after Window, wrapping around if Window is the + top window." + (check-type window window) + (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window)))) + + + + +;;;; Setting window width and height. + +;;; %SET-WINDOW-WIDTH -- Internal +;;; +;;; Since we don't support non-full-width windows, this does nothing. +;;; +(defun %set-window-width (window new-value) + (declare (ignore window)) + new-value) + +;;; %SET-WINDOW-HEIGHT -- Internal +;;; +;;; Can't change window height either. +;;; +(defun %set-window-height (window new-value) + (declare (ignore window)) + new-value) + + + + +;;;; Random Typeout + +;;; Random typeout is done to a bitmap-hunk-output-stream +;;; (Bitmap-Hunk-Stream.Lisp). These streams have an associated hunk +;;; that is used for its font-family, foreground and background color, +;;; and X window pointer. The hunk is not associated with any Hemlock +;;; window, and the low level painting routines that use hunk dimensions +;;; are not used for output. The X window is resized as necessary with +;;; each use, but the hunk is only registered for input and boundary +;;; crossing event service; therefore, it never gets exposure or changed +;;; notifications. + +;;; These are set in INIT-BITMAP-SCREEN-MANAGER. +;;; +(defvar *random-typeout-start-x* 0 + "Where we put the the random typeout window.") +(defvar *random-typeout-start-y* 0 + "Where we put the the random typeout window.") +(defvar *random-typeout-start-width* 0 + "How wide the random typeout window is.") + + +;;; DEFAULT-RANDOM-TYPEOUT-HOOK -- Internal +;;; +;;; The default hook-function for random typeout. Nothing very fancy +;;; for now. If not given a window, makes one on top of the initial +;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER. If +;;; given a window, we will change the height subject to the constraint +;;; that the bottom won't be off the screen. Any resulting window has +;;; input and boundary crossing events selected, a hemlock cursor defined, +;;; and is mapped. +;;; +#+clx +(defun default-random-typeout-hook (device window height) + (declare (fixnum height)) + (let* ((display (bitmap-device-display device)) + (root (xlib:screen-root (xlib:display-default-screen display))) + (full-height (xlib:drawable-height root)) + (actual-height (if window + (multiple-value-bind (x y) (window-root-xy window) + (declare (ignore x) (fixnum y)) + (min (- full-height y xwindow-border-width*2) + height)) + (min (- full-height *random-typeout-start-y* + xwindow-border-width*2) + height))) + (win (cond (window + (setf (xlib:drawable-height window) actual-height) + window) + (t + (let ((win (xlib:create-window + :parent root + :x *random-typeout-start-x* + :y *random-typeout-start-y* + :width *random-typeout-start-width* + :height actual-height + :background *default-background-pixel* + :border-width xwindow-border-width + :border *default-border-pixmap* + :event-mask random-typeout-xevents-mask + :override-redirect :on :class :input-output + :cursor *hemlock-cursor*))) + (xlib:set-wm-properties + win :name "Pop-up Display" :icon-name "Pop-up Display" + :resource-name "Hemlock" + :x *random-typeout-start-x* + :y *random-typeout-start-y* + :width *random-typeout-start-width* + :height actual-height + :user-specified-position-p t :user-specified-size-p t + ;; Tell OpenLook pseudo-X11 server we want input. + :input :on) + win)))) + (gcontext (if (not window) (default-gcontext win)))) + (values win gcontext))) + +#-clx +(defun default-random-typeout-hook (device window height) + (declare (ignore device window height))) + +(defvar *random-typeout-hook* #'default-random-typeout-hook + "This function is called when a window is needed to display random typeout. + It is called with the Hemlock device, a pre-existing window or NIL, and the + number of pixels needed to display the number of lines requested in + WITH-RANDOM-TYPEOUT. It should return a window, and if a new window was + created, then a gcontext must be returned as the second value.") + +;;; BITMAP-RANDOM-TYPEOUT-SETUP -- Internal +;;; +;;; This function is called by the with-random-typeout macro to +;;; to set things up. It calls the *Random-Typeout-Hook* to get a window +;;; to work with, and then adjusts the random typeout stream's data-structures +;;; to match. +;;; +#+clx +(defun bitmap-random-typeout-setup (device stream height) + (let* ((*more-prompt-action* :empty) + (hwin-exists-p (random-typeout-stream-window stream)) + (hwindow (if hwin-exists-p + (change-bitmap-random-typeout-window hwin-exists-p height) + (setf (random-typeout-stream-window stream) + (make-bitmap-random-typeout-window + device + (buffer-start-mark + (line-buffer + (mark-line (random-typeout-stream-mark stream)))) + height))))) + (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow))) + (display (bitmap-device-display device))) + (xlib:display-finish-output display) + (loop + (unless (xlib:event-case (display :timeout 0) + (:exposure (event-window) + (eq event-window xwindow)) + (t () nil)) + (return)))))) + +#+clx +(defun change-bitmap-random-typeout-window (hwindow height) + (update-modeline-field (window-buffer hwindow) hwindow :more-prompt) + (let* ((hunk (window-hunk hwindow)) + (xwin (bitmap-hunk-xwindow hunk))) + ;; + ;; *random-typeout-hook* sets the window's height to the right value. + (funcall *random-typeout-hook* (device-hunk-device hunk) xwin + (+ (* height (font-family-height (bitmap-hunk-font-family hunk))) + hunk-top-border (bitmap-hunk-bottom-border hunk) + hunk-modeline-top hunk-modeline-bottom)) + (xlib:with-state (xwin) + (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin) + nil)) + ;; + ;; We push this on here because we took it out the last time we cleaned up. + (push hwindow (buffer-windows (window-buffer hwindow))) + (setf (bitmap-hunk-trashed hunk) t) + (xlib:map-window xwin) + (setf (xlib:window-priority xwin) :above)) + hwindow) + +#+clx +(defun make-bitmap-random-typeout-window (device mark height) + (let* ((display (bitmap-device-display device)) + (hunk (make-bitmap-hunk + :font-family *default-font-family* + :end *the-sentinel* :trashed t + :input-handler #'window-input-handler + :device device :thumb-bar-p nil))) + (multiple-value-bind + (xwindow gcontext) + (funcall *random-typeout-hook* + device (bitmap-hunk-xwindow hunk) + (+ (* height (font-family-height *default-font-family*)) + hunk-top-border (bitmap-hunk-bottom-border hunk) + hunk-modeline-top hunk-modeline-bottom)) + ;; + ;; When gcontext, we just made the window, so tie some stuff together. + (when gcontext + (setf (xlib:gcontext-font gcontext) + (svref (font-family-map *default-font-family*) 0)) + (setf (bitmap-hunk-xwindow hunk) xwindow) + (setf (bitmap-hunk-gcontext hunk) gcontext) + ;; + ;; Select input and enable event service before showing the window. + (setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask) + (add-xwindow-object xwindow hunk *hemlock-windows*)) + ;; + ;; Put the window on the screen so it's visible and we can know the size. + (xlib:map-window xwindow) + (xlib:display-finish-output display) + ;; A window is not really mapped until it is viewable (not visible). + ;; It is said to be mapped if a map request has been sent whether it + ;; is handled or not. + (loop (when (eq (xlib:window-map-state xwindow) :viewable) + (return))) + (xlib:with-state (xwindow) + (set-hunk-size hunk (xlib:drawable-width xwindow) + (xlib:drawable-height xwindow) t)) + ;; + ;; Get a Hemlock window and hide it from the rest of Hemlock. + (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*))) + (update-modeline-field (window-buffer hwin) hwin :more-prompt) + (setf (bitmap-hunk-window hunk) hwin) + (setf *window-list* (delete hwin *window-list*)) + hwin)))) + + +;;; RANDOM-TYPEOUT-CLEANUP -- Internal +;;; +;;; Clean up after random typeout. This just removes the window from +;;; the screen and sets the more-prompt action back to normal. +;;; +#+clx +(defun bitmap-random-typeout-cleanup (stream degree) + (when degree + (xlib:unmap-window (bitmap-hunk-xwindow + (window-hunk (random-typeout-stream-window stream)))))) + + + + +;;;; Initialization. + +;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and +;;; echo. The main window is made according to "Default Initial Window X", +;;; "Default Initial Window Y", "Default Initial Window Width", and "Default +;;; Initial Window Height", prompting the user for any unspecified components. +;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and +;;; size of the echo area including how big its font is, and the main xwindow +;;; is potentially modified by this function. The window name is set to get +;;; around an awm and twm bug that inhibits menu clicks unless the window has a +;;; name; this could be used better. +;;; +#+clx +(defun default-create-initial-windows-hook (device) + (let ((root (xlib:screen-root (xlib:display-default-screen + (bitmap-device-display device))))) + (let* ((xwindow (maybe-prompt-user-for-window + root + (value hemlock::default-initial-window-x) + (value hemlock::default-initial-window-y) + (value hemlock::default-initial-window-width) + (value hemlock::default-initial-window-height) + *default-font-family* + t ;modelinep + (value hemlock::thumb-bar-meter) + "Hemlock"))) + (setf (xlib:window-border xwindow) *highlight-border-pixmap*) + (let ((main-win (make-window (buffer-start-mark *current-buffer*) + :device device + :window xwindow))) + (multiple-value-bind + (echo-x echo-y echo-width echo-height) + (default-create-initial-windows-echo + (xlib:drawable-height root) + (window-hunk main-win)) + (let ((echo-xwin (make-echo-xwindow root echo-x echo-y echo-width + echo-height))) + (setf *echo-area-window* + (hlet ((hemlock::thumb-bar-meter nil)) + (make-window + (buffer-start-mark *echo-area-buffer*) + :device device :modelinep t + :window echo-xwin))))) + (setf *current-window* main-win))))) + +#-clx +(defun default-create-initial-windows-hook (device) + (declare (ignore device))) + +;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as +;;; the main window and places it directly under it. If the echo area does not +;;; fit on the screen, we change the main window to make it fit. There is +;;; a problem in computing main-xwin's x and y relative to the root window +;;; which is where we line up the echo and main windows. Some losing window +;;; managers (awm and twm) reparent the window, so we have to make sure +;;; main-xwin's x and y are relative to the root and not some false parent. +;;; +#+clx +(defun default-create-initial-windows-echo (full-height hunk) + (declare (fixnum full-height)) + (let ((font-family (bitmap-hunk-font-family hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (xparent (window-group-xparent (bitmap-hunk-window-group hunk)))) + (xlib:with-state (xwindow) + (let ((w (xlib:drawable-width xwindow)) + (h (xlib:drawable-height xwindow))) + (declare (fixnum w h)) + (multiple-value-bind (x y) + (window-root-xy xwindow + (xlib:drawable-x xwindow) + (xlib:drawable-y xwindow)) + (declare (fixnum x y)) + (let* ((ff-height (font-family-height font-family)) + (ff-width (font-family-width font-family)) + (echo-height (+ (* ff-height 4) + hunk-top-border hunk-bottom-border + hunk-modeline-top hunk-modeline-bottom))) + (declare (fixnum echo-height)) + (if (<= (+ y h echo-height xwindow-border-width*2) full-height) + (values x (+ y h xwindow-border-width*2) + w echo-height ff-width ff-height) + (let* ((newh (- full-height y echo-height xwindow-border-width*2 + ;; Since y is really the outside y, subtract + ;; two more borders, so the echo area's borders + ;; both appear on the screen. + xwindow-border-width*2))) + (setf (xlib:drawable-height xparent) newh) + (values x (+ y newh xwindow-border-width*2) + w echo-height ff-width ff-height))))))))) + +(defvar *create-initial-windows-hook* #'default-create-initial-windows-hook + "Hemlock uses this function when it initializes the screen manager to make + the first windows, typically the main and echo area windows. It takes a + Hemlock device as a required argument. It sets *current-window* and + *echo-area-window*.") + +(defun make-echo-xwindow (root x y width height) + (let* ((font-width (font-family-width *default-font-family*)) + (font-height (font-family-height *default-font-family*))) + (create-window-with-properties root x y width height + font-width font-height + "Echo Area" nil nil t))) + +#+clx +(defun init-bitmap-screen-manager (display) + ;; + ;; Setup stuff for X interaction. + (cond ((value hemlock::reverse-video) + (setf *default-background-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-black-color)) + (setf *cursor-foreground-color* (make-white-color)) + (setf *hack-hunk-replace-line* nil)) + (t (setf *default-background-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-white-color)) + (setf *cursor-foreground-color* (make-black-color)))) + (setf *foreground-background-xor* + (logxor *default-foreground-pixel* *default-background-pixel*)) + (setf *highlight-border-pixmap* *default-foreground-pixel*) + (setf *default-border-pixmap* (get-hemlock-grey-pixmap display)) + (get-hemlock-cursor display) + (add-hook hemlock::make-window-hook 'define-window-cursor) + ;; + ;; Make the device for the rest of initialization. + (let ((device (make-default-bitmap-device display))) + ;; + ;; Create initial windows. + (funcall *create-initial-windows-hook* device) + ;; + ;; Setup random typeout over the user's main window. + (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*)))) + (xlib:with-state (xwindow) + (multiple-value-bind (x y) + (window-root-xy xwindow (xlib:drawable-x xwindow) + (xlib:drawable-y xwindow)) + (setf *random-typeout-start-x* x) + (setf *random-typeout-start-y* y)) + (setf *random-typeout-start-width* (xlib:drawable-width xwindow))))) + (add-hook hemlock::window-buffer-hook 'set-window-name-for-window-buffer) + (add-hook hemlock::buffer-name-hook 'set-window-name-for-buffer-name) + (add-hook hemlock::set-window-hook 'set-window-hook-raise-fun) + (add-hook hemlock::buffer-modified-hook 'raise-echo-area-when-modified)) + +(defun make-default-bitmap-device (display) + (make-bitmap-device + :name "Windowed Bitmap Device" + :init #'init-bitmap-device + :exit #'exit-bitmap-device + :smart-redisplay #'smart-window-redisplay + :dumb-redisplay #'dumb-window-redisplay + :after-redisplay #'bitmap-after-redisplay + :clear nil + :note-read-wait #'frob-cursor + :put-cursor #'hunk-show-cursor + :show-mark #'bitmap-show-mark + :next-window #'bitmap-next-window + :previous-window #'bitmap-previous-window + :make-window #'bitmap-make-window + :delete-window #'bitmap-delete-window + :force-output #'bitmap-force-output + :finish-output #'bitmap-finish-output + :random-typeout-setup #'bitmap-random-typeout-setup + :random-typeout-cleanup #'bitmap-random-typeout-cleanup + :random-typeout-full-more #'do-bitmap-full-more + :random-typeout-line-more #'update-bitmap-line-buffered-stream + :beep #'bitmap-beep + :display display)) + +(defun init-bitmap-device (device) + (let ((display (bitmap-device-display device))) + (hemlock-ext:flush-display-events display) + (hemlock-window display t))) + +(defun exit-bitmap-device (device) + (hemlock-window (bitmap-device-display device) nil)) + +#+clx +(defun bitmap-finish-output (device window) + (declare (ignore window)) + (xlib:display-finish-output (bitmap-device-display device))) + +#+clx +(defun bitmap-force-output () + (xlib:display-force-output + (bitmap-device-display (device-hunk-device (window-hunk (current-window)))))) + +(defun bitmap-after-redisplay (device) + (let ((display (bitmap-device-display device))) + (loop (unless (hemlock-ext:object-set-event-handler display) (return))))) + + + + +;;;; Miscellaneous. + +;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date. +;;; If the size is wrong, or it is trashed due to font changes, then we +;;; call HUNK-CHANGED. We also clear the hunk. +;;; +#+clx +(defun hunk-reset (hunk) + (let ((xwindow (bitmap-hunk-xwindow hunk)) + (trashed (bitmap-hunk-trashed hunk))) + (when trashed + (setf (bitmap-hunk-trashed hunk) nil) + (xlib:with-state (xwindow) + (let ((w (xlib:drawable-width xwindow)) + (h (xlib:drawable-height xwindow))) + (when (or (/= w (bitmap-hunk-width hunk)) + (/= h (bitmap-hunk-height hunk)) + (eq trashed :font-change)) + (hunk-changed hunk w h nil))))) + (xlib:clear-area xwindow :width (bitmap-hunk-width hunk) + :height (bitmap-hunk-height hunk)) + (hunk-draw-bottom-border hunk))) + +;;; HUNK-CHANGED -- Internal. +;;; +;;; HUNK-RESET and the changed window handler call this. Don't go through +;;; REDISPLAY-WINDOW-ALL since the window changed handler updates the window +;;; image. +;;; +(defun hunk-changed (hunk new-width new-height redisplay) + (set-hunk-size hunk new-width new-height) + (funcall (bitmap-hunk-changed-handler hunk) hunk) + (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk)))) + +;;; WINDOW-GROUP-CHANGED -- Internal. +;;; +;;; HUNK-RECONFIGURED calls this when the hunk was a window-group. This finds +;;; the windows in the changed group, sorts them by their vertical stacking +;;; order, and tries to resize the windows proportioned by their old sizes +;;; relative to the old group size. If that fails, this tries to make all the +;;; windows the same size, dividing up the new group's size. +;;; +#+clx +(defun window-group-changed (window-group new-width new-height) + (let ((xparent (window-group-xparent window-group)) + (affected-windows nil) + (count 0) + (old-xparent-height (window-group-height window-group))) + (setf (window-group-width window-group) new-width) + (setf (window-group-height window-group) new-height) + (dolist (window *window-list*) + (let ((test (window-group-xparent (bitmap-hunk-window-group + (window-hunk window))))) + (when (eq test xparent) + (push window affected-windows) + (incf count)))) + ;; Probably shoulds insertion sort them, but I'm lame. + ;; + (xlib:with-state (xparent) + (sort affected-windows #'< + :key #'(lambda (window) + (xlib:drawable-y + (bitmap-hunk-xwindow (window-hunk window)))))) + (let ((start 0)) + (declare (fixnum start)) + (do ((windows affected-windows (cdr windows))) + ((endp windows)) + (let* ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows)))) + (new-child-height (round + (* new-height + (/ (xlib:drawable-height xwindow) + old-xparent-height)))) + (hunk (window-hunk (car windows)))) + ;; If there is not enough room for one of the windows, space them out + ;; evenly so there will be room. + ;; + (when (< new-child-height (minimum-window-height + (font-family-height + (bitmap-hunk-font-family hunk)) + (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-thumb-bar-p hunk))) + (reconfigure-windows-evenly affected-windows new-width new-height) + (return)) + (xlib:with-state (xwindow) + (setf (xlib:drawable-y xwindow) start + ;; Make the last window absorb or lose the number of pixels + ;; lost in rounding. + ;; + (xlib:drawable-height xwindow) (if (cdr windows) + new-child-height + (- new-height start)) + (xlib:drawable-width xwindow) new-width + start (+ start new-child-height 1)))))))) + +#+clx +(defun reconfigure-windows-evenly (affected-windows new-width new-height) + (let ((count (length affected-windows))) + (multiple-value-bind + (pixels-per-window remainder) + (truncate new-height count) + (let ((count-1 (1- count))) + (do ((windows affected-windows (cdr windows)) + (i 0 (1+ i))) + ((endp windows)) + (let ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows))))) + (setf (xlib:drawable-y xwindow) (* i pixels-per-window)) + (setf (xlib:drawable-width xwindow) new-width) + (if (= i count-1) + (return (setf (xlib:drawable-height + (bitmap-hunk-xwindow + (window-hunk (car windows)))) + (+ pixels-per-window remainder))) + (setf (xlib:drawable-height xwindow) pixels-per-window)))))))) + +;;; SET-HUNK-SIZE -- Internal +;;; +;;; Given a pixel size for a bitmap hunk, set the char size. If the window +;;; is too small, we refuse to admit it; if the user makes unreasonably small +;;; windows, our only responsibity is to not blow up. X will clip any stuff +;;; that doesn't fit. +;;; +(defun set-hunk-size (hunk w h &optional modelinep) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (font-width (font-family-width font-family)) + (font-height (font-family-height font-family))) + (setf (bitmap-hunk-height hunk) h) + (setf (bitmap-hunk-width hunk) w) + (setf (bitmap-hunk-char-width hunk) + (max (truncate (- w hunk-left-border) font-width) + minimum-window-columns)) + (let* ((h-minus-borders (- h hunk-top-border + (bitmap-hunk-bottom-border hunk))) + (hwin (bitmap-hunk-window hunk)) + (modelinep (or modelinep (and hwin (window-modeline-buffer hwin))))) + (setf (bitmap-hunk-char-height hunk) + (max (if modelinep + (1- (truncate (- h-minus-borders + hunk-modeline-top hunk-modeline-bottom) + font-height)) + (truncate h-minus-borders font-height)) + minimum-window-lines)) + (setf (bitmap-hunk-modeline-pos hunk) + (if modelinep (- h font-height + hunk-modeline-top hunk-modeline-bottom)))))) + +;;; BITMAP-HUNK-BOTTOM-BORDER -- Internal. +;;; +(defun bitmap-hunk-bottom-border (hunk) + (if (bitmap-hunk-thumb-bar-p hunk) + hunk-thumb-bar-bottom-border + hunk-bottom-border)) + + +;;; DEFAULT-GCONTEXT is used when making hunks. +;;; +#+clx +(defun default-gcontext (drawable &optional font-family) + (xlib:create-gcontext + :drawable drawable + :foreground *default-foreground-pixel* + :background *default-background-pixel* + :font (if font-family (svref (font-family-map font-family) 0)))) + + +;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to +;;; its root. Some window managers reparent Hemlock's window, so we have +;;; to mess around possibly to get this right. If x and y are supplied, they +;;; are relative to xwin's parent. +;;; +#+clx +(defun window-root-xy (xwin &optional x y) + (multiple-value-bind (children parent root) + (xlib:query-tree xwin) + (declare (ignore children)) + (if (eq parent root) + (if (and x y) + (values x y) + (xlib:with-state (xwin) + (values (xlib:drawable-x xwin) (xlib:drawable-y xwin)))) + (multiple-value-bind + (tx ty) + (if (and x y) + (xlib:translate-coordinates parent x y root) + (xlib:with-state (xwin) + (xlib:translate-coordinates + parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root))) + (values (- tx xwindow-border-width) + (- ty xwindow-border-width)))))) + +;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent. X, y, w, and +;;; h are possibly nil, so we supply zero in this case. This would be used +;;; for prompting the user. Some standard properties are set to keep window +;;; managers in line. We name all windows because awm and twm window managers +;;; refuse to honor menu clicks over windows without names. Min-width and +;;; min-height are optional and only used for prompting the user for a window. +;;; +#+clx +(defun create-window-with-properties (parent x y w h font-width font-height + icon-name + &optional min-width min-height + window-group-p) + (let* ((win (xlib:create-window + :parent parent :x (or x 0) :y (or y 0) + :width (or w 0) :height (or h 0) + :background (if window-group-p :none *default-background-pixel*) + :border-width (if window-group-p xwindow-border-width 0) + :border (if window-group-p *default-border-pixmap* nil) + :class :input-output))) + (xlib:set-wm-properties + win :name (new-hemlock-window-name) :icon-name icon-name + :resource-name "Hemlock" + :x x :y y :width w :height h + :user-specified-position-p t :user-specified-size-p t + :width-inc font-width :height-inc font-height + :min-width min-width :min-height min-height + ;; Tell OpenLook pseudo-X11 server we want input. + :input :on) + win)) + + +;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by +;;; "Set Window Autoraise". When autoraising, check that it isn't only the +;;; echo area window that we autoraise; if it is only the echo area window, +;;; then see if window is the echo area window. +;;; +#+clx +(defun set-window-hook-raise-fun (window) + (let ((auto (value hemlock::set-window-autoraise))) + (when (and auto + (or (not (eq auto :echo-only)) + (eq window *echo-area-window*))) + (let* ((hunk (window-hunk window)) + (win (window-group-xparent (bitmap-hunk-window-group hunk)))) + (xlib:map-window win) + (setf (xlib:window-priority win) :above) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device hunk))))))) + + +;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set. +;;; If we are running on a windowed bitmap, we first setup the default +;;; foregrounds and backgrounds. Having done that, we get a new cursor. Then +;;; we do over all the hunks, updating their graphics contexts, cursors, and +;;; backgrounds. The current window's border is given the new highlight pixmap. +;;; Lastly, we update the random typeout hunk and redisplay everything. +;;; + +#+clx +(defun reverse-video-hook-fun (name kind where new-value) + (declare (ignore name kind where)) + (when (windowed-monitor-p) + (let* ((current-window (current-window)) + (current-hunk (window-hunk current-window)) + (device (device-hunk-device current-hunk)) + (display (bitmap-device-display device))) + (cond + (new-value + (setf *default-background-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-black-color)) + (setf *cursor-foreground-color* (make-white-color)) + (setf *hack-hunk-replace-line* nil)) + (t (setf *default-background-pixel* + (xlib:screen-white-pixel (xlib:display-default-screen display))) + (setf *default-foreground-pixel* + (xlib:screen-black-pixel (xlib:display-default-screen display))) + (setf *cursor-background-color* (make-white-color)) + (setf *cursor-foreground-color* (make-black-color)))) + (setf *highlight-border-pixmap* *default-foreground-pixel*) + (get-hemlock-cursor display) + (dolist (hunk (device-hunks device)) + (reverse-video-frob-hunk hunk)) + (dolist (rt-info *random-typeout-buffers*) + (reverse-video-frob-hunk + (window-hunk (random-typeout-stream-window (cdr rt-info))))) + (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk)) + *highlight-border-pixmap*)) + (redisplay-all))) + +#-clx +(defun reverse-video-hook-fun (name kind where new-value) + (declare (ignore name kind where new-value))) + +#+clx +(defun reverse-video-frob-hunk (hunk) + (let ((gcontext (bitmap-hunk-gcontext hunk))) + (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*) + (setf (xlib:gcontext-background gcontext) *default-background-pixel*)) + (let ((xwin (bitmap-hunk-xwindow hunk))) + (setf (xlib:window-cursor xwin) *hemlock-cursor*) + (setf (xlib:window-background xwin) *default-background-pixel*))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bufed.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bufed.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/bufed.lisp (revision 8058) @@ -0,0 +1,301 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains Bufed (Buffer Editing) code. +;;; + +(in-package :hemlock) + + + + +;;;; Representation of existing buffers. + +;;; This is the array of buffers in the bufed buffer. Each element is a cons, +;;; where the CAR is the buffer, and the CDR indicates whether the buffer +;;; should be deleted (t deleted, nil don't). +;;; +(defvar *bufed-buffers* nil) +(defvar *bufed-buffers-end* nil) +;;; +(defmacro bufed-buffer (x) `(car ,x)) +(defmacro bufed-buffer-deleted (x) `(cdr ,x)) +(defmacro make-bufed-buffer (buffer) `(list ,buffer)) + + +;;; This is the bufed buffer if it exists. +;;; +(defvar *bufed-buffer* nil) + +;;; This is the cleanup method for deleting *bufed-buffer*. +;;; +(defun delete-bufed-buffers (buffer) + (when (eq buffer *bufed-buffer*) + (setf *bufed-buffer* nil) + (setf *bufed-buffers* nil))) + + + + +;;;; Commands. + +(defmode "Bufed" :major-p t + :documentation + "Bufed allows the user to quickly save, goto, delete, etc., his buffers.") + +(defhvar "Virtual Buffer Deletion" + "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately + deleting it." + :value t) + +(defhvar "Bufed Delete Confirm" + "When set, \"Bufed\" commands that actually delete buffers ask for + confirmation before taking action." + :value t) + +(defcommand "Bufed Delete" (p) + "Delete the buffer. + Any windows displaying this buffer will display some other buffer." + "Delete the buffer indicated by the current line. Any windows displaying this + buffer will display some other buffer." + (declare (ignore p)) + (let* ((point (current-point)) + (buf-info (array-element-from-mark point *bufed-buffers*))) + (if (and (not (value virtual-buffer-deletion)) + (or (not (value bufed-delete-confirm)) + (prompt-for-y-or-n :prompt "Delete buffer? " :default t + :must-exist t :default-string "Y"))) + (delete-bufed-buffer (bufed-buffer buf-info)) + (with-writable-buffer (*bufed-buffer*) + (setf (bufed-buffer-deleted buf-info) t) + (with-mark ((point point)) + (setf (next-character (line-start point)) #\D)))))) + +(defcommand "Bufed Undelete" (p) + "Undelete the buffer. + Any windows displaying this buffer will display some other buffer." + "Undelete the buffer. Any windows displaying this buffer will display some + other buffer." + (declare (ignore p)) + (with-writable-buffer (*bufed-buffer*) + (setf (bufed-buffer-deleted (array-element-from-mark + (current-point) *bufed-buffers*)) + nil) + (with-mark ((point (current-point))) + (setf (next-character (line-start point)) #\space)))) + +(defcommand "Bufed Expunge" (p) + "Expunge buffers marked for deletion." + "Expunge buffers marked for deletion." + (declare (ignore p)) + (expunge-bufed-buffers)) + +(defcommand "Bufed Quit" (p) + "Kill the bufed buffer, expunging any buffer marked for deletion." + "Kill the bufed buffer, expunging any buffer marked for deletion." + (declare (ignore p)) + (expunge-bufed-buffers) + (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))) + +;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer, +;;; signalling an error if the current buffer is not the bufed buffer. This +;;; returns t if it deletes some buffer, otherwise nil. We build a list of +;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements +;;; around in *bufed-buffers*. +;;; +(defun expunge-bufed-buffers () + (unless (eq *bufed-buffer* (current-buffer)) + (editor-error "Not in the Bufed buffer.")) + (let (buffers) + (dotimes (i *bufed-buffers-end*) + (let ((buf-info (svref *bufed-buffers* i))) + (when (bufed-buffer-deleted buf-info) + (push (bufed-buffer buf-info) buffers)))) + (if (and buffers + (or (not (value bufed-delete-confirm)) + (prompt-for-y-or-n :prompt "Delete buffers? " :default t + :must-exist t :default-string "Y"))) + (dolist (b buffers t) (delete-bufed-buffer b))))) + +(defun delete-bufed-buffer (buf) + (when (and (buffer-modified buf) + (prompt-for-y-or-n :prompt (list "~A is modified. Save it first? " + (buffer-name buf)))) + (save-file-command nil buf)) + (delete-buffer-if-possible buf)) + + +(defcommand "Bufed Goto" (p) + "Change to the buffer." + "Change to the buffer." + (declare (ignore p)) + (change-to-buffer + (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*)))) + +(defcommand "Bufed Goto and Quit" (p) + "Change to the buffer quitting Bufed. + This supplies a function for \"Generic Pointer Up\" which is a no-op." + "Change to the buffer quitting Bufed." + (declare (ignore p)) + (expunge-bufed-buffers) + (point-to-here-command nil) + (change-to-buffer + (bufed-buffer (array-element-from-pointer-pos *bufed-buffers* + "No buffer on that line."))) + (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)) + (supply-generic-pointer-up-function #'(lambda () nil))) + +(defcommand "Bufed Save File" (p) + "Save the buffer." + "Save the buffer." + (declare (ignore p)) + (save-file-command + nil + (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*)))) + +(defcommand "Bufed" (p) + "Creates a list of buffers in a buffer supporting operations such as deletion + and selection. If there already is a bufed buffer, just go to it." + "Creates a list of buffers in a buffer supporting operations such as deletion + and selection. If there already is a bufed buffer, just go to it." + (declare (ignore p)) + (let ((buf (or *bufed-buffer* + (make-buffer "Bufed" :modes '("Bufed") + :delete-hook (list #'delete-bufed-buffers))))) + + (unless *bufed-buffer* + (setf *bufed-buffer* buf) + (setf *bufed-buffers-end* + ;; -1 echo, -1 bufed. + (- (length (the list *buffer-list*)) 2)) + (setf *bufed-buffers* (make-array *bufed-buffers-end*)) + (setf (buffer-writable buf) t) + (with-output-to-mark (s (buffer-point buf)) + (let ((i 0)) + (do-strings (n b *buffer-names*) + (declare (simple-string n)) + (unless (or (eq b *echo-area-buffer*) + (eq b buf)) + (bufed-write-line b n s) + (setf (svref *bufed-buffers* i) (make-bufed-buffer b)) + (incf i))))) + (setf (buffer-writable buf) nil) + (setf (buffer-modified buf) nil) + (let ((fields (buffer-modeline-fields *bufed-buffer*))) + (setf (cdr (last fields)) + (list (or (modeline-field :bufed-cmds) + (make-modeline-field + :name :bufed-cmds :width 18 + :function + #'(lambda (buffer window) + (declare (ignore buffer window)) + " Type ? for help."))))) + (setf (buffer-modeline-fields *bufed-buffer*) fields)) + (buffer-start (buffer-point buf))) + (change-to-buffer buf))) + +(defun bufed-write-line (buffer name s + &optional (buffer-pathname (buffer-pathname buffer))) + (let ((modified (buffer-modified buffer))) + (write-string (if modified " *" " ") s) + (if buffer-pathname + (format s "~A ~A~:[~50T~A~;~]~%" + (file-namestring buffer-pathname) + (directory-namestring buffer-pathname) + (string= (pathname-to-buffer-name buffer-pathname) name) + name) + (write-line name s)))) + + +(defcommand "Bufed Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Bufed")) + + + + +;;;; Maintenance hooks. + +(eval-when (:compile-toplevel :execute) +(defmacro with-bufed-point ((point buffer &optional pos) &rest body) + (let ((pos (or pos (gensym)))) + `(when (and *bufed-buffers* + (not (eq *bufed-buffer* ,buffer)) + (not (eq *echo-area-buffer* ,buffer))) + (let ((,pos (position ,buffer *bufed-buffers* :key #'car + :test #'eq :end *bufed-buffers-end*))) + (unless ,pos (error "Unknown Bufed buffer.")) + (let ((,point (buffer-point *bufed-buffer*))) + (unless (line-offset (buffer-start ,point) ,pos 0) + (error "Bufed buffer not displayed?")) + (with-writable-buffer (*bufed-buffer*) ,@body)))))) +) ;eval-when + + +(defun bufed-modified-hook (buffer modified) + (with-bufed-point (point buffer) + (setf (next-character (mark-after point)) (if modified #\* #\space)))) +;;; +(add-hook buffer-modified-hook 'bufed-modified-hook) + +(defun bufed-make-hook (buffer) + (declare (ignore buffer)) + (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))) +;;; +(add-hook make-buffer-hook 'bufed-make-hook) + +(defun bufed-delete-hook (buffer) + (with-bufed-point (point buffer pos) + (with-mark ((temp point :left-inserting)) + (line-offset temp 1) + (delete-region (region point temp))) + (let ((len-1 (1- *bufed-buffers-end*))) + (replace *bufed-buffers* *bufed-buffers* + :start1 pos :end1 len-1 + :start2 (1+ pos) :end1 *bufed-buffers-end*) + (setf (svref *bufed-buffers* len-1) nil) + (setf *bufed-buffers-end* len-1)))) +;;; +(add-hook delete-buffer-hook 'bufed-delete-hook) + +(defun bufed-name-hook (buffer name) + (with-bufed-point (point buffer) + (with-mark ((temp point :left-inserting)) + (line-offset temp 1) + (delete-region (region point temp))) + (with-output-to-mark (s point) + (bufed-write-line buffer name s)))) +;;; +(add-hook buffer-name-hook 'bufed-name-hook) + +(defun bufed-pathname-hook (buffer pathname) + (with-bufed-point (point buffer) + (with-mark ((temp point :left-inserting)) + (line-offset temp 1) + (delete-region (region point temp))) + (with-output-to-mark (s point) + (bufed-write-line buffer (buffer-name buffer) s pathname)))) +;;; +(add-hook buffer-pathname-hook 'bufed-pathname-hook) + + + +;;;; Utilities + +(defun array-element-from-pointer-pos (vector &optional + (error-msg "Invalid line.")) + (multiple-value-bind (x y window) (last-key-event-cursorpos) + (declare (ignore x window)) + (when (>= y (length vector)) + (editor-error error-msg)) + (svref vector y))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/debug.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/debug.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/debug.lisp (revision 8058) @@ -0,0 +1,561 @@ +;;; -*- Mode: Lisp; Package: ED; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This contains commands for sending debugger commands to slaves in the +;;; debugger. +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock) + + + + +;;;; DEFINE-DEBUGGER-COMMAND. + +(defmacro define-debugger-command (name doc cmd &key uses-argument) + `(defcommand ,(concatenate 'simple-string "Debug " name) (p) + ,doc ,doc + ,@(if uses-argument + nil + '((declare (ignore p)))) + (let* ((server-info (get-current-eval-server t)) + (wire (server-info-wire server-info))) + (wire:remote wire + (ts-stream-accept-input + (ts-data-stream (server-info-slave-info server-info)) + ,(if uses-argument + `(list ,cmd p) + cmd))) + (wire:wire-force-output wire)))) + + + + +;;;; Frame changing commands. + +(define-debugger-command "Up" + "Moves the \"Current Eval Server\" up one debugger frame." + :up) + +(define-debugger-command "Down" + "Moves the \"Current Eval Server\" down one debugger frame." + :down) + +(define-debugger-command "Top" + "Moves the \"Current Eval Server\" to the top of the debugging stack." + :top) + +(define-debugger-command "Bottom" + "Moves the \"Current Eval Server\" to the bottom of the debugging stack." + :bottom) + +(define-debugger-command "Frame" + "Moves the \"Current Eval Server\" to the absolute debugger frame number + indicated by the prefix argument." + :frame + :uses-argument t) + + + + +;;;; In and Out commands. + +(define-debugger-command "Quit" + "In the \"Current Eval Server\", throws to top level out of the debugger." + :quit) + +(define-debugger-command "Go" + "In the \"Current Eval Server\", tries the CONTINUE restart." + :go) + +(define-debugger-command "Abort" + "In the \"Current Eval Server\", execute the previous ABORT restart." + :abort) + +(define-debugger-command "Restart" + "In the \"Current Eval Server\", executes the restart indicated by the + prefix argument." + :restart + :uses-argument t) + + + + +;;;; Information commands. + +(define-debugger-command "Help" + "In the \"Current Eval Server\", prints the debugger's help text." + :help) + +(define-debugger-command "Error" + "In the \"Current Eval Server\", print the error condition and restart cases + upon entering the debugger." + :error) + +(define-debugger-command "Backtrace" + "Executes the debugger's BACKTRACE command." + :backtrace) + +(define-debugger-command "Print" + "In the \"Current Eval Server\", prints a representation of the debugger's + current frame." + :print) + +(define-debugger-command "Verbose Print" + "In the \"Current Eval Server\", prints a representation of the debugger's + current frame without elipsis." + :vprint) + +(define-debugger-command "List Locals" + "In the \"Current Eval Server\", prints the local variables for the debugger's + current frame." + :list-locals) + +(define-debugger-command "Source" + "In the \"Current Eval Server\", prints the source form for the debugger's + current frame." + :source) + +(define-debugger-command "Verbose Source" + "In the \"Current Eval Server\", prints the source form for the debugger's + current frame with surrounding forms for context." + :vsource) + + + + +;;;; Source editing. + +;;; "Debug Edit Source" -- Command. +;;; +;;; The :edit-source command in the slave debugger initiates a synchronous RPC +;;; into the editor via the wire in *terminal-io*, a typescript stream. This +;;; routine takes the necessary values, a file and source-path, and changes the +;;; editor's state to display that location. +;;; +;;; This command has to wait on SERVE-EVENT until some special is set by the +;;; RPC routine saying it is okay to return to the editor's top level. +;;; +(defvar *debug-editor-source-data* nil) +(defvar *in-debug-edit-source* nil) + +(defcommand "Debug Edit Source" (p) + "Given the \"Current Eval Server\"'s current debugger frame, place the user + at the location's source in the editor." + "Given the \"Current Eval Server\"'s current debugger frame, place the user + at the location's source in the editor." + (declare (ignore p)) + (let* ((server-info (get-current-eval-server t)) + (wire (server-info-wire server-info))) + ;; + ;; Tell the slave to tell the editor some source info. + (wire:remote wire + (ts-stream-accept-input + (ts-data-stream (server-info-slave-info server-info)) + :edit-source)) + (wire:wire-force-output wire) + ;; + ;; Wait for the source info. + (let ((*debug-editor-source-data* nil) + (*in-debug-edit-source* t)) + (catch 'blow-debug-edit-source + (loop + (system:serve-event) + (when *debug-editor-source-data* (return))))))) + +;;; EDIT-SOURCE-LOCATION -- Internal Interface. +;;; +;;; The slave calls this in the editor when the debugger gets an :edit-source +;;; command. This receives the information necessary to take the user in +;;; Hemlock to the source location, and does it. +;;; +(defun edit-source-location (name source-created-date tlf-offset + local-tlf-offset char-offset form-number) + (let ((pn (pathname name))) + (unless (probe-file pn) + (editor-error "Source file no longer exists: ~A." name)) + (multiple-value-bind (buffer newp) (find-file-buffer pn) + (let ((date (buffer-write-date buffer)) + (point (buffer-point buffer))) + (when newp (push-buffer-mark (copy-mark point) nil)) + (buffer-start point) + ;; + ;; Get to the top-level form in the buffer. + (cond ((buffer-modified buffer) + (loud-message "Buffer has been modified. Using form offset ~ + instead of character position.") + (dotimes (i local-tlf-offset) + (pre-command-parse-check point) + (form-offset point 1))) + ((not date) + (loud-message "Cannot compare write dates. Assuming source ~ + has not been modified -- ~A." + name) + (character-offset point char-offset)) + ((= source-created-date date) + (character-offset point char-offset)) + (t + (loud-message "File has been modified since reading the source. ~ + Using form offset instead of character position.") + (dotimes (i local-tlf-offset) + (pre-command-parse-check point) + (form-offset point 1)))) + ;; + ;; Read our form, get form-number translations, get the source-path, + ;; and make it usable. + ;; + ;; NOTE: Here READ is used in the editor lisp to look at a form + ;; that the compiler has digested in the slave lisp. The editor + ;; does not have the same environment at the slave so bad things + ;; can happen if READ hits a #. reader macro (like unknown package + ;; or undefined function errors) which can break the editor. This + ;; code basically inhibits the read-time eval. This doesn't always + ;; work right as the compiler may be seeing a different form structure + ;; and the compiler's version of PATH may not match the editor's. + ;; The main trouble seen in testing is that the 'form-number' + ;; supplied by the compiler was one more than what the vector + ;; returned by form-number-translations contained. For lack of a + ;; better solution, I (pw) just limit the form-number to legal range. + ;; This has worked ok on test code but may be off for some + ;; forms. At least the editor won't break. + + (let* ((vector (di:form-number-translations + (with-input-from-region + (s (region point (buffer-end-mark buffer))) + (let ((*read-suppress* t)) + (read s))) + tlf-offset)) + ;; Don't signal error on index overrun.It may be due + ;; to read-time eval getting form editing blind to + ;; editor + (index (min form-number (1- (length vector)))) + (path (nreverse (butlast (cdr (svref vector index)))))) + ;; + ;; Walk down to the form. Change to buffer in case we get an error + ;; while finding the form. + (change-to-buffer buffer) + (mark-to-debug-source-path point path))))) + (setf *debug-editor-source-data* t) + ;; + ;; While Hemlock was setting up the source edit, the user could have typed + ;; while looking at a buffer no longer current when the commands execute. + (clear-editor-input *editor-input*)) + +;;; CANNOT-EDIT-SOURCE-LOCATION -- Interface. +;;; +;;; The slave calls this when the debugger command "EDIT-SOURCE" runs, and the +;;; slave cannot give the editor source information. +;;; +(defun cannot-edit-source-location () + (loud-message "Can't edit source.") + (when *in-debug-edit-source* + (throw 'blow-debug-edit-source nil))) + + + +;;;; Breakpoints. + +;;; +;;; Breakpoint information for editor management. +;;; + +;;; This holds all the stuff we might want to know about a breakpoint in some +;;; slave. +;;; +(defstruct (breakpoint-info (:print-function print-breakpoint-info) + (:constructor make-breakpoint-info + (slave buffer remote-object name))) + (slave nil :type server-info) + (buffer nil :type buffer) + (remote-object nil :type wire:remote-object) + (name nil :type simple-string)) +;;; +(defun print-breakpoint-info (obj str n) + (declare (ignore n)) + (format str "#" (breakpoint-info-name obj))) + +(defvar *breakpoints* nil) + +(macrolet ((frob (name accessor) + `(defun ,name (key) + (let ((res nil)) + (dolist (bpt-info *breakpoints* res) + (when (eq (,accessor bpt-info) key) + (push bpt-info res))))))) + (frob slave-breakpoints breakpoint-info-slave) + (frob buffer-breakpoints breakpoint-info-buffer)) + +(defun delete-breakpoints-buffer-hook (buffer) + (let ((server-info (value current-eval-server))) + (when server-info + (let ((bpts (buffer-breakpoints buffer)) + (wire (server-info-wire server-info))) + (dolist (b bpts) + (setf *breakpoints* (delete b *breakpoints*)) + (when wire + (wire:remote wire + (di:delete-breakpoint (breakpoint-info-remote-object b)))) + (when wire + (wire:wire-force-output wire))))))) +;;; +(add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook) + +;;; +;;; Setting breakpoints. +;;; + +;;; "Debug Breakpoint" uses this to prompt for :function-end and +;;; :function-start breakpoints. +;;; +(defvar *function-breakpoint-strings* + (make-string-table :initial-contents + '(("Start" . :function-start) ("End" . :function-end)))) +;;; +;;; Maybe this should use the wire level directly and hold onto remote-objects +;;; identifying the breakpoints. Then we could write commands to show where +;;; the breakpoints were and to individually deactivate or delete them. As it +;;; is now we probably have to delete all for a given function. What about +;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a +;;; nice set such as something to simply print all locals at a certain +;;; location. +;;; +(defcommand "Debug Breakpoint" (p) + "This tries to set a breakpoint in the \"Current Eval Server\" at the + location designated by the current point. If there is no known code + location at the point, then this moves the point to the closest location + before the point. With an argument, this sets a breakpoint at the start + or end of the function, prompting the user for which one to use." + "This tries to set a breakpoint in the \"Current Eval Server\" at the + location designated by the current point. If there is no known code + location at the point, then this moves the point to the closest location + before the point. With an argument, this sets a breakpoint at the start + or end of the function, prompting the user for which one to use." + (let ((point (current-point))) + (pre-command-parse-check point) + (let ((name (find-defun-for-breakpoint point))) + (if p + (multiple-value-bind (str place) + (prompt-for-keyword + (list *function-breakpoint-strings*) + :prompt "Set breakpoint at function: " + :default :start :default-string "Start") + (declare (ignore str)) + (set-breakpoint-in-slave (get-current-eval-server t) name place)) + (let* ((path (find-path-for-breakpoint point)) + (server-info (get-current-eval-server t)) + (res (set-breakpoint-in-slave server-info name path))) + (cond ((not res) + (message "No code locations correspond with point.")) + ((wire:remote-object-p res) + (push (make-breakpoint-info server-info (current-buffer) + res name) + *breakpoints*) + (message "Breakpoint set.")) + (t + (resolve-ambiguous-breakpoint-location server-info + name res)))))))) + +;;; FIND-PATH-FOR-BREAKPOINT -- Internal. +;;; +;;; This walks up from point to the beginning of its containing DEFUN to return +;;; the pseudo source-path (no form-number, no top-level form offset, and in +;;; descent order from start of the DEFUN). +;;; +(defun find-path-for-breakpoint (point) + (with-mark ((m point) + (end point)) + (let ((path nil)) + (top-level-offset end -1) + (with-mark ((containing-form m)) + (loop + (when (mark= m end) (return)) + (backward-up-list containing-form) + (do ((count 0 (1+ count))) + ((mark= m containing-form) + ;; Count includes moving from the first form inside the + ;; containing-form paren to the outside of the containing-form + ;; paren -- one too many. + (push (1- count) path)) + (form-offset m -1)))) + path))) + +;;; SET-BREAKPOINT-IN-SLAVE -- Internal. +;;; +;;; This tells the slave to set a breakpoint for name. Path is a modified +;;; source-path (with no form-number or top-level-form offset) or a symbol +;;; (:function-start or :function-end). If the server dies while evaluating +;;; form, then this signals an editor-error. +;;; +(defun set-breakpoint-in-slave (server-info name path) + (when (server-info-notes server-info) + (editor-error "Server ~S is currently busy. See \"List Operations\"." + (server-info-name server-info))) + (multiple-value-bind (res error) + (wire:remote-value (server-info-wire server-info) + (di:set-breakpoint-for-editor (value current-package) + name path)) + (when error (editor-error "The server died before finishing.")) + res)) + +;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal. +;;; +;;; This helps the user select an ambiguous code location for "Debug +;;; Breakpoint". +;;; +(defun resolve-ambiguous-breakpoint-location (server-info name locs) + (declare (list locs)) + (let ((point (current-point)) + (loc-num (length locs)) + (count 1) + (cur-loc locs)) + (flet ((show-loc () + (top-level-offset point -1) + (mark-to-debug-source-path point (cdar cur-loc)))) + (show-loc) + (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num) + :help "Pick a location to set a breakpoint." + :change-window nil) + (#\space "Move point to next possible location." + (setf cur-loc (cdr cur-loc)) + (cond (cur-loc + (incf count)) + (t + (setf cur-loc locs) + (setf count 1))) + (show-loc) + (reprompt)) + (:confirm "Choose the current location." + (let ((res (wire:remote-value (server-info-wire server-info) + (di:set-location-breakpoint-for-editor (caar cur-loc))))) + (unless (wire:remote-object-p res) + (editor-error "Couldn't set breakpoint from location?")) + (push (make-breakpoint-info server-info (current-buffer) res name) + *breakpoints*)) + (message "Breakpoint set.")))))) + +;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal. +;;; +;;; This takes a mark at the beginning of a top-level form and modified debugger +;;; source-path. Path has no form number or top-level-form offset element, and +;;; it has been reversed to actually be usable. +;;; +(defun mark-to-debug-source-path (mark path) + (let ((quote-or-function nil)) + (pre-command-parse-check mark) + (dolist (n path) + (when quote-or-function + (editor-error + "Apparently settled on the symbol QUOTE or FUNCTION via their ~ + read macros, which is odd, but furthermore there seems to be ~ + more source-path left.")) + (unless (form-offset mark 1) + ;; Want to use the following and delete the next FORM-OFFSET -1. + ;; (scan-direction-valid mark t (or :open-paren :prefix)) + (editor-error + "Ran out of text in buffer with more source-path remaining.")) + (form-offset mark -1) + (ecase (next-character mark) + (#\( + (mark-after mark) + (form-offset mark n)) + (#\' + (case n + (0 (setf quote-or-function t)) + (1 (mark-after mark)) + (t (editor-error "Next form is QUOTE, but source-path index ~ + is other than zero or one.")))) + (#\# + (case (next-character (mark-after mark)) + (#\' + (case n + (0 (setf quote-or-function t)) + (1 (mark-after mark)) + (t (editor-error "Next form is FUNCTION, but source-path ~ + index is other than zero or one.")))) + (t (editor-error + "Can only parse ' and #' read macros.")))))) + ;; Get to the beginning of the form. + (form-offset mark 1) + (form-offset mark -1))) + +;;; +;;; Deleting breakpoints. +;;; + +(defhvar "Delete Breakpoints Confirm" + "This determines whether \"Debug Delete Breakpoints\" should ask for + confirmation before deleting breakpoints." + :value t) + +(defcommand "Debug Delete Breakpoints" (p) + "This deletes all breakpoints for the named DEFUN containing the point. + This affects the \"Current Eval Server\"." + "This deletes all breakpoints for the named DEFUN containing the point. + This affects the \"Current Eval Server\"." + (declare (ignore p)) + (let* ((server-info (get-current-eval-server t)) + (wire (server-info-wire server-info)) + (name (find-defun-for-breakpoint (current-point))) + (bpts (slave-breakpoints server-info))) + (cond ((not bpts) + (message "No breakpoints recorded for ~A." name)) + ((or (not (value delete-breakpoints-confirm)) + (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name) + :default t + :default-string "Y")) + (dolist (b bpts) + (when (string= name (breakpoint-info-name b)) + (setf *breakpoints* (delete b *breakpoints*)) + (wire:remote wire + (di:delete-breakpoint-for-editor + (breakpoint-info-remote-object b))))) + (wire:wire-force-output wire))))) + +;;; +;;; Breakpoint utilities. +;;; + +;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal. +;;; +;;; This returns as a string the name of the DEFUN containing point. It +;;; signals any errors necessary to ensure "we are in good form". +;;; +(defun find-defun-for-breakpoint (point) + (with-mark ((m1 point) + (m2 point)) + (unless (top-level-offset m2 -1) + (editor-error "Must be inside a DEFUN.")) + ;; + ;; Check for DEFUN. + (mark-after (move-mark m1 m2)) + (unless (find-attribute m1 :whitespace #'zerop) + (editor-error "Must be inside a DEFUN.")) + (word-offset (move-mark m2 m1) 1) + (unless (string-equal (region-to-string (region m1 m2)) "defun") + (editor-error "Must be inside a DEFUN.")) + ;; + ;; Find name. + (unless (find-attribute m2 :whitespace #'zerop) + (editor-error "Function unnamed?")) + (form-offset (move-mark m1 m2) 1) + (region-to-string (region m2 m1)))) + + + + +;;;; Miscellaneous commands. + +(define-debugger-command "Flush Errors" + "In the \"Current Eval Server\", toggles whether the debugger ignores errors + or recursively enters itself." + :flush) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/dired.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/dired.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/dired.lisp (revision 8058) @@ -0,0 +1,701 @@ +;;; -*- Log: hemlock.log; Package: dired -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains site dependent code for dired. +;;; Written by Bill Chiles. +;;; + +(defpackage "DIRED" + (:shadow "RENAME-FILE" "DELETE-FILE") + (:export "COPY-FILE" "RENAME-FILE" "FIND-FILE" "DELETE-FILE" + "MAKE-DIRECTORY" + "*UPDATE-DEFAULT*" "*CLOBBER-DEFAULT*" "*RECURSIVE-DEFAULT*" + "*REPORT-FUNCTION*" "*ERROR-FUNCTION*" "*YESP-FUNCTION*" + "PATHNAMES-FROM-PATTERN")) + +(in-package "DIRED") + + + +;;;; Exported parameters. + +(defparameter *update-default* nil + "Update arguments to utilities default to this value.") + +(defparameter *clobber-default* t + "Clobber arguments to utilities default to this value.") + +(defparameter *recursive-default* nil + "Recursive arguments to utilities default to this value.") + + + + +;;;; WILDCARDP + +(defconstant wildcard-char #\* + "Wildcard designator for file names will match any substring.") + +(defmacro wildcardp (file-namestring) + `(position wildcard-char (the simple-string ,file-namestring) :test #'char=)) + + + + +;;;; User interaction functions, variable declarations, and their defaults. + +(defun default-error-function (string &rest args) + (apply #'error string args)) +;;; +(defvar *error-function* #'default-error-function + "This function is called when an error is encountered in dired code.") + +(defun default-report-function (string &rest args) + (apply #'format t string args)) +;;; +(defvar *report-function* #'default-report-function + "This function is called when the user needs to be informed of something.") + +(defun default-yesp-function (string &rest args) + (apply #'format t string args) + (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line))))) + (declare (simple-string answer)) + (or (string= answer "") + (string= answer "y") + (string= answer "yes") + (string= answer "ye")))) +;;; +(defvar *yesp-function* #'default-yesp-function + "Function to query the user about clobbering an already existent file.") + + + + +;;;; Copy-File + +;;; WILD-MATCH objects contain information about wildcard matches. File is the +;;; Sesame namestring of the file matched, and substitute is a substring of the +;;; file-namestring of file. +;;; +(defstruct (wild-match (:print-function print-wild-match) + (:constructor make-wild-match (file substitute))) + file + substitute) + +(defun print-wild-match (obj str n) + (declare (ignore n)) + (format str "#" + (wild-match-file obj) (wild-match-substitute obj))) + + +(defun copy-file (spec1 spec2 &key (update *update-default*) + (clobber *clobber-default*) + (directory () directoryp)) + "Copy file spec1 to spec2. A single wildcard is acceptable, and directory + names may be used. If spec1 and spec2 are both directories, then a + recursive copy is done of the files and subdirectory structure of spec1; + if spec2 is in the subdirectory structure of spec1, the recursion will + not descend into it. Use spec1/* to copy only the files in spec1 to + directory spec2. If spec2 is a directory, and spec1 is a file, then + spec1 is copied into spec2 with the same pathname-name. Files are + copied maintaining the source's write date. If :update is non-nil, then + files are only copied if the source is newer than the destination, still + maintaining the source's write date; the user is not warned if the + destination is newer (not the same write date) than the source. If + :clobber and :update are nil, then if any file spec2 already exists, the + user will be asked whether it should be overwritten or not." + (cond + ((not directoryp) + (let* ((ses-name1 (ext:unix-namestring spec1 t)) + (exists1p (unix:unix-file-kind ses-name1)) + (ses-name2 (ext:unix-namestring spec2 nil)) + (pname1 (pathname ses-name1)) + (pname2 (pathname ses-name2)) + (dirp1 (directoryp pname1)) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp (file-namestring pname1))) + (wildp2 (wildcardp (file-namestring pname2)))) + (when (and dirp1 wildp1) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname1)) + (when (and dirp2 wildp2) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname2)) + (when (and dirp1 (not dirp2)) + (funcall *error-function* + "Cannot handle spec1 being a directory and spec2 a file.")) + (when (and wildp2 (not wildp1)) + (funcall *error-function* + "Cannot handle destination having wildcards without ~ + source having wildcards.")) + (when (and wildp1 (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (cond ((and dirp1 dirp2) + (unless (directory-existsp ses-name1) + (funcall *error-function* + "Directory does not exist -- ~S." pname1)) + (unless (directory-existsp ses-name2) + (enter-directory ses-name2)) + (recursive-copy pname1 pname2 update clobber pname2 + ses-name1 ses-name2)) + (dirp2 + ;; merge pname2 with pname1 to pick up a similar file-namestring. + (copy-file-1 pname1 wildp1 exists1p + (merge-pathnames pname2 pname1) + wildp1 update clobber)) + (t (copy-file-1 pname1 wildp1 exists1p + pname2 wildp2 update clobber))))) + (directory + (when (pathname-directory spec1) + (funcall *error-function* + "Spec1 is just a pattern when supplying directory -- ~S." + spec1)) + (let* ((pname2 (pathname (ext:unix-namestring spec2 nil))) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp spec1)) + (wildp2 (wildcardp (file-namestring pname2)))) + (unless wildp1 + (funcall *error-function* + "Pattern, ~S, does not contain a wildcard." + spec1)) + (when (and (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (copy-wildcard-files spec1 wildp1 + (if dirp2 (merge-pathnames pname2 spec1) pname2) + (if dirp2 wildp1 wildp2) + update clobber directory)))) + (values)) + +;;; RECURSIVE-COPY takes two pathnames that represent directories, and +;;; the files in pname1 are copied into pname2, recursively descending into +;;; subdirectories. If a subdirectory of pname1 does not exist in pname2, +;;; it is created. Pname1 is known to exist. Forbidden-dir is originally +;;; the same as pname2; this keeps us from infinitely recursing if pname2 +;;; is in the subdirectory structure of pname1. Returns t if some file gets +;;; copied. +;;; +(defun recursive-copy (pname1 pname2 update clobber + forbidden-dir ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2) + (dolist (spec (directory (directory-namestring pname1))) + (let ((spec-ses-name (namestring spec))) + (if (directoryp spec) + (unless (equal (pathname spec-ses-name) forbidden-dir) + (let* ((dir2-pname (merge-dirs spec pname2)) + (dir2-ses-name (namestring dir2-pname))) + (unless (directory-existsp dir2-ses-name) + (enter-directory dir2-ses-name)) + (recursive-copy spec dir2-pname update clobber forbidden-dir + spec-ses-name dir2-ses-name) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 + ses-name2))) + (copy-file-2 spec-ses-name + (namestring (merge-pathnames pname2 spec)) + update clobber))))) + +;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and +;;; adds it to the end of the sequence of directory names from pname2, returning +;;; a pathname. +;;; +#| +(defun merge-dirs (pname1 pname2) + (let* ((dirs1 (pathname-directory pname1)) + (dirs2 (pathname-directory pname2)) + (dirs2-len (length dirs2)) + (new-dirs2 (make-array (1+ dirs2-len)))) + (declare (simple-vector dirs1 dirs2 new-dirs2)) + (replace new-dirs2 dirs2) + (setf (svref new-dirs2 dirs2-len) + (svref dirs1 (1- (length dirs1)))) + (make-pathname :directory new-dirs2 :device :absolute))) +|# + +(defun merge-dirs (pname1 pname2) + (let* ((dirs1 (pathname-directory pname1)) + (dirs2 (pathname-directory pname2)) + (dirs2-len (length dirs2)) + (new-dirs2 (make-list (1+ dirs2-len)))) + (replace new-dirs2 dirs2) + (setf (nth dirs2-len new-dirs2) + (nth (1- (length dirs1)) dirs1)) + (make-pathname :directory new-dirs2 :device :unspecific))) + +;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard +;;; or none. Wildp1 and Wildp2 are either nil or indexes into the +;;; file-namestring of pname1 and pname2, respectively, indicating the position +;;; of the wildcard character. If there is no wildcard, then simply call +;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files. +;;; +(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber) + (if wildp1 + (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber) + (let ((ses-name1 (namestring pname1))) + (unless exists1p (funcall *error-function* + "~S does not exist." ses-name1)) + (copy-file-2 ses-name1 (namestring pname2) update clobber)))) + +(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber + &optional directory) + (multiple-value-bind (dst-before dst-after) + (before-wildcard-after (file-namestring pname2) wildp2) + (dolist (match (resolve-wildcard pname1 wildp1 directory)) + (copy-file-2 (wild-match-file match) + (namestring (concatenate 'simple-string + (directory-namestring pname2) + dst-before + (wild-match-substitute match) + dst-after)) + update clobber)))) + +;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update +;;; and clobber, with respect to the documentation of COPY-FILE. If ses-name2 +;;; doesn't exist, then just copy it; otherwise, if update, then only copy it +;;; if the destination's write date precedes the source's, and if not clobber +;;; and not update, then ask the user before doing the copy. +;;; +(defun copy-file-2 (ses-name1 ses-name2 update clobber) + (let ((secs1 (get-write-date ses-name1))) + (cond ((not (probe-file ses-name2)) + (do-the-copy ses-name1 ses-name2 secs1)) + (update + (let ((secs2 (get-write-date ses-name2))) + (cond (clobber + (do-the-copy ses-name1 ses-name2 secs1)) + ((and (> secs2 secs1) + (funcall *yesp-function* + "~&~S ==> ~S~% ~ + ** Destination is newer than source. ~ + Overwrite it? " + ses-name1 ses-name2)) + (do-the-copy ses-name1 ses-name2 secs1)) + ((< secs2 secs1) + (do-the-copy ses-name1 ses-name2 secs1))))) + ((not clobber) + (when (funcall *yesp-function* + "~&~S ==> ~S~% ** Destination already exists. ~ + Overwrite it? " + ses-name1 ses-name2) + (do-the-copy ses-name1 ses-name2 secs1))) + (t (do-the-copy ses-name1 ses-name2 secs1))))) + +(defun do-the-copy (ses-name1 ses-name2 secs1) + (let* ((fd (open-file ses-name1))) + (unwind-protect + (multiple-value-bind (data byte-count mode) + (read-file fd ses-name1) + (unwind-protect (write-file ses-name2 data byte-count mode) + (system:deallocate-system-memory data byte-count))) + (close-file fd))) + (set-write-date ses-name2 secs1) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)) + + + +;;;; Rename-File + +(defun rename-file (spec1 spec2 &key (clobber *clobber-default*) + (directory () directoryp)) + "Rename file spec1 to spec2. A single wildcard is acceptable, and spec2 may + be a directory with the result spec being the merging of spec2 with spec1. + If clobber is nil and spec2 exists, then the user will be asked to confirm + the renaming. As with Unix mv, if you are renaming a directory, don't + specify the trailing slash." + (cond + ((not directoryp) + (let* ((ses-name1 (ext:unix-namestring spec1 t)) + (exists1p (unix:unix-file-kind ses-name1)) + (ses-name2 (ext:unix-namestring spec2 nil)) + (pname1 (pathname ses-name1)) + (pname2 (pathname ses-name2)) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp (file-namestring pname1))) + (wildp2 (wildcardp (file-namestring pname2)))) + (if (and dirp2 wildp2) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname2)) + (if (and wildp2 (not wildp1)) + (funcall *error-function* + "Cannot handle destination having wildcards without ~ + source having wildcards.")) + (if (and wildp1 (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (if dirp2 + (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2 + pname1) + wildp1 clobber) + (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber)))) + (directory + (when (pathname-directory spec1) + (funcall *error-function* + "Spec1 is just a pattern when supplying directory -- ~S." + spec1)) + + (let* ((pname2 (pathname (ext:unix-namestring spec2 nil))) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp spec1)) + (wildp2 (wildcardp (file-namestring pname2)))) + (unless wildp1 + (funcall *error-function* + "Pattern, ~S, does not contain a wildcard." + spec1)) + (when (and (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (rename-wildcard-files spec1 wildp1 + (if dirp2 (merge-pathnames pname2 spec1) pname2) + (if dirp2 wildp1 wildp2) + clobber directory)))) + (values)) + +;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard +;;; or none. Wildp1 and Wildp2 are either nil or indexes into the +;;; file-namestring of pname1 and pname2, respectively, indicating the position +;;; of the wildcard character. If there is no wildcard, then simply call +;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files. +;;; +(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber) + (if wildp1 + (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber) + (let ((ses-name1 (namestring pname1))) + (unless exists1p (funcall *error-function* + "~S does not exist." ses-name1)) + (rename-file-2 ses-name1 (namestring pname2) clobber)))) + +(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber + &optional directory) + (multiple-value-bind (dst-before dst-after) + (before-wildcard-after (file-namestring pname2) wildp2) + (dolist (match (resolve-wildcard pname1 wildp1 directory)) + (rename-file-2 (wild-match-file match) + (namestring (concatenate 'simple-string + (directory-namestring pname2) + dst-before + (wild-match-substitute match) + dst-after)) + clobber)))) + +(defun rename-file-2 (ses-name1 ses-name2 clobber) + (cond ((and (probe-file ses-name2) (not clobber)) + (when (funcall *yesp-function* + "~&~S ==> ~S~% ** Destination already exists. ~ + Overwrite it? " + ses-name1 ses-name2) + (sub-rename-file ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))) + (t (sub-rename-file ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)))) + + + + +;;;; Find-File + +(defun find-file (file-name &optional (directory "") + (find-all-p nil find-all-suppliedp)) + "Find the file with file-namestring file recursively looking in directory. + If find-all-p is non-nil, then do not stop searching upon finding the first + occurance of file. File may contain a single wildcard, which causes + find-all-p to default to t instead of nil." + (let* ((file (coerce file-name 'simple-string)) + (wildp (wildcardp file)) + (find-all-p (if find-all-suppliedp find-all-p wildp))) + (declare (simple-string file)) + (catch 'found-file + (if wildp + (multiple-value-bind (before after) + (before-wildcard-after file wildp) + (find-file-aux file directory find-all-p before after)) + (find-file-aux file directory find-all-p)))) + (values)) + +(defun find-file-aux (the-file directory find-all-p &optional before after) + (declare (simple-string the-file)) + (dolist (spec (directory directory)) + (let* ((spec-ses-name (namestring spec)) + (spec-file-name (file-namestring spec-ses-name))) + (declare (simple-string spec-ses-name spec-file-name)) + (if (directoryp spec) + (find-file-aux the-file spec find-all-p before after) + (when (if before + (find-match before after spec-file-name :no-cons) + (string-equal the-file spec-file-name)) + (print spec-ses-name) + (unless find-all-p (throw 'found-file t))))))) + + + + +;;;; Delete-File + +;;; DELETE-FILE +;;; If spec is a directory, but recursive is nil, just pass the directory +;;; down through, letting LISP:DELETE-FILE signal an error if the directory +;;; is not empty. +;;; +(defun delete-file (spec &key (recursive *recursive-default*) + (clobber *clobber-default*)) + "Delete spec asking confirmation on each file if clobber is nil. A single + wildcard is acceptable. If recursive is non-nil, then a directory spec may + be given to recursively delete the entirety of the directory and its + subdirectory structure. An empty directory may be specified without + recursive being non-nil. When specifying a directory, the trailing slash + must be included." + (let* ((ses-name (ext:unix-namestring spec t)) + (pname (pathname ses-name)) + (wildp (wildcardp (file-namestring pname))) + (dirp (directoryp pname))) + (if dirp + (if recursive + (recursive-delete pname ses-name clobber) + (delete-file-2 ses-name clobber)) + (delete-file-1 pname ses-name wildp clobber))) + (values)) + +(defun recursive-delete (directory dir-ses-name clobber) + (dolist (spec (directory (directory-namestring directory))) + (let ((spec-ses-name (namestring spec))) + (if (directoryp spec) + (recursive-delete (pathname spec-ses-name) spec-ses-name clobber) + (delete-file-2 spec-ses-name clobber)))) + (delete-file-2 dir-ses-name clobber)) + +(defun delete-file-1 (pname ses-name wildp clobber) + (if wildp + (dolist (match (resolve-wildcard pname wildp)) + (delete-file-2 (wild-match-file match) clobber)) + (delete-file-2 ses-name clobber))) + +(defun delete-file-2 (ses-name clobber) + (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name)) + (if (directoryp ses-name) + (delete-directory ses-name) + (lisp:delete-file ses-name)) + (funcall *report-function* "~&~A~%" ses-name))) + + + + +;;;; Wildcard resolution + +(defun pathnames-from-pattern (pattern files) + "Return a list of pathnames from files whose file-namestrings match + pattern. Pattern must be a non-empty string and contains only one + asterisk. Files contains no directories." + (declare (simple-string pattern)) + (when (string= pattern "") + (funcall *error-function* "Must be a non-empty pattern.")) + (unless (= (count wildcard-char pattern :test #'char=) 1) + (funcall *error-function* "Pattern must contain one asterisk.")) + (multiple-value-bind (before after) + (before-wildcard-after pattern (wildcardp pattern)) + (let ((result nil)) + (dolist (f files result) + (let* ((ses-namestring (namestring f)) + (f-namestring (file-namestring ses-namestring)) + (match (find-match before after f-namestring))) + (when match (push f result))))))) + + +;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the +;;; wildcard character in the file-namestring and returns a list of wild-match +;;; objects. When directory is supplied, pname is just a pattern, or a +;;; file-namestring. It is an error for directory to be anything other than +;;; absolute pathnames in the same directory. Each wild-match object contains +;;; the Sesame namestring of a file in the same directory as pname, or +;;; directory, and a simple-string representing what the wildcard matched. +;;; +(defun resolve-wildcard (pname wild-pos &optional directory) + (multiple-value-bind (before after) + (before-wildcard-after (if directory + pname + (file-namestring pname)) + wild-pos) + (let (result) + (dolist (f (or directory (directory (directory-namestring pname))) + (nreverse result)) + (unless (directoryp f) + (let* ((ses-namestring (namestring f)) + (f-namestring (file-namestring ses-namestring)) + (match (find-match before after f-namestring))) + (if match + (push (make-wild-match ses-namestring match) result)))))))) + +;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a +;;; file-namestring. If before and after match a substring of file-namestring +;;; and are respectively left bound and right bound, then anything left in +;;; between is the match returned. If no match is found, nil is returned. +;;; NOTE: if version numbers ever really exist, then this code will have to be +;;; changed since the file-namestring of a pathname contains the version number. +;;; +(defun find-match (before after file-namestring &optional no-cons) + (declare (simple-string before after file-namestring)) + (let ((before-len (length before)) + (after-len (length after)) + (name-len (length file-namestring))) + (if (>= name-len (+ before-len after-len)) + (let* ((start (if (string= before file-namestring + :end1 before-len :end2 before-len) + before-len)) + (end (- name-len after-len)) + (matchp (and start + (string= after file-namestring :end1 after-len + :start2 end :end2 name-len)))) + (if matchp + (if no-cons + t + (subseq file-namestring start end))))))) + +(defun before-wildcard-after (file-namestring wild-pos) + (declare (simple-string file-namestring)) + (values (subseq file-namestring 0 wild-pos) + (subseq file-namestring (1+ wild-pos) (length file-namestring)))) + + + + +;;;; Miscellaneous Utilities (e.g., MAKEDIR). + +(defun make-directory (name) + "Creates directory name. If name exists, then an error is signaled." + (let ((ses-name (ext:unix-namestring name nil))) + (when (unix:unix-file-kind ses-name) + (funcall *error-function* "Name already exists -- ~S" ses-name)) + (enter-directory ses-name)) + t) + + + + +;;;; Mach Operations + +(defun open-file (ses-name) + (multiple-value-bind (fd err) + (unix:unix-open ses-name unix:o_rdonly 0) + (unless fd + (funcall *error-function* "Opening ~S failed: ~A." ses-name err)) + fd)) + +(defun close-file (fd) + (unix:unix-close fd)) + +(defun read-file (fd ses-name) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size) + (unix:unix-fstat fd) + (declare (ignore ino nlink uid gid rdev)) + (unless winp (funcall *error-function* + "Opening ~S failed: ~A." ses-name dev-or-err)) + (let ((storage (system:allocate-system-memory size))) + (multiple-value-bind (read-bytes err) + (unix:unix-read fd storage size) + (when (or (null read-bytes) (not (= size read-bytes))) + (system:deallocate-system-memory storage size) + (funcall *error-function* + "Reading file ~S failed: ~A." ses-name err))) + (values storage size mode)))) + +(defun write-file (ses-name data byte-count mode) + (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644) + (unless fd + (funcall *error-function* "Couldn't create file ~S: ~A" + ses-name (unix:get-unix-error-msg err))) + (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count) + (unless winp + (funcall *error-function* "Writing file ~S failed: ~A" + ses-name + (unix:get-unix-error-msg err)))) + (unix:unix-fchmod fd (logand mode #o777)) + (unix:unix-close fd))) + +(defun set-write-date (ses-name secs) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime) + (unix:unix-stat ses-name) + (declare (ignore ino mode nlink uid gid rdev size)) + (unless winp + (funcall *error-function* "Couldn't stat file ~S failed: ~A." + ses-name dev-or-err)) + (multiple-value-bind (winp err) + (unix:unix-utimes ses-name atime 0 secs 0) + (unless winp + (funcall *error-function* "Couldn't set write date of file ~S: ~A" + ses-name (unix:get-unix-error-msg err)))))) + +(defun get-write-date (ses-name) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size + atime mtime) + (unix:unix-stat ses-name) + (declare (ignore ino mode nlink uid gid rdev size atime)) + (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A." + ses-name dev-or-err)) + mtime)) + +;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE. +;;; This is because it merges the new name with the old name to pick up +;;; defaults, and this conflicts with Unix-oid names. For example, renaming +;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't +;;; have this problem. +;;; +(defun sub-rename-file (ses-name1 ses-name2) + (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) + (unless res + (funcall *error-function* "Failed to rename ~A to ~A: ~A." + ses-name1 ses-name2 (unix:get-unix-error-msg err))))) + +(defun directory-existsp (ses-name) + (eq (unix:unix-file-kind ses-name) :directory)) + +(defun enter-directory (ses-name) + (declare (simple-string ses-name)) + (let* ((length-1 (1- (length ses-name))) + (name (if (= (position #\/ ses-name :test #'char= :from-end t) + length-1) + (subseq ses-name 0 (1- (length ses-name))) + ses-name))) + (multiple-value-bind (winp err) (unix:unix-mkdir name #o755) + (unless winp + (funcall *error-function* "Couldn't make directory ~S: ~A" + name + (unix:get-unix-error-msg err)))))) + +(defun delete-directory (ses-name) + (declare (simple-string ses-name)) + (multiple-value-bind (winp err) + (unix:unix-rmdir (subseq ses-name 0 + (1- (length ses-name)))) + (unless winp + (funcall *error-function* "Couldn't delete directory ~S: ~A" + ses-name + (unix:get-unix-error-msg err))))) + + + + +;;;; Misc. Utility Utilities + +;;; NSEPARATE-FILES destructively returns a list of file specs from listing. +(defun nseparate-files (listing) + (do (files hold) + ((null listing) files) + (setf hold (cdr listing)) + (unless (directoryp (car listing)) + (setf (cdr listing) files) + (setf files listing)) + (setf listing hold))) + + +(defun directoryp (p) + (not (or (pathname-name p) (pathname-type p)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/diredcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/diredcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/diredcoms.lisp (revision 8058) @@ -0,0 +1,905 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Simple directory editing support. +;;; This file contains site dependent calls. +;;; +;;; Written by Blaine Burks and Bill Chiles. +;;; + +(in-package :hemlock) + + +(defmode "Dired" :major-p t + :documentation + "Dired permits convenient directory browsing and file operations including + viewing, deleting, copying, renaming, and wildcard specifications.") + + +(defstruct (dired-information (:print-function print-dired-information) + (:conc-name dired-info-)) + pathname ; Pathname of directory. + pattern ; FILE-NAMESTRING with wildcard possibly. + dot-files-p ; Whether to include UNIX dot files. + write-date ; Write date of directory. + files ; Simple-vector of dired-file structures. + file-list) ; List of pathnames for files, excluding directories. + +(defun print-dired-information (obj str n) + (declare (ignore n)) + (format str "#" (namestring (dired-info-pathname obj)))) + + +(defstruct (dired-file (:print-function print-dired-file) + (:constructor make-dired-file (pathname))) + pathname + (deleted-p nil) + (write-date nil)) + +(defun print-dired-file (obj str n) + (declare (ignore n)) + (format str "#" (namestring (dired-file-pathname obj)))) + + + + +;;;; "Dired" command. + +;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to +;;; buffers that display their contents. +;;; +(defvar *pathnames-to-dired-buffers* ()) + +(make-modeline-field + :name :dired-cmds :width 20 + :function + #'(lambda (buffer window) + (declare (ignore buffer window)) + " Type ? for help. ")) + +(defcommand "Dired" (p &optional directory) + "Prompts for a directory and edits it. If a dired for that directory already + exists, go to that buffer, otherwise create one. With an argument, include + UNIX dot files." + "Prompts for a directory and edits it. If a dired for that directory already + exists, go to that buffer, otherwise create one. With an argument, include + UNIX dot files." + (let ((info (if (hemlock-bound-p 'dired-information) + (value dired-information)))) + (dired-guts nil + ;; Propagate dot-files property to subdirectory edits. + (or (and info (dired-info-dot-files-p info)) + p) + directory))) + +(defcommand "Dired with Pattern" (p) + "Do a dired, prompting for a pattern which may include a single *. With an + argument, include UNIX dit files." + "Do a dired, prompting for a pattern which may include a single *. With an + argument, include UNIX dit files." + (dired-guts t p nil)) + +(defun dired-guts (patternp dot-files-p directory) + (let* ((dpn (value pathname-defaults)) + (directory (dired-directorify + (or directory + (prompt-for-file + :prompt "Edit Directory: " + :help "Pathname to edit." + :default (make-pathname + :device (pathname-device dpn) + :directory (pathname-directory dpn)) + :must-exist nil)))) + (pattern (if patternp + (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t))) + (full-name (namestring (if pattern + (merge-pathnames directory pattern) + directory))) + (name (concatenate 'simple-string "Dired " full-name)) + (buffer (cdr (assoc full-name *pathnames-to-dired-buffers* + :test #'string=)))) + (declare (simple-string full-name)) + (setf (value pathname-defaults) (merge-pathnames directory dpn)) + (change-to-buffer + (cond (buffer + (when (and dot-files-p + (not (dired-info-dot-files-p + (variable-value 'dired-information + :buffer buffer)))) + (setf (dired-info-dot-files-p (variable-value 'dired-information + :buffer buffer)) + t) + (update-dired-buffer directory pattern buffer)) + buffer) + (t + (let ((buffer (make-buffer + name :modes '("Dired") + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field :dired-cmds))) + :delete-hook (list 'dired-buffer-delete-hook)))) + (unless (initialize-dired-buffer directory pattern + dot-files-p buffer) + (delete-buffer-if-possible buffer) + (editor-error "No entries for ~A." full-name)) + (push (cons full-name buffer) *pathnames-to-dired-buffers*) + buffer)))))) + +;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some +;;; variables to make it usable as a dired buffer. If there are no file +;;; satisfying directory, then this returns nil, otherwise t. +;;; +(defun initialize-dired-buffer (directory pattern dot-files-p buffer) + (multiple-value-bind (pathnames dired-files) + (dired-in-buffer directory pattern dot-files-p buffer) + (if (zerop (length dired-files)) + nil + (defhvar "Dired Information" + "Contains the information neccessary to manipulate dired buffers." + :buffer buffer + :value (make-dired-information :pathname directory + :pattern pattern + :dot-files-p dot-files-p + :write-date (file-write-date directory) + :files dired-files + :file-list pathnames))))) + +;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors +;;; to the user and to clean up the dired buffer. +;;; +(defun call-print-directory (directory mark dot-files-p) + (handler-case (with-output-to-mark (s mark :full) + (print-directory directory s + :all dot-files-p :verbose t :return-list t)) + (error (condx) + (delete-buffer-if-possible (line-buffer (mark-line mark))) + (editor-error "~A" condx)))) + +;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion. This +;;; removes the buffer from the pathnames mapping, and it deletes and buffer +;;; local variables referring to it. +;;; +(defun dired-buffer-delete-hook (buffer) + (setf *pathnames-to-dired-buffers* + (delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr))) + + + + +;;;; Dired deletion and undeletion. + +(defcommand "Dired Delete File" (p) + "Marks a file for deletion; signals an error if not in a dired buffer. + With an argument, this prompts for a pattern that may contain at most one + wildcard, an asterisk, and all names matching the pattern will be flagged + for deletion." + "Marks a file for deletion; signals an error if not in a dired buffer." + (dired-frob-deletion p t)) + +(defcommand "Dired Undelete File" (p) + "Removes a mark for deletion; signals and error if not in a dired buffer. + With an argument, this prompts for a pattern that may contain at most one + wildcard, an asterisk, and all names matching the pattern will be unflagged + for deletion." + "Removes a mark for deletion; signals and error if not in a dired buffer." + (dired-frob-deletion p nil)) + +(defcommand "Dired Delete File and Down Line" (p) + "Marks file for deletion and moves down a line. + See \"Dired Delete File\"." + "Marks file for deletion and moves down a line. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion nil t) + (dired-down-line (current-point))) + +(defcommand "Dired Undelete File and Down Line" (p) + "Marks file undeleted and moves down a line. + See \"Dired Delete File\"." + "Marks file undeleted and moves down a line. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion nil nil) + (dired-down-line (current-point))) + +(defcommand "Dired Delete File with Pattern" (p) + "Prompts for a pattern and marks matching files for deletion. + See \"Dired Delete File\"." + "Prompts for a pattern and marks matching files for deletion. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion t t) + (dired-down-line (current-point))) + +(defcommand "Dired Undelete File with Pattern" (p) + "Prompts for a pattern and marks matching files undeleted. + See \"Dired Delete File\"." + "Prompts for a pattern and marks matching files undeleted. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion t nil) + (dired-down-line (current-point))) + +;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a +;;; pattern and whether to mark the file deleted or undeleted. This uses +;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal +;;; an error. +;;; +(defun dired-frob-deletion (patternp deletep) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (with-mark ((mark (current-point) :left-inserting)) + (let* ((dir-info (value dired-information)) + (files (dired-info-files dir-info)) + (del-files + (if patternp + (dired:pathnames-from-pattern + (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t) + (dired-info-file-list dir-info)) + (list (dired-file-pathname + (array-element-from-mark mark files))))) + (note-char (if deletep #\D #\space))) + (with-writable-buffer ((current-buffer)) + (dolist (f del-files) + (let* ((pos (position f files :test #'equal + :key #'dired-file-pathname)) + (dired-file (svref files pos))) + (buffer-start mark) + (line-offset mark pos 0) + (setf (dired-file-deleted-p dired-file) deletep) + (if deletep + (setf (dired-file-write-date dired-file) + (file-write-date (dired-file-pathname dired-file))) + (setf (dired-file-write-date dired-file) nil)) + (setf (next-character mark) note-char))))))) + +(defun dired-down-line (point) + (line-offset point 1) + (when (blank-line-p (mark-line point)) + (line-offset point -1))) + + + + +;;;; Dired file finding and going to dired buffers. + +(defcommand "Dired Edit File" (p) + "Read in file or recursively \"Dired\" a directory." + "Read in file or recursively \"Dired\" a directory." + (declare (ignore p)) + (let ((point (current-point))) + (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) + (let ((pathname (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information)))))) + (if (directoryp pathname) + (dired-command nil (directory-namestring pathname)) + (change-to-buffer (find-file-buffer pathname)))))) + +(defcommand "Dired View File" (p) + "Read in file as if by \"View File\" or recursively \"Dired\" a directory. + This associates the file's buffer with the dired buffer." + "Read in file as if by \"View File\". + This associates the file's buffer with the dired buffer." + (declare (ignore p)) + (let ((point (current-point))) + (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) + (let ((pathname (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information)))))) + (if (directoryp pathname) + (dired-command nil (directory-namestring pathname)) + (let* ((dired-buf (current-buffer)) + (buffer (view-file-command nil pathname))) + (push #'(lambda (buffer) + (declare (ignore buffer)) + (setf dired-buf nil)) + (buffer-delete-hook dired-buf)) + (setf (variable-value 'view-return-function :buffer buffer) + #'(lambda () + (if dired-buf + (change-to-buffer dired-buf) + (dired-from-buffer-pathname-command nil))))))))) + +(defcommand "Dired from Buffer Pathname" (p) + "Invokes \"Dired\" on the directory part of the current buffer's pathname. + With an argument, also prompt for a file pattern within that directory." + "Invokes \"Dired\" on the directory part of the current buffer's pathname. + With an argument, also prompt for a file pattern within that directory." + (let ((pathname (buffer-pathname (current-buffer)))) + (if pathname + (dired-command p (directory-namestring pathname)) + (editor-error "No pathname associated with buffer.")))) + +(defcommand "Dired Up Directory" (p) + "Invokes \"Dired\" on the directory up one level from the current Dired + buffer." + "Invokes \"Dired\" on the directory up one level from the current Dired + buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (let ((dirs (or (pathname-directory + (dired-info-pathname (value dired-information))) + '(:relative)))) + (dired-command nil + (truename (make-pathname :directory (nconc dirs '(:UP))))))) + + + + +;;;; Dired misc. commands -- update, help, line motion. + +(defcommand "Dired Update Buffer" (p) + "Recompute the contents of a dired buffer. + This maintains delete flags for files that have not been modified." + "Recompute the contents of a dired buffer. + This maintains delete flags for files that have not been modified." + (declare (ignore p)) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (let ((buffer (current-buffer)) + (dir-info (value dired-information))) + (update-dired-buffer (dired-info-pathname dir-info) + (dired-info-pattern dir-info) + buffer))) + +;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting +;;; whatever is in the buffer already. This assumes buffer was previously +;;; used as a dired buffer having necessary variables bound. The new files +;;; are compared to the old ones propagating any deleted flags if the name +;;; and the write date is the same for both specifications. +;;; +(defun update-dired-buffer (directory pattern buffer) + (with-writable-buffer (buffer) + (delete-region (buffer-region buffer)) + (let ((dir-info (variable-value 'dired-information :buffer buffer))) + (multiple-value-bind (pathnames new-dired-files) + (dired-in-buffer directory pattern + (dired-info-dot-files-p dir-info) + buffer) + (let ((point (buffer-point buffer)) + (old-dired-files (dired-info-files dir-info))) + (declare (simple-vector old-dired-files)) + (dotimes (i (length old-dired-files)) + (let ((old-file (svref old-dired-files i))) + (when (dired-file-deleted-p old-file) + (let ((pos (position (dired-file-pathname old-file) + new-dired-files :test #'equal + :key #'dired-file-pathname))) + (when pos + (let* ((new-file (svref new-dired-files pos)) + (write-date (file-write-date + (dired-file-pathname new-file)))) + (when (= (dired-file-write-date old-file) write-date) + (setf (dired-file-deleted-p new-file) t) + (setf (dired-file-write-date new-file) write-date) + (setf (next-character + (line-offset (buffer-start point) pos 0)) + #\D)))))))) + (setf (dired-info-files dir-info) new-dired-files) + (setf (dired-info-file-list dir-info) pathnames) + (setf (dired-info-write-date dir-info) + (file-write-date directory)) + (move-mark point (buffer-start-mark buffer))))))) + +;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning +;;; two values: a list of pathnames of files only, and an array of dired-file +;;; structures. This uses FILTER-REGION to insert a space for the indication +;;; of whether the file is flagged for deletion. Then we clean up extra header +;;; and trailing lines known to be in the output (into every code a little +;;; slime must fall). +;;; +(defun dired-in-buffer (directory pattern dot-files-p buffer) + (let ((point (buffer-point buffer))) + (with-writable-buffer (buffer) + (let* ((pathnames (call-print-directory + (if pattern + (merge-pathnames directory pattern) + directory) + point + dot-files-p)) + (dired-files (make-array (length pathnames)))) + (declare (list pathnames) (simple-vector dired-files)) + (filter-region #'(lambda (str) + (concatenate 'simple-string " " str)) + (buffer-region buffer)) + (delete-characters point -2) + (delete-region (line-to-region (mark-line (buffer-start point)))) + (delete-characters point) + (do ((p pathnames (cdr p)) + (i 0 (1+ i))) + ((null p)) + (setf (svref dired-files i) (make-dired-file (car p)))) + (values (delete-if #'directoryp pathnames) dired-files))))) + + +(defcommand "Dired Help" (p) + "How to use dired." + "How to use dired." + (declare (ignore p)) + (describe-mode-command nil "Dired")) + +(defcommand "Dired Next File" (p) + "Moves to next undeleted file." + "Moves to next undeleted file." + (unless (dired-line-offset (current-point) (or p 1)) + (editor-error "Not enough lines."))) + +(defcommand "Dired Previous File" (p) + "Moves to previous undeleted file." + "Moves to next undeleted file." + (unless (dired-line-offset (current-point) (or p -1)) + (editor-error "Not enough lines."))) + +;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark. If +;;; there are not enough lines, mark remains unmoved, this returns nil. +;;; +(defun dired-line-offset (mark n) + (with-mark ((m mark)) + (let ((step (if (plusp n) 1 -1))) + (dotimes (i (abs n) (move-mark mark m)) + (loop + (unless (line-offset m step 0) + (return-from dired-line-offset nil)) + (when (blank-line-p (mark-line m)) + (return-from dired-line-offset nil)) + (when (char= (next-character m) #\space) + (return))))))) + + + + +;;;; Dired user interaction functions. + +(defun dired-error-function (string &rest args) + (apply #'editor-error string args)) + +(defun dired-report-function (string &rest args) + (clear-echo-area) + (apply #'message string args)) + +(defun dired-yesp-function (string &rest args) + (prompt-for-y-or-n :prompt (cons string args) :default t)) + + + + +;;;; Dired expunging and quitting. + +(defcommand "Dired Expunge Files" (p) + "Expunges files marked for deletion. + Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do + the same with directories and the value of \"Dired Directory Expunge + Confirm\"." + "Expunges files marked for deletion. + Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do + the same with directories and the value of \"Dired Directory Expunge + Confirm\"." + (declare (ignore p)) + (when (expunge-dired-files) + (dired-update-buffer-command nil)) + (maintain-dired-consistency)) + +(defcommand "Dired Quit" (p) + "Expunges the files in a dired buffer and then exits." + "Expunges the files in a dired buffer and then exits." + (declare (ignore p)) + (expunge-dired-files) + (delete-buffer-if-possible (current-buffer))) + +(defhvar "Dired File Expunge Confirm" + "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask + for confirmation before deleting the marked files." + :value t) + +(defhvar "Dired Directory Expunge Confirm" + "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask + for confirmation before deleting each marked directory." + :value t) + +(defun expunge-dired-files () + (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files) + (let ((dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function) + (we-did-something nil)) + (when (and marked-files + (or (not (value dired-file-expunge-confirm)) + (prompt-for-y-or-n :prompt "Really delete files? " + :default t + :must-exist t + :default-string "Y"))) + (setf we-did-something t) + (dolist (file-info marked-files) + (let ((pathname (car file-info)) + (write-date (cdr file-info))) + (if (= write-date (file-write-date pathname)) + (dired:delete-file (namestring pathname) :clobber t + :recursive nil) + (message "~A has been modified, it remains unchanged." + (namestring pathname)))))) + (when marked-dirs + (dolist (dir-info marked-dirs) + (let ((dir (car dir-info)) + (write-date (cdr dir-info))) + (if (= write-date (file-write-date dir)) + (when (or (not (value dired-directory-expunge-confirm)) + (prompt-for-y-or-n + :prompt (list "~a is a directory. Delete it? " + (directory-namestring dir)) + :default t + :must-exist t + :default-string "Y")) + (dired:delete-file (directory-namestring dir) :clobber t + :recursive t) + (setf we-did-something t)) + (message "~A has been modified, it remains unchanged."))))) + we-did-something))) + + + + +;;;; Dired copying and renaming. + +(defhvar "Dired Copy File Confirm" + "Can be either t, nil, or :update. T means always query before clobbering an + existing file, nil means don't query before clobbering an existing file, and + :update means only ask if the existing file is newer than the source." + :value T) + +(defhvar "Dired Rename File Confirm" + "When non-nil, dired will query before clobbering an existing file." + :value T) + +(defcommand "Dired Copy File" (p) + "Copy the file under the point" + "Copy the file under the point" + (declare (ignore p)) + (let* ((point (current-point)) + (confirm (value dired-copy-file-confirm)) + (source (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information))))) + (dest (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:copy-file source dest :update (if (eq confirm :update) t nil) + :clobber (not confirm))) + (maintain-dired-consistency)) + +(defcommand "Dired Rename File" (p) + "Rename the file or directory under the point" + "Rename the file or directory under the point" + (declare (ignore p)) + (let* ((point (current-point)) + (source (dired-namify (dired-file-pathname + (array-element-from-mark + point + (dired-info-files (value dired-information)))))) + (dest (prompt-for-file + :prompt "New Filename: " + :help "The new name for this file." + :default source + :must-exist nil)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start. + (dired:rename-file source dest :clobber (value dired-rename-file-confirm))) + (maintain-dired-consistency)) + +(defcommand "Dired Copy with Wildcard" (p) + "Copy files that match a pattern containing ONE wildcard." + "Copy files that match a pattern containing ONE wildcard." + (declare (ignore p)) + (let* ((dir-info (value dired-information)) + (confirm (value dired-copy-file-confirm)) + (pattern (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t)) + (destination (namestring + (prompt-for-file + :prompt "Destination Spec: " + :help "Destination spec. May contain ONE asterisk." + :default (dired-info-pathname dir-info) + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*yesp-function* #'dired-yesp-function) + (dired:*report-function* #'dired-report-function)) + (dired:copy-file pattern destination :update (if (eq confirm :update) t nil) + :clobber (not confirm) + :directory (dired-info-file-list dir-info))) + (maintain-dired-consistency)) + +(defcommand "Dired Rename with Wildcard" (p) + "Rename files that match a pattern containing ONE wildcard." + "Rename files that match a pattern containing ONE wildcard." + (declare (ignore p)) + (let* ((dir-info (value dired-information)) + (pattern (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t)) + (destination (namestring + (prompt-for-file + :prompt "Destination Spec: " + :help "Destination spec. May contain ONE asterisk." + :default (dired-info-pathname dir-info) + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*yesp-function* #'dired-yesp-function) + (dired:*report-function* #'dired-report-function)) + (dired:rename-file pattern destination + :clobber (not (value dired-rename-file-confirm)) + :directory (dired-info-file-list dir-info))) + (maintain-dired-consistency)) + +(defcommand "Delete File" (p) + "Delete a file. Specify directories with a trailing slash." + "Delete a file. Specify directories with a trailing slash." + (declare (ignore p)) + (let* ((spec (namestring + (prompt-for-file + :prompt "Delete File: " + :help '("Name of File or Directory to delete. ~ + One wildcard is permitted.") + :must-exist nil))) + (directoryp (directoryp spec)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (when (or (not directoryp) + (not (value dired-directory-expunge-confirm)) + (prompt-for-y-or-n + :prompt (list "~A is a directory. Delete it? " + (directory-namestring spec)) + :default t :must-exist t :default-string "Y"))) + (dired:delete-file spec :recursive t + :clobber (or directoryp + (value dired-file-expunge-confirm)))) + (maintain-dired-consistency)) + +(defcommand "Copy File" (p) + "Copy a file, allowing ONE wildcard." + "Copy a file, allowing ONE wildcard." + (declare (ignore p)) + (let* ((confirm (value dired-copy-file-confirm)) + (source (namestring + (prompt-for-file + :prompt "Source Filename: " + :help "Name of File to copy. One wildcard is permitted." + :must-exist nil))) + (dest (namestring + (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:copy-file source dest :update (if (eq confirm :update) t nil) + :clobber (not confirm))) + (maintain-dired-consistency)) + +(defcommand "Rename File" (p) + "Rename a file, allowing ONE wildcard." + "Rename a file, allowing ONE wildcard." + (declare (ignore p)) + (let* ((source (namestring + (prompt-for-file + :prompt "Source Filename: " + :help "Name of file to rename. One wildcard is permitted." + :must-exist nil))) + (dest (namestring + (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:rename-file source dest + :clobber (not (value dired-rename-file-confirm)))) + (maintain-dired-consistency)) + +(defun maintain-dired-consistency () + (dolist (info *pathnames-to-dired-buffers*) + (let* ((directory (directory-namestring (car info))) + (buffer (cdr info)) + (dir-info (variable-value 'dired-information :buffer buffer)) + (write-date (file-write-date directory))) + (unless (= (dired-info-write-date dir-info) write-date) + (update-dired-buffer directory (dired-info-pattern dir-info) buffer))))) + + + + +;;;; Dired utilities. + +;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs +;;; and a list of directory specs that have been marked for deletion. This +;;; assumes the current buffer is a "Dired" buffer. +;;; +(defun get-marked-dired-files () + (let* ((files (dired-info-files (value dired-information))) + (length (length files)) + (marked-files ()) + (marked-dirs ())) + (unless files (editor-error "Not in Dired buffer.")) + (do ((i 0 (1+ i))) + ((= i length) (values (nreverse marked-files) (nreverse marked-dirs))) + (let* ((thing (svref files i)) + (pathname (dired-file-pathname thing))) + (when (and (dired-file-deleted-p thing) ; file marked for delete + (probe-file pathname)) ; file still exists + (if (directoryp pathname) + (push (cons pathname (file-write-date pathname)) marked-dirs) + (push (cons pathname (file-write-date pathname)) + marked-files))))))) + +;;; ARRAY-ELEMENT-FROM-MARK -- Internal Interface. +;;; +;;; This counts the lines between it and the beginning of the buffer. The +;;; number is used to index vector as if each line mapped to an element +;;; starting with the zero'th element (lines are numbered starting at 1). +;;; This must use AREF since some modes use this with extendable vectors. +;;; +(defun array-element-from-mark (mark vector + &optional (error-msg "Invalid line.")) + (when (blank-line-p (mark-line mark)) (editor-error error-msg)) + (aref vector + (1- (count-lines (region + (buffer-start-mark (line-buffer (mark-line mark))) + mark))))) + +;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime. +;;; +(defun dired-namify (pathname) + (let* ((string (namestring pathname)) + (last (1- (length string)))) + (if (char= (schar string last) #\/) + (subseq string 0 last) + string))) +;;; +;;; This is necessary to derive a canonical representation for directory +;;; names, so "Dired" can map various strings naming one directory to that +;;; one directory. +;;; +(defun dired-directorify (pathname) + (let ((directory (ext:unix-namestring pathname))) + (if (directoryp directory) + directory + (pathname (concatenate 'simple-string (namestring directory) "/"))))) + + + + +;;;; View Mode. + +(defmode "View" :major-p nil + :setup-function 'setup-view-mode + :cleanup-function 'cleanup-view-mode + :precedence 5.0 + :documentation + "View mode scrolls forwards and backwards in a file with the buffer read-only. + Scrolling off the end optionally deletes the buffer.") + +(defun setup-view-mode (buffer) + (defhvar "View Return Function" + "Function that gets called when quitting or returning from view mode." + :value nil + :buffer buffer) + (setf (buffer-writable buffer) nil)) +;;; +(defun cleanup-view-mode (buffer) + (delete-variable 'view-return-function :buffer buffer) + (setf (buffer-writable buffer) t)) + +(defcommand "View File" (p &optional pathname) + "Reads a file in as if by \"Find File\", but read-only. Commands exist + for scrolling convenience." + "Reads a file in as if by \"Find File\", but read-only. Commands exist + for scrolling convenience." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file + :prompt "View File: " :must-exist t + :help "Name of existing file to read into its own buffer." + :default (buffer-default-pathname (current-buffer))))) + (buffer (make-buffer (format nil "View File ~A" (gensym))))) + (visit-file-command nil pn buffer) + (setf (buffer-minor-mode buffer "View") t) + (change-to-buffer buffer) + buffer)) + +(defcommand "View Return" (p) + "Return to a parent buffer, if it exists." + "Return to a parent buffer, if it exists." + (declare (ignore p)) + (unless (call-view-return-fun) + (editor-error "No View return method for this buffer."))) + +(defcommand "View Quit" (p) + "Delete a buffer in view mode." + "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for + this buffer." + (declare (ignore p)) + (let* ((buf (current-buffer)) + (funp (call-view-return-fun))) + (delete-buffer-if-possible buf) + (unless funp (editor-error "No View return method for this buffer.")))) + +;;; CALL-VIEW-RETURN-FUN returns nil if there is no current +;;; view-return-function. If there is one, it calls it and returns t. +;;; +(defun call-view-return-fun () + (if (hemlock-bound-p 'view-return-function) + (let ((fun (value view-return-function))) + (cond (fun + (funcall fun) + t))))) + + +(defhvar "View Scroll Deleting Buffer" + "When this is set, \"View Scroll Down\" deletes the buffer when the end + of the file is visible." + :value t) + +(defcommand "View Scroll Down" (p) + "Scroll the current window down through its buffer. + If the end of the file is visible, then delete the buffer if \"View Scroll + Deleting Buffer\" is set. If the buffer is associated with a dired buffer, + this returns there instead of to the previous buffer." + "Scroll the current window down through its buffer. + If the end of the file is visible, then delete the buffer if \"View Scroll + Deleting Buffer\" is set. If the buffer is associated with a dired buffer, + this returns there instead of to the previous buffer." + (if (and (not p) + (displayed-p (buffer-end-mark (current-buffer)) + (current-window)) + (value view-scroll-deleting-buffer)) + (view-quit-command nil) + (scroll-window-down-command p))) + +(defcommand "View Edit File" (p) + "Turn off \"View\" mode in this buffer." + "Turn off \"View\" mode in this buffer." + (declare (ignore p)) + (let ((buf (current-buffer))) + (setf (buffer-minor-mode buf "View") nil) + (warn-about-visit-file-buffers buf))) + +(defcommand "View Help" (p) + "Shows \"View\" mode help message." + "Shows \"View\" mode help message." + (declare (ignore p)) + (describe-mode-command nil "View")) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/display.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/display.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/display.lisp (revision 8058) @@ -0,0 +1,310 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; +;;; This is the device independent redisplay entry points for Hemlock. +;;; + +(in-package :hemlock-internals) + + + +;;;; Main redisplay entry points. + +(defvar *things-to-do-once* () + "This is a list of lists of functions and args to be applied to. The + functions are called with args supplied at the top of the command loop.") + +(defvar *screen-image-trashed* () + "This variable is set to true if the screen has been trashed by some screen + manager operation, and thus should be totally refreshed. This is currently + only used by tty redisplay.") + +;;; True if we are in redisplay, and thus don't want to enter it recursively. +;;; +(defvar *in-redisplay* nil) + +(declaim (special *window-list*)) + +(eval-when (:compile-toplevel :execute) + +;;; REDISPLAY-LOOP -- Internal. +;;; +;;; This executes internal redisplay routines on all windows interleaved with +;;; checking for input, and if any input shows up we punt returning +;;; :editor-input. Special-fun is for windows that the redisplay interface +;;; wants to recenter to keep the window's buffer's point visible. General-fun +;;; is for other windows. +;;; +;;; Whenever we invoke one of the internal routines, we keep track of the +;;; non-nil return values, so we can return t when we are done. Returning t +;;; means redisplay should run again to make sure it converged. To err on the +;;; safe side, if any window had any changed lines, then let's go through +;;; redisplay again; that is, return t. +;;; +;;; After checking each window, we put the cursor in the appropriate place and +;;; force output. When we try to position the cursor, it may no longer lie +;;; within the window due to buffer modifications during redisplay. If it is +;;; out of the window, return t to indicate we need to finish redisplaying. +;;; +;;; Then we check for the after-redisplay method. Routines such as REDISPLAY +;;; and REDISPLAY-ALL want to invoke the after method to make sure we handle +;;; any events generated from redisplaying. There wouldn't be a problem with +;;; handling these events if we were going in and out of Hemlock's event +;;; handling, but some user may loop over one of these interface functions for +;;; a long time without going through Hemlock's input loop; when that happens, +;;; each call to redisplay may not result in a complete redisplay of the +;;; device. Routines such as INTERNAL-REDISPLAY don't want to worry about this +;;; since Hemlock calls them while going in and out of the input/event-handling +;;; loop. +;;; +;;; Around all of this, we establish the 'redisplay-catcher tag. Some device +;;; redisplay methods throw to this to abort redisplay in addition to this +;;; code. +;;; +(defmacro redisplay-loop (general-fun special-fun &optional (afterp t)) + (let* ((device (gensym)) (point (gensym)) (hunk (gensym)) (n-res (gensym)) + (win-var (gensym)) + (general-form (if (symbolp general-fun) + `(,general-fun ,win-var) + `(funcall ,general-fun ,win-var))) + (special-form (if (symbolp special-fun) + `(,special-fun ,win-var) + `(funcall ,special-fun ,win-var)))) + `(let ((,n-res nil) + (*in-redisplay* t)) + (catch 'redisplay-catcher + (when (listen-editor-input *real-editor-input*) + (throw 'redisplay-catcher :editor-input)) + (let ((,win-var *current-window*)) + (when ,special-form (setf ,n-res t))) + (dolist (,win-var *window-list*) + (unless (eq ,win-var *current-window*) + (when (listen-editor-input *real-editor-input*) + (throw 'redisplay-catcher :editor-input)) + (when (if (window-display-recentering ,win-var) + ,special-form + ,general-form) + (setf ,n-res t)))) + (let* ((,hunk (window-hunk *current-window*)) + (,device (device-hunk-device ,hunk)) + (,point (window-point *current-window*))) + (move-mark ,point (buffer-point (window-buffer *current-window*))) + (multiple-value-bind (x y) + (mark-to-cursorpos ,point *current-window*) + (if x + (funcall (device-put-cursor ,device) ,hunk x y) + (setf ,n-res t))) + (when (device-force-output ,device) + (funcall (device-force-output ,device))) + ,@(if afterp + `((when (device-after-redisplay ,device) + (funcall (device-after-redisplay ,device) ,device) + ;; The after method may have queued input that the input + ;; loop won't see until the next input arrives, so check + ;; here to return the correct value as per the redisplay + ;; contract. + (when (listen-editor-input *real-editor-input*) + (setf ,n-res :editor-input))))) + ,n-res))))) + +) ;eval-when + + +;;; REDISPLAY -- Public. +;;; +;;; This function updates the display of all windows which need it. It assumes +;;; it's internal representation of the screen is accurate and attempts to do +;;; the minimal amount of output to bring the screen into correspondence. +;;; *screen-image-trashed* is only used by terminal redisplay. +;;; +(defun redisplay () + "The main entry into redisplay; updates any windows that seem to need it." + (when *things-to-do-once* + (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) + (setf *things-to-do-once* nil)) + (cond (*in-redisplay* t) + (*screen-image-trashed* + (when (eq (redisplay-all) t) + (setf *screen-image-trashed* nil) + t)) + (t + (redisplay-loop redisplay-window redisplay-window-recentering)))) + + +;;; REDISPLAY-ALL -- Public. +;;; +;;; Update the screen making no assumptions about its correctness. This is +;;; useful if the screen gets trashed, or redisplay gets lost. Since windows +;;; may be on different devices, we have to go through the list clearing all +;;; possible devices. Always returns T or :EDITOR-INPUT, never NIL. +;;; +(defun redisplay-all () + "An entry into redisplay; causes all windows to be fully refreshed." + (let ((cleared-devices nil)) + (dolist (w *window-list*) + (let* ((hunk (window-hunk w)) + (device (device-hunk-device hunk))) + (unless (member device cleared-devices :test #'eq) + (when (device-clear device) + (funcall (device-clear device) device)) + ;; + ;; It's cleared whether we did clear it or there was no method. + (push device cleared-devices))))) + (redisplay-loop + redisplay-window-all + #'(lambda (window) + (setf (window-tick window) (tick)) + (update-window-image window) + (maybe-recenter-window window) + (funcall (device-dumb-redisplay + (device-hunk-device (window-hunk window))) + window) + t))) + + + + +;;;; Internal redisplay entry points. + +(defun internal-redisplay () + "The main internal entry into redisplay. This is just like REDISPLAY, but it + doesn't call the device's after-redisplay method." + (when *things-to-do-once* + (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) + (setf *things-to-do-once* nil)) + (cond (*in-redisplay* t) + (*screen-image-trashed* + (when (eq (redisplay-all) t) + (setf *screen-image-trashed* nil) + t)) + (t + (redisplay-loop redisplay-window redisplay-window-recentering)))) + +;;; REDISPLAY-WINDOWS-FROM-MARK -- Internal Interface. +;;; +;;; hemlock-output-stream methods call this to update the screen. It only +;;; redisplays windows which are displaying the buffer concerned and doesn't +;;; deal with making the cursor track the point. *screen-image-trashed* is +;;; only used by terminal redisplay. This must call the device after-redisplay +;;; method since stream output may occur without ever returning to the +;;; Hemlock input/event-handling loop. +;;; +(defun redisplay-windows-from-mark (mark) + (when *things-to-do-once* + (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing))) + (setf *things-to-do-once* nil)) + (cond ((or *in-redisplay* (not *in-the-editor*)) t) + ((listen-editor-input *real-editor-input*) :editor-input) + (*screen-image-trashed* + (when (eq (redisplay-all) t) + (setf *screen-image-trashed* nil) + t)) + (t + (catch 'redisplay-catcher + (let ((buffer (line-buffer (mark-line mark)))) + (when buffer + (flet ((frob (win) + (let* ((device (device-hunk-device (window-hunk win))) + (force (device-force-output device)) + (after (device-after-redisplay device))) + (when force (funcall force)) + (when after (funcall after device))))) + (let ((windows (buffer-windows buffer))) + (when (member *current-window* windows :test #'eq) + (redisplay-window-recentering *current-window*) + (frob *current-window*)) + (dolist (window windows) + (unless (eq window *current-window*) + (redisplay-window window) + (frob window))))))))))) + +;;; REDISPLAY-WINDOW -- Internal. +;;; +;;; Return t if there are any changed lines, nil otherwise. +;;; +(defun redisplay-window (window) + "Maybe updates the window's image and calls the device's smart redisplay + method. NOTE: the smart redisplay method may throw to + 'hi::redisplay-catcher to abort redisplay." + (maybe-update-window-image window) + (prog1 + (not (eq (window-first-changed window) *the-sentinel*)) + (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) + window))) + +(defun redisplay-window-all (window) + "Updates the window's image and calls the device's dumb redisplay method." + (setf (window-tick window) (tick)) + (update-window-image window) + (funcall (device-dumb-redisplay (device-hunk-device (window-hunk window))) + window) + t) + +(defun random-typeout-redisplay (window) + (catch 'redisplay-catcher + (maybe-update-window-image window) + (let* ((device (device-hunk-device (window-hunk window))) + (force (device-force-output device))) + (funcall (device-smart-redisplay device) window) + (when force (funcall force))))) + + + +;;;; Support for redisplay entry points. + +;;; REDISPLAY-WINDOW-RECENTERING -- Internal. +;;; +;;; This tries to be clever about updating the window image unnecessarily, +;;; recenters the window if the window's buffer's point moved off the window, +;;; and does a smart redisplay. We call the redisplay method even if we didn't +;;; update the image or recenter because someone else may have modified the +;;; window's image and already have updated it; if nothing happened, then the +;;; smart method shouldn't do anything anyway. NOTE: the smart redisplay +;;; method may throw to 'hi::redisplay-catcher to abort redisplay. +;;; +;;; This return t if there are any changed lines, nil otherwise. +;;; +(defun redisplay-window-recentering (window) + (setup-for-recentering-redisplay window) + (invoke-hook hemlock::redisplay-hook window) + (setup-for-recentering-redisplay window) + (prog1 + (not (eq (window-first-changed window) *the-sentinel*)) + (funcall (device-smart-redisplay (device-hunk-device (window-hunk window))) + window))) + +(defun setup-for-recentering-redisplay (window) + (let* ((display-start (window-display-start window)) + (old-start (window-old-start window))) + ;; + ;; If the start is in the middle of a line and it wasn't before, + ;; then move the start there. + (when (and (same-line-p display-start old-start) + (not (start-line-p display-start)) + (start-line-p old-start)) + (line-start display-start)) + (maybe-update-window-image window) + (maybe-recenter-window window))) + + +;;; MAYBE-UPDATE-WINDOW-IMAGE only updates if the text has changed or the +;;; display start. +;;; +(defun maybe-update-window-image (window) + (when (or (> (buffer-modified-tick (window-buffer window)) + (window-tick window)) + (mark/= (window-display-start window) + (window-old-start window))) + (setf (window-tick window) (tick)) + (update-window-image window) + t)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/dylan.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/dylan.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/dylan.lisp (revision 8058) @@ -0,0 +1,66 @@ +;;; -*- Package: hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains a minimal dylan mode. +;;; +(in-package :hemlock) + +;;; hack .. + +(setf (getstring "dylan" *mode-names*) nil) + + +(defmode "Dylan" :major-p t) +(defcommand "Dylan Mode" (p) + "Put the current buffer into \"Dylan\" mode." + "Put the current buffer into \"Dylan\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Dylan")) + +(define-file-type-hook ("dylan") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Dylan")) + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It must take one argument that is the prefix argument." + :value #'generic-indent + :mode "Dylan") + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\"." + :mode "Dylan" :value t) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :mode "Dylan" :value "//") + +(defhvar "Comment End" + "String that ends comments. Nil indicates #\newline termination." + :mode "Dylan" :value nil) + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :mode "Dylan" :value "// ") + +(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" + :mode "Dylan") +(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Dylan") + +;;; hacks... + +(shadow-attribute :scribe-syntax #\< nil "Dylan") +(shadow-attribute :scribe-syntax #\> nil "Dylan") +(bind-key "Self Insert" #k"\>" :mode "Dylan") +(bind-key "Scribe Insert Bracket" #k")" :mode "Dylan") +(bind-key "Scribe Insert Bracket" #k"]" :mode "Dylan") +(bind-key "Scribe Insert Bracket" #k"}" :mode "Dylan") Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/README =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/README (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/README (revision 8058) @@ -0,0 +1,52 @@ +This is currently a work-in-progess. + +The aim is to build an environment taht lets most elisp packages run inside +PHemlock. Two things that explicitly will not be handled is "emacs sockets" +and "emacs sub-processes". There may be stubs for them, actuallym, there +will probably be stubs for them. + +Currently, most of the code is horribly uncommented and there's next-to-no +docstrings. This will be fixed, at some point. + +The current files in the implementation, with a description of my +generals thoughts of what should go where: + +base.lisp: This is the "base elisp" implementation. Things here end up + in the ELISP package and should in general be "user visible". + +codewalker.lisp: This is a code walker necessary to wrap "variable + access". It's not the most well-tested piece of code in the + world, but so far it hasn't fallen over on my test cases. + +hemlock-shims.lisp: This is functions that need to interact deeply + with Hemlock (key definitions etc, etc). + +internals.lisp: This is the file for what ends up being needed but not + fitting anywhere else. + +loadup.lisp: Load all files, in something approaching a sensible order. + +packages.lisp: Package definitions. + +read-table.lisp: Readtables and support functions. + +implementation-needed: Contains a tentative list of symbols in GNU + Emacs that may or may not need sensible implementation before + we're done. Theory is, once all built-ins are in place, we can + then bootstrap off whatever files tag along with emacs, should + anyone want to. + +Here are some things to look at before releasing: +[new-bbox] +|Warning: These variables are undefined: +| MAJOR-MODE MODE-NAME +| +| +|Warning: These functions are undefined: +| DEFINE-KEY GET-BUFFER-CREATE MAKE-SPARSE-KEYMAP SET-BUFFER SWITCH-TO-BUFFER +| USE-LOCAL-MAP + + + + +//Ingvar Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/base.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/base.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/base.lisp (revision 8058) @@ -0,0 +1,260 @@ +(in-package "ELISP") + +(defvar load-path nil) +(defvar features nil) +(defvar *buffer-locals* (make-hash-table)) +(defvar *current-buffer* nil) +(define-symbol-macro major-mode (buffer-major-mode (current-buffer))) + + +(cl:defun make-sparse-keymap (&optional string) + (if string + (list 'keymap string) + (list 'keymap))) + +(cl:defun make-keymap (&optional string) + (if string + (list 'keymap string (make-vector 256)) + (list 'keymap (make-vector 256)))) + +(cl:defun make-sparse-keymap (&optional string) + (if string + (list 'keymap string) + (list 'keymap))) + +(cl:defun buffer-local-p (sym) + (multiple-value-bind (expansion expanded) (macroexpand sym) + (declare (ignore expansion)) + expanded)) + +(cl:defun elisp-value (sym) + (cl:let ((marker (gensym))) + (multiple-value-bind (value exists) + (gethash sym *buffer-locals*) + (if exists + (hemlock::variable-value sym) + (eval sym))))) + +(cl:defun = (a b) + (cond ((and (characterp a) (characterp b)) + (char= a b)) + ((and (numberp a) (characterp b)) + (cl:= a (char-code b))) + ((and (characterp a) (numberp b)) + (cl:= (char-code a) b)) + ((and (numberp a) (numberp b)) + (cl:= a b)) + (t (error "Wrong type argument ~a" (if (or (numberp a) (characterp a)) + b + a))))) + +(cl:defun make-variable-buffer-local (sym) + (make-variable-foo-local sym :buffer)) + +(cl:defun make-variable-foo-local (sym kind) + "MAKE-VARIABLES-BUFFER-LOCAL +Arguments SYMBOL + +Will make a variable buffer-local UNLESS it has prior special binding, +this may be a grave incompatibility with Emacs Lisp. + +In a buffer where no dedicated value has been set, will use the +default-value. The default value is set with SET-DEFAULT." + (unless (hemlock::hemlock-bound-p sym) + (setf (gethash sym *buffer-locals*) kind) + (defhvar sym "Variable automatically set from ELISP" :mode :kind) + )) + + +;;; Troublesome? Looks like it IM -- 2003-04-05 +(cl:defun set-default (sym value) + "SET-DEFAULT +Args: SYMBOL VALUE + +Will set the default value of (the buffer-local) SYMBOL to VALUE" + (if (buffer-local-p sym) + (setf (gethash *buffer-locals* (gethash sym *buffer-locals*)) value) + (set sym value))) + +;;; Troublesome? Looks like it IM -- 2003-04-05 +(cl:defun get-default (sym) + "GET-DEFAULT +Args: SYMBOL + +Returns the default value for SYMBOL" + (if (buffer-local-p sym) + (gethash *buffer-locals* (gethash sym *buffer-locals*)) + (symbol-value sym))) + +(cl:defmacro interactive (&rest spec) + (declare (ignore spec)) + nil) + +;;; This really should generate a glue function to handle the differences +;;; betwen emacs command calling conventions and Hemlock ccc. +;;; Basically, what we need is a layer that does all the prompting that +;;; would've been done on an interactive call in emacs. Probably simplest +;;; to just generate a lambda with the right stuff prompted for, then have +;;; that call the function proper. +(cl:defmacro defun (name args &body body) + (cl:let ((real-args (elisp-internals:find-lambda-list-variables args)) + (body (walk-code `(defun ,name ,args ,@body))) + (maybe-docstring (car body)) + (interactive-p (member 'interactive body :key #'(lambda (x) (when (consp x) (car x)))))) + (if interactive-p + `(prog1 + (cl:defun ,name ,args + (declare (special ,@real-args)) + ,@(cdddr body)) + (make-command ,(string-downcase (string name)) + ,(if (stringp maybe-docstring) + maybe-docstring + (format nil "This implements the elisp command for function ~a." (string name))) ,(elisp-internals:interactive-glue (cadr (car interactive-p)) name))) + + `(cl:defun ,name ,args + (declare (special ,@real-args)) + ,@(cdddr body))))) + +(cl:defmacro let (inits &body body) + (cl:let ((vars (loop for var in inits + collect (cl:if (symbolp var) var (car var))))) + `(cl:let ,inits + (declare (special ,@vars)) + ,@body))) + +(cl:defmacro if (test true &rest falses) + `(cl:if ,test ,true (progn ,@falses))) + +(cl:defmacro lexical-let (&rest body) + `(cl:let ,@body )) + +(cl:defmacro setq (&rest rest) + `(cl:setf ,@rest)) + +(cl:defun provide (feature) + (cl:push feature features)) + +(cl:defun require (feature &optional filename noerror) + (let ((*readtable* elisp-internals:*elisp-readtable*)) + (or + (car (member feature features)) + (loop for directory in load-path + if (elisp-internals:require-load directory feature filename) + return feature) + (unless noerror + (error "Cannot open file ~a." (if filename + filename + (cl:string-downcase feature))))))) + +;; Done via CL:DEFUN since the code walker wreaks havoc with the loop macro. +;; Keep these together for sanity's sake +(cl:defun load-library (library-name) + (loop for directory in load-path + do (loop for ext in '(".el" "") + for name = (format nil "~a/~a~a" directory library-name ext) + if (cl:probe-file name) + do (return-from load-library + (let (*package* (find-package "ELISP-USER")) + (let ((*readtable* elisp-internals:*elisp-readtable*)) + (cl:load name))))))) + +(cl:defun load-file (filename) + (let ((*readtable* elisp-internals:*elisp-readtable*) + (*package* (find-package "ELISP-USER"))) + (load filename))) + +(make-command "load-file" "Load a file, elisp style" #'(lambda (p) (declare (ignore p)) (load-file (hemlock-internals:prompt-for-file :prompt "Load file: ")))) +(make-command "load-library" "Load a library, elisp-style" #'(lambda (p) (declare (ignore p)) (load-library (hemlock-internals:prompt-for-string :prompt "Load library: ")))) +;; End of things kept together + +;; Unfinished, including at least *one* function taht isn't implemented +;; (and will be hell to make portably, I'm afraid) +(cl:defun expand-file-name (name &optional default-directory) + (cl:let ((result (search "~" name))) + (if result + (cl:let ((name (subseq name result))) + (if (char= (cl:aref name 1) #\/) + (merge-pathnames (subseq name 2) (elisp-internals:get-user-homedir)) + (cl:let ((username (subseq name 1 (search "/" name))) + (directory (subseq name (1+ (search "/" name))))) + (merge-pathnames directory (elisp-internals:get-user-homedir username))))) + name + ))) + +(cl:defmacro while (test &body body) + `(cl:do () + ((not ,test) nil) + ,@body)) + +(cl:defmacro aset (array index new-element) + `(setf (cl:aref ,array ,index) ,new-element)) + +(cl:defmacro assq (key list) + `(cl:assoc ,key ,list :test 'eq)) + +(cl:defmacro assoc (key list) + `(cl:assoc ,key ,list :test 'equal)) + +(cl:defun % (x y) + "Return the remainder of X divided by Y, both X and Y must be integers" + (declare (integer x y)) + (mod x y)) + +(cl:defun car-safe (object) + (when (consp object) + (car object))) + +(cl:defun cdr-safe (object) + (when (consp object) + (cdr object))) + +(cl:defun car-less-than-car (a b) + (< (car a) (car b))) + +(cl:defun bool-vector-p (array) + (and (simple-vector-p array) + (eq (element-type array) 'bit))) + +(cl:defun aref (vector &rest indices) + (if (bool-vector-p vector) + (= 1 (apply #'cl:aref vector indices)) + (apply #'cl:aref vector indices))) + +(cl:defun make-bool-vector (length init) + (make-array (list length) :element-type bit :initial-element (if init 1 0))) + +(cl:defun delq (element list) + (cl:delete element list :test #'cl:eq)) + +(cl:defun fset (symbol function) + (cl:setf (symbol-function symbol) function)) + +(cl:defmacro autoload (function file &optional docstring interactive type) + (cond ((and docstring interactive) + `(defun ,function (&rest args) + ,docstring + (interactive) + (unless (gethash ',function elisp-internals::*autoloads* nil) + (setf (gethash ',function elisp-internals::*autoloads*) t) + (load ,file)) + (apply ',function args))) + ((and docstring (not interactive)) + `(defun ,function (&rest args) + ,docstring + (unless (gethash ',function elisp-internals::*autoloads* nil) + (setf (gethash ',function elisp-internals::*autoloads*) t) + (load ,file)) + (apply ',function args))) + (interactive + `(defun ,function (&rest args) + (interactive) + (unless (gethash ',function elisp-internals::*autoloads* nil) + (setf (gethash ',function elisp-internals::*autoloads*) t) + (load ,file)) + (apply ',function args))) + (t + `(defun ,function (&rest args) + (unless (gethash ',function elisp-internals::*autoloads* nil) + (setf (gethash ',function elisp-internals::*autoloads*) t) + (load ,file)) + (apply ',function args))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/cmucl-hemlock-glue.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/cmucl-hemlock-glue.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/cmucl-hemlock-glue.lisp (revision 8058) @@ -0,0 +1,15 @@ +;;; File to fix Irritating Impedance Mismatch between +;;; CMU CL Hemlock and PortableHemlock. + +#+cmu +(unless (find-package :hemlock-ext) + #-hemlock + (progn + (load "/usr/share/common-lisp/systems/cmucl-hemlock.system") + (mk:oos :cmucl-hemlock :load)) + + ;; OK, here comes the nasty. CMUCLHemlock stuffs things in the "EXT" + ;; package (system-dependent stuff, basically). We expect things to be + ;; orderly and live in a Hemlock package. Thus: + (common-lisp::enter-new-nicknames (find-package "EXTENSIONS") '("HEMLOCK-EXT"))) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/codewalker.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/codewalker.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/codewalker.lisp (revision 8058) @@ -0,0 +1,71 @@ +;;; The code walker should ideally be in ELISP-INTERNALS, however +;;; getting it there won't be trivial, so ignoring that for now. +(in-package "ELISP") + +(cl:defun walk-code (form &optional lexicals) + (cond ((null form) nil) + ((numberp form) form) + ((stringp form) form) + ((atom form) (if (member form lexicals) + form + `(elisp-value ',form))) + (t (cl:let ((head (car form)) + (rest (cdr form))) + (cond ((eq head 'lexical-let) + (cl:let ((bindings (append lexicals + (mapcar #'(lambda (x) + (cl:if (symbolp x) + x + (car x))) + (car rest)))) + (tail (cdr rest))) + (cons head + (cons (mapcar #'(lambda (form) + (walk-code form lexicals)) + (car rest)) + (mapcar #'(lambda (form) + (walk-code form bindings)) + tail))))) + ((eq head 'let) + (cons head (cons (mapcar #'(lambda (form) + (walk-code form lexicals)) + (car rest)) + (mapcar #'(lambda (form) + (walk-code form lexicals)) + (cdr rest))))) + ((member head '(defun defmacro)) + (cl:let ((name (car rest)) + (new-vars + (cl:loop for sym in (cadr rest) + if (not + (member sym '(&optional &rest + &aux &key))) + collect sym)) + (forms (cddr rest)) + (vars (cadr rest))) + `(,head ,name ,vars + ,@(mapcar + #'(lambda (form) + (walk-code form + (append lexicals new-vars))) + forms)))) + ((eq head 'cond) + (cons head + (cl:loop for cond-form in rest + collect + (cl:loop for form in cond-form + collect (walk-code form lexicals))))) + ((eq head 'quote) + (cons head rest)) + ((member head '(setq setf)) + (cons head + (loop for symbol in rest + for toggle = t then (not toggle) + if toggle + collect symbol + else + collect (walk-code symbol lexicals)))) + (t (cons head (mapcar #'(lambda (form) + (walk-code form lexicals)) + rest)))))))) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/compile.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/compile.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/compile.lisp (revision 8058) @@ -0,0 +1,6 @@ +(load "loadup") +(compile-file "read-table") +(compile-file "internals") +(compile-file "codewalker") +(compile-file "base") +(compile-file "hemlock-shims") Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/hemlock-shims.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/hemlock-shims.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/hemlock-shims.lisp (revision 8058) @@ -0,0 +1,77 @@ +(in-package "ELISP") + +(cl:defun mangle-key (key) + "Turn a CL-elisp key designator to a PHemlock KEY-EVENT" + (typecase key +; (string (with-input-from-string (stream key) +; (let ((*readtable* elisp-internals:*elisp-readtable*)) +; (elisp-internals::read-string-char stream :event)))) + (string (map 'vector #'mangle-key key)) + ((or vector array) + (map 'vector #'mangle-key key)) + (hemlock-ext:key-event key) + ((or integer character) + (multiple-value-bind (ismeta ischar) (truncate (if (characterp key) + (char-code key) + key) + 128) + (cl:let ((charspec (if (cl:= 1 ismeta) (list :meta)))) + (when (< ischar 32) + (push :control charspec) + (setq ischar (1- (+ ischar (char-code #\a))))) + (push (code-char ischar) charspec) + (elisp-internals::emit-character (reverse charspec) :event) + ))))) + +(cl:defun global-set-key (key command) + (let ((key (mangle-key key))) + (bind-key (string command) key :global))) + +(cl:defun local-set-key (key command) + (let ((key (mangle-key key))) + (bind-key (string command) key :mode major-mode))) + +(cl:defun use-local-map (keymap) + (cond ((and (listp keymap) + (eq (car keymap) 'keymap)) + (cl:let ((has-menu-name (stringp (cadr keymap)))) + (let ((char-table (if has-menu-name + (if (vectorp (caddr keymap)) + (caddr keymap)) + (if (vectorp (cadr keymap)) + (cadr keymap)))) + (the-alist (if has-menu-name + (if (vectorp (caddr keymap)) + (cdddr keymap)) + (if (vectorp (cadr keymap)) + (cddr keymap))))) + ; iterate through the relevant sections + ))) + ((symbolp keymap) + (use-local-map (eval keymap))))) + +(cl:defun get-buffer-create (buffer-name) + (or (getstring buffer-name *buffer-names*) + (make-buffer buffer-name))) + +(cl:defun get-buffer (buffer-name) + (getstring buffer-name *buffer-names*)) + +(cl:defun commandp (function-designator) + (typecase function-designator + (symbol (hemlock-internals:commandp (getstring (string-downcase (string function-designator)) hemlock-internals:*command-names*))) + (function nil) ; Bug, but as far as I can tell, we can't portably + ; extract the name from the function object + (string (hemlock-internals:commandp (getstring (string-downcase function-designator) hemlock-internals:*command-names*))) + (t nil))) + +(cl:defun bolp () + (= 0 (hemlock-internals:mark-charpos (hemlock-internals:current-point)))) + +(cl:defun bobp () + (and (= 0 (hemlock-internals::line-number (hemlock-internals:mark-line (hemlock-internals:current-point)))) + (bolp))) + +(cl:defun abort-recursive-edit () + (and (hemlock-internals:in-recursive-edit) + (hemlock-internals:exit-recursive-edit))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/implementation-needed =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/implementation-needed (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/implementation-needed (revision 8058) @@ -0,0 +1,779 @@ +abbrev-expansion ; elisp +abbrev-symbol ; elisp +accept-process-output ; elisp +access-file ; elisp +accessible-keymaps ; elisp +active-minibuffer-window ; elisp +add-name-to-file ; elisp +add-text-properties ; elisp +all-completions ; elisp +apropos-internal ; elisp +backtrace ; elisp +backtrace-debug ; elisp +backward-char ; elisp +backward-prefix-chars ; elisp +barf-if-buffer-read-only ; elisp +base64-decode-region ; elisp +base64-decode-string ; elisp +base64-encode-region ; elisp +base64-encode-string ; elisp +beginning-of-line ; elisp +bitmap-spec-p ; elisp +buffer-base-buffer ; elisp +buffer-disable-undo ; elisp +buffer-enable-undo ; elisp +buffer-file-name ; elisp +buffer-has-markers-at ; elisp +buffer-list ; elisp +buffer-live-p ; elisp +buffer-local-variables ; elisp +buffer-modified-p ; elisp +buffer-modified-tick ; elisp +buffer-name ; elisp +buffer-size ; elisp +buffer-string ; elisp +buffer-substring ; elisp +buffer-substring-no-properties ; elisp +bufferp ; elisp +bury-buffer ; elisp +byte-code ; elisp +byte-code-function-p ; elisp +byte-to-position ; elisp +c-beginning-of-defun ; elisp +call-interactively ; elisp +call-last-kbd-macro ; elisp +call-process ; elisp +call-process-region ; elisp +cancel-kbd-macro-events ; elisp +capitalize ; elisp +capitalize-region ; elisp +capitalize-word ; elisp +case-table-p ; elisp +category-docstring ; elisp +category-set-mnemonics ; elisp +category-table ; elisp +category-table-p ; elisp +ccl-execute ; elisp +ccl-execute-on-string ; elisp +ccl-program-p ; elisp +char-after ; elisp +char-before ; elisp +char-bytes ; elisp +char-category-set ; elisp +char-charset ; elisp +char-direction ; elisp +char-or-string-p ; elisp +char-syntax ; elisp +char-table-extra-slot ; elisp +char-table-p ; elisp +char-table-parent ; elisp +char-table-range ; elisp +char-table-subtype ; elisp +char-to-string ; elisp +char-valid-p ; elisp +char-width ; elisp +chars-in-region ; elisp +charset-after ; elisp +check-coding-system ; elisp +clear-abbrev-table ; elisp +clear-buffer-auto-save-failure ; elisp +clear-face-cache ; elisp +clear-image-cache ; elisp +clear-this-command-keys ; elisp +clear-visited-file-modtime ; elisp +coding-system-p ; elisp +color-gray-p ; elisp +color-supported-p ; elisp +combine-after-change-execute ; elisp +command-execute ; elisp +compare-buffer-substrings ; elisp +compare-strings ; elisp +compare-window-configurations ; elisp +completing-read ; elisp +compose-region-internal ; elisp +compose-string-internal ; elisp +compute-motion ; elisp +concat ; elisp +condition-case ; elisp +constrain-to-field ; elisp +continue-process ; elisp +coordinates-in-window-p ; elisp +copy-category-table ; elisp +copy-file ; elisp +copy-hash-table ; elisp +copy-keymap ; elisp +copy-marker ; elisp +copy-sequence ; elisp +copy-syntax-table ; elisp +cp-make-coding-systems-for-codepage ; elisp +cperl-mode ; elisp +current-buffer ; elisp +current-case-table ; elisp +current-column ; elisp +current-global-map ; elisp +current-indentation ; elisp +current-input-mode ; elisp +current-local-map ; elisp +current-message ; elisp +current-minor-mode-maps ; elisp +current-time ; elisp +current-time-string ; elisp +current-time-zone ; elisp +current-window-configuration ; elisp +declare-equiv-charset ; elisp +decode-big5-char ; elisp +decode-coding-region ; elisp +decode-coding-string ; elisp +decode-sjis-char ; elisp +decode-time ; elisp +defalias ; elisp +default-boundp ; elisp +default-file-modes ; elisp +default-value ; elisp +defconst ; elisp +define-abbrev ; elisp +define-abbrev-table ; elisp +define-category ; elisp +define-charset ; elisp +define-global-abbrev ; elisp +define-hash-table-test ; elisp +define-key ; elisp +define-mode-abbrev ; elisp +define-prefix-command ; elisp +defining-kbd-macro ; elisp +delete-and-extract-region ; elisp +delete-backward-char ; elisp +delete-char ; elisp +delete-directory ; elisp +delete-field ; elisp +delete-frame ; elisp +delete-other-windows ; elisp +delete-overlay ; elisp +delete-process ; elisp +delete-region ; elisp +delete-window ; elisp +delete-windows-on ; elisp +describe-bindings-internal ; elisp +describe-categories ; elisp +describe-syntax ; elisp +describe-vector ; elisp +detect-coding-region ; elisp +detect-coding-string ; elisp +ding ; elisp +directory-file-name ; elisp +directory-files ; elisp +directory-files-and-attributes ; elisp +discard-input ; elisp +display-buffer ; elisp +display-completion-list ; elisp +do-auto-save ; elisp +documentation-property ; elisp +downcase ; elisp +downcase-region ; elisp +downcase-word ; elisp +dump-emacs ; elisp +emacs-pid ; elisp +encode-big5-char ; elisp +encode-coding-region ; elisp +encode-coding-string ; elisp +encode-sjis-char ; elisp +encode-time ; elisp +end-kbd-macro ; elisp +end-of-line ; elisp +enlarge-window ; elisp +eobp ; elisp +eolp ; elisp +erase-buffer ; elisp +error-message-string ; elisp +eval-buffer ; elisp +eval-minibuffer ; elisp +eval-region ; elisp +event-convert-list ; elisp +execute-extended-command ; elisp +execute-kbd-macro ; elisp +exit-minibuffer ; elisp +exit-recursive-edit ; elisp +expand-abbrev ; elisp +expand-file-name ; elisp +external-debugging-output ; elisp +f90-mode ; elisp +face-font ; elisp +featurep ; elisp +fetch-bytecode ; elisp +field-beginning ; elisp +field-end ; elisp +field-string ; elisp +field-string-no-properties ; elisp +file-accessible-directory-p ; elisp +file-attributes ; elisp +file-attributes-lessp ; elisp +file-directory-p ; elisp +file-executable-p ; elisp +file-exists-p ; elisp +file-locked-p ; elisp +file-modes ; elisp +file-name-absolute-p ; elisp +file-name-all-completions ; elisp +file-name-as-directory ; elisp +file-name-completion ; elisp +file-name-directory ; elisp +file-name-nondirectory ; elisp +file-newer-than-file-p ; elisp +file-readable-p ; elisp +file-regular-p ; elisp +file-symlink-p ; elisp +file-writable-p ; elisp +fillarray ; elisp +find-charset-region ; elisp +find-charset-string ; elisp +find-coding-systems-region-internal ; elisp +find-composition-internal ; elisp +find-file-name-handler ; elisp +find-operation-coding-system ; elisp +float-time ; elisp +following-char ; elisp +font-info ; elisp +fontset-font ; elisp +fontset-info ; elisp +fontset-list ; elisp +format-time-string ; elisp +fortran-mode ; elisp +forward-char ; elisp +forward-comment ; elisp +forward-line ; elisp +forward-point ; elisp +forward-word ; elisp +frame-char-height ; elisp +frame-char-width ; elisp +frame-face-alist ; elisp +frame-first-window ; elisp +frame-focus ; elisp +frame-list ; elisp +frame-live-p ; elisp +frame-or-buffer-changed-p ; elisp +frame-parameter ; elisp +frame-parameters ; elisp +frame-pixel-height ; elisp +frame-pixel-width ; elisp +frame-root-window ; elisp +frame-selected-window ; elisp +frame-visible-p ; elisp +framep ; elisp +gap-position ; elisp +gap-size ; elisp +garbage-collect ; elisp +generate-new-buffer-name ; elisp +generic-character-list ; elisp +get-buffer-process ; elisp +get-buffer-window ; elisp +get-char-property ; elisp +get-file-buffer ; elisp +get-file-char ; elisp +get-largest-window ; elisp +get-lru-window ; elisp +get-process ; elisp +get-text-property ; elisp +get-unused-category ; elisp +get-unused-iso-final-char ; elisp +getenv-internal ; elisp +global-key-binding ; elisp +goto-char ; elisp +handle-switch-frame ; elisp +hash-table-weakness ; elisp +iconify-frame ; elisp +ignore-event ; elisp +image-mask-p ; elisp +image-size ; elisp +indent-to ; elisp +indirect-function ; elisp +input-pending-p ; elisp +insert ; elisp +insert-abbrev-table-description ; elisp +insert-and-inherit ; elisp +insert-before-markers ; elisp +insert-before-markers-and-inherit ; elisp +insert-buffer-substring ; elisp +insert-char ; elisp +insert-file-contents ; elisp +insert-string ; elisp +integer-or-marker-p ; elisp +interactive-p ; elisp +intern-soft ; elisp +internal-char-font ; elisp +internal-copy-lisp-face ; elisp +internal-face-x-get-resource ; elisp +internal-get-lisp-face-attribute ; elisp +internal-lisp-face-attribute-values ; elisp +internal-lisp-face-empty-p ; elisp +internal-lisp-face-equal-p ; elisp +internal-lisp-face-p ; elisp +internal-make-lisp-face ; elisp +internal-merge-in-global-face ; elisp +internal-set-alternative-font-family-alist ; elisp +internal-set-alternative-font-registry-alist ; elisp +internal-set-font-selection-order ; elisp +internal-set-lisp-face-attribute ; elisp +internal-set-lisp-face-attribute-from-resource ; elisp +internal-show-cursor ; elisp +internal-show-cursor-p ; elisp +interrupt-process ; elisp +invocation-directory ; elisp +invocation-name ; elisp +iso-charset ; elisp +iswitchb-read-buffer ; elisp +key-binding ; elisp +key-description ; elisp +keyboard-coding-system ; elisp +keymap-parent ; elisp +keymapp ; elisp +kill-all-local-variables ; elisp +kill-buffer ; elisp +kill-emacs ; elisp +kill-local-variable ; elisp +kill-process ; elisp +line-beginning-position ; elisp +line-end-position ; elisp +list-processes ; elisp +load-average ; elisp +local-key-binding ; elisp +local-variable-if-set-p ; elisp +local-variable-p ; elisp +lock-buffer ; elisp +log10 ; elisp +logb ; elisp +looking-at ; elisp +lookup-key ; elisp +lower-frame ; elisp +lsh ; elisp +make-abbrev-table ; elisp +make-byte-code ; elisp +make-category-set ; elisp +make-category-table ; elisp +make-char-internal ; elisp +make-char-table ; elisp +make-directory-internal ; elisp +make-frame-invisible ; elisp +make-frame-visible ; elisp +make-indirect-buffer ; elisp +make-local-variable ; elisp +make-marker ; elisp +make-overlay ; elisp +make-symbolic-link ; elisp +make-temp-name ; elisp +make-terminal-frame ; elisp +make-variable-frame-local ; elisp +make-vector ; elisp +makehash ; elisp +map-char-table ; elisp +mapatoms ; elisp +mapconcat ; elisp +mark-marker ; elisp +marker-buffer ; elisp +marker-insertion-type ; elisp +marker-position ; elisp +markerp ; elisp +match-beginning ; elisp +match-data ; elisp +match-end ; elisp +matching-paren ; elisp +md5 ; elisp +memory-limit ; elisp +memory-use-counts ; elisp +memq ; elisp +message ; elisp +message-box ; elisp +message-or-box ; elisp +minibuffer-complete ; elisp +minibuffer-complete-and-exit ; elisp +minibuffer-complete-word ; elisp +minibuffer-completion-help ; elisp +minibuffer-depth ; elisp +minibuffer-message ; elisp +minibuffer-prompt ; elisp +minibuffer-window ; elisp +minor-mode-key-binding ; elisp +ml-arg ; elisp +ml-if ; elisp +ml-interactive ; elisp +ml-nargs ; elisp +ml-prefix-argument-loop ; elisp +ml-provide-prefix-argument ; elisp +modify-category-entry ; elisp +modify-frame-parameters ; elisp +modify-syntax-entry ; elisp +mouse-pixel-position ; elisp +mouse-position ; elisp +move-overlay ; elisp +move-to-column ; elisp +move-to-window-line ; elisp +multibyte-char-to-unibyte ; elisp +multibyte-string-p ; elisp +narrow-to-region ; elisp +natnump ; elisp +new-fontset ; elisp +next-char-property-change ; elisp +next-frame ; elisp +next-overlay-change ; elisp +next-property-change ; elisp +next-single-char-property-change ; elisp +next-single-property-change ; elisp +next-window ; elisp +nlistp ; elisp +number-or-marker-p ; elisp +number-to-string ; elisp +open-dribble-file ; elisp +open-network-stream ; elisp +open-termscript ; elisp +optimize-char-table ; elisp +other-buffer ; elisp +other-window ; elisp +other-window-for-scrolling ; elisp +overlay-buffer ; elisp +overlay-end ; elisp +overlay-get ; elisp +overlay-lists ; elisp +overlay-properties ; elisp +overlay-put ; elisp +overlay-recenter ; elisp +overlay-start ; elisp +overlayp ; elisp +overlays-at ; elisp +overlays-in ; elisp +parse-partial-sexp ; elisp +play-sound ; elisp +plist-get ; elisp +plist-member ; elisp +plist-put ; elisp +point ; elisp +point-marker ; elisp +point-max ; elisp +point-max-marker ; elisp +point-min ; elisp +point-min-marker ; elisp +pop-to-buffer ; elisp +pos-visible-in-window-p ; elisp +position-bytes ; elisp +posix-looking-at ; elisp +posix-search-backward ; elisp +posix-search-forward ; elisp +posix-string-match ; elisp +preceding-char ; elisp +prefix-numeric-value ; elisp +previous-char-property-change ; elisp +previous-frame ; elisp +previous-overlay-change ; elisp +previous-property-change ; elisp +previous-single-char-property-change ; elisp +previous-single-property-change ; elisp +previous-window ; elisp +primitive-undo ; elisp +process-buffer ; elisp +process-coding-system ; elisp +process-command ; elisp +process-contact ; elisp +process-exit-status ; elisp +process-filter ; elisp +process-id ; elisp +process-inherit-coding-system-flag ; elisp +process-kill-without-query ; elisp +process-list ; elisp +process-mark ; elisp +process-name ; elisp +process-running-child-p ; elisp +process-send-eof ; elisp +process-send-region ; elisp +process-send-string ; elisp +process-sentinel ; elisp +process-status ; elisp +process-tty-name ; elisp +processp ; elisp +propertize ; elisp +purecopy ; elisp +put ; elisp +put-text-property ; elisp +puthash ; elisp +query-fontset ; elisp +quit-process ; elisp +raise-frame ; elisp +rassq ; elisp +re-search-backward ; elisp +re-search-forward ; elisp +read-buffer ; elisp +read-char-exclusive ; elisp +read-coding-system ; elisp +read-command ; elisp +read-event ; elisp +read-file-name ; elisp +read-file-name-internal ; elisp +read-from-minibuffer ; elisp +read-key-sequence ; elisp +read-key-sequence-vector ; elisp +read-minibuffer ; elisp +read-no-blanks-input ; elisp +read-non-nil-coding-system ; elisp +read-string ; elisp +read-variable ; elisp +recent-auto-save-p ; elisp +recent-keys ; elisp +recenter ; elisp +recursion-depth ; elisp +recursive-edit ; elisp +redirect-frame-focus ; elisp +redraw-display ; elisp +redraw-frame ; elisp +regexp-quote ; elisp +region-beginning ; elisp +region-end ; elisp +register-ccl-program ; elisp +register-code-conversion-map ; elisp +remove-text-properties ; elisp +rename-buffer ; elisp +replace-buffer-in-windows ; elisp +replace-match ; elisp +reset-this-command-lengths ; elisp +restore-buffer-modified-p ; elisp +run-hook-with-args ; elisp +run-hook-with-args-until-failure ; elisp +run-hook-with-args-until-success ; elisp +run-hooks ; elisp +safe-length ; elisp +same-window-p ; elisp +save-current-buffer ; elisp +save-excursion ; elisp +save-restriction ; elisp +save-window-excursion ; elisp +scan-lists ; elisp +scan-sexps ; elisp +scroll-down ; elisp +scroll-left ; elisp +scroll-other-window ; elisp +scroll-right ; elisp +scroll-up ; elisp +search-backward ; elisp +search-backward-regexp ; elisp +search-forward ; elisp +search-forward-regexp ; elisp +select-frame ; elisp +select-window ; elisp +selected-frame ; elisp +selected-window ; elisp +self-insert-and-exit ; elisp +self-insert-command ; elisp +send-string-to-terminal ; elisp +sequencep ; elisp +set-buffer ; elisp +set-buffer-auto-saved ; elisp +set-buffer-major-mode ; elisp +set-buffer-modified-p ; elisp +set-buffer-multibyte ; elisp +set-case-table ; elisp +set-category-table ; elisp +set-char-table-default ; elisp +set-char-table-extra-slot ; elisp +set-char-table-parent ; elisp +set-char-table-range ; elisp +set-coding-priority-internal ; elisp +set-default-file-modes ; elisp +set-file-modes ; elisp +set-fontset-font ; elisp +set-frame-height ; elisp +set-frame-position ; elisp +set-frame-selected-window ; elisp +set-frame-size ; elisp +set-frame-width ; elisp +set-input-mode ; elisp +set-keyboard-coding-system-internal ; elisp +set-keymap-parent ; elisp +set-marker ; elisp +set-marker-insertion-type ; elisp +set-match-data ; elisp +set-minibuffer-window ; elisp +set-mouse-pixel-position ; elisp +set-mouse-position ; elisp +set-process-buffer ; elisp +set-process-coding-system ; elisp +set-process-filter ; elisp +set-process-inherit-coding-system-flag ; elisp +set-process-sentinel ; elisp +set-process-window-size ; elisp +set-safe-terminal-coding-system-internal ; elisp +set-standard-case-table ; elisp +set-syntax-table ; elisp +set-terminal-coding-system-internal ; elisp +set-text-properties ; elisp +set-time-zone-rule ; elisp +set-visited-file-modtime ; elisp +set-window-buffer ; elisp +set-window-configuration ; elisp +set-window-dedicated-p ; elisp +set-window-display-table ; elisp +set-window-hscroll ; elisp +set-window-margins ; elisp +set-window-point ; elisp +set-window-redisplay-end-trigger ; elisp +set-window-start ; elisp +set-window-vscroll ; elisp +setcar ; elisp +setcdr ; elisp +setplist ; elisp +setq-default ; elisp +setup-special-charsets ; elisp +shrink-window ; elisp +signal-process ; elisp +single-key-description ; elisp +sit-for ; elisp +skip-chars-backward ; elisp +skip-chars-forward ; elisp +skip-syntax-backward ; elisp +skip-syntax-forward ; elisp +sleep-for ; elisp +special-display-p ; elisp +split-char ; elisp +split-window ; elisp +standard-case-table ; elisp +standard-category-table ; elisp +standard-syntax-table ; elisp +start-kbd-macro ; elisp +start-process ; elisp +stop-process ; elisp +store-kbd-macro-event ; elisp +string-as-multibyte ; elisp +string-as-unibyte ; elisp +string-bytes ; elisp +string-make-multibyte ; elisp +string-make-unibyte ; elisp +string-match ; elisp +string-to-char ; elisp +string-to-number ; elisp +string-to-syntax ; elisp +string-width ; elisp +subr-interactive-form ; elisp +subrp ; elisp +subst-char-in-region ; elisp +substitute-command-keys ; elisp +substitute-in-file-name ; elisp +substring ; elisp +suspend-emacs ; elisp +switch-to-buffer ; elisp +syntax-table ; elisp +syntax-table-p ; elisp +system-name ; elisp +terminal-coding-system ; elisp +text-char-description ; elisp +text-properties-at ; elisp +text-property-any ; elisp +text-property-not-all ; elisp +this-command-keys ; elisp +this-command-keys-vector ; elisp +this-single-command-keys ; elisp +this-single-command-raw-keys ; elisp +tool-bar-lines-needed ; elisp +top-level ; elisp +track-mouse ; elisp +translate-region ; elisp +transpose-regions ; elisp +try-completion ; elisp +tty-display-color-p ; elisp +tty-suppress-bold-inverse-default-colors ; elisp +undo-boundary ; elisp +unexpand-abbrev ; elisp +unhandled-file-name-directory ; elisp +unibyte-char-to-multibyte ; elisp +unix-sync ; elisp +unlock-buffer ; elisp +upcase ; elisp +upcase-initials ; elisp +upcase-initials-region ; elisp +upcase-region ; elisp +upcase-word ; elisp +update-coding-systems-internal ; elisp +use-global-map ; elisp +user-full-name ; elisp +user-login-name ; elisp +user-real-login-name ; elisp +user-real-uid ; elisp +user-uid ; elisp +user-variable-p ; elisp +vconcat ; elisp +vector-or-char-table-p ; elisp +verify-visited-file-modtime ; elisp +vertical-motion ; elisp +visible-frame-list ; elisp +visited-file-modtime ; elisp +waiting-for-user-input-p ; elisp +where-is-internal ; elisp +wholenump ; elisp +widen ; elisp +widget-apply ; elisp +widget-get ; elisp +widget-put ; elisp +window-at ; elisp +window-buffer ; elisp +window-configuration-frame ; elisp +window-configuration-p ; elisp +window-dedicated-p ; elisp +window-display-table ; elisp +window-edges ; elisp +window-end ; elisp +window-frame ; elisp +window-height ; elisp +window-hscroll ; elisp +window-list ; elisp +window-live-p ; elisp +window-margins ; elisp +window-minibuffer-p ; elisp +window-point ; elisp +window-redisplay-end-trigger ; elisp +window-start ; elisp +window-text-height ; elisp +window-vscroll ; elisp +window-width ; elisp +windowp ; elisp +with-output-to-temp-buffer ; elisp +word-search-backward ; elisp +word-search-forward ; elisp +write-region ; elisp +x-backspace-delete-keys-p ; elisp +x-change-window-property ; elisp +x-close-connection ; elisp +x-create-frame ; elisp +x-delete-window-property ; elisp +x-disown-selection-internal ; elisp +x-display-backing-store ; elisp +x-display-color-cells ; elisp +x-display-grayscale-p ; elisp +x-display-list ; elisp +x-display-mm-height ; elisp +x-display-mm-width ; elisp +x-display-pixel-height ; elisp +x-display-pixel-width ; elisp +x-display-planes ; elisp +x-display-save-under ; elisp +x-display-screens ; elisp +x-display-visual-class ; elisp +x-family-fonts ; elisp +x-focus-frame ; elisp +x-font-family-list ; elisp +x-get-cut-buffer-internal ; elisp +x-get-resource ; elisp +x-get-selection-internal ; elisp +x-hide-tip ; elisp +x-list-fonts ; elisp +x-open-connection ; elisp +x-own-selection-internal ; elisp +x-parse-geometry ; elisp +x-popup-dialog ; elisp +x-popup-menu ; elisp +x-rotate-cut-buffers-internal ; elisp +x-selection-exists-p ; elisp +x-selection-owner-p ; elisp +x-server-max-request-size ; elisp +x-server-vendor ; elisp +x-server-version ; elisp +x-show-tip ; elisp +x-store-cut-buffer-internal ; elisp +x-synchronize ; elisp +x-window-property ; elisp +xw-color-defined-p ; elisp +xw-color-values ; elisp +xw-display-color-p ; elisp Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/internals.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/internals.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/internals.lisp (revision 8058) @@ -0,0 +1,162 @@ +(in-package "ELISP-INTERNALS") + +(defvar *my-symbols* nil) +(defvar *cl-symbols* nil) +(defvar *cl-kluge-symbols* nil) +(defvar *autoloads* (make-hash-table)) + +(cl:defun find-lambda-list-variables (list) + (loop for elem in list + if (and (symbolp elem) + (not (member elem '(&optional &rest)))) + collect elem)) + +(cl:defun generate-cl-package () + (when (and (null *my-symbols*) + (null *cl-symbols*) + (null *cl-kluge-symbols*)) + (setf *my-symbols* (make-hash-table :test 'equal)) + (loop for sym being the present-symbols of (find-package "ELISP") + do (cl:let ((name (symbol-name sym))) + (setf (gethash name *my-symbols*) name))) + (setf *cl-kluge-symbols* + (loop for sym being the external-symbol + of (find-package "COMMON-LISP") + collect sym)) + (setf *cl-symbols* + (loop for sym in *cl-kluge-symbols* + when (and (not (gethash (symbol-name sym) *my-symbols*)) + (fboundp sym)) + collect (symbol-name sym))) + (cl:let ((rv (with-output-to-string (s) + (format s "(in-package \"ELISP\")~%") + (loop for symname in *cl-symbols* + do + (format s "(cl:defmacro cl-~a (&rest args)~%`(cl:~a ,@args))~%~%~%" symname symname) + finally (format s "(export '~a (find-package \"ELISP\"))~%" *cl-kluge-symbols*))))) + (with-input-from-string (stream rv) + (load stream))))) + +(cl:defun require-load (directory feature filename) + (if filename + (cl:let ((fname (format nil "~a/~a" directory filename))) + (when (cl:probe-file fname) + (cl:let ((*package* (cl:find-package "ELISP-USER"))) + (load fname) + (cl:if (member feature elisp::features) + feature)))) + (cl:let ((fname-1 + (format nil "~a.el" (cl:string-downcase feature))) + (fname-2 + (format nil "~a" (cl:string-downcase feature)))) + (or (require-load directory feature fname-1) + (require-load directory feature fname-2))))) + +;;; Almost there! +;;; Basic thought: "generate a lambda expression that acts as a shim" +;;; NB: Does not handle "*" (read-only buffer signals error) or +;;; "@" (magic find-window-specifying--set-window indicator) +(cl:defun interactive-glue (initform function) + (if initform + (cl:let ((args (cl:with-input-from-string (s initform) + (cl:loop for l = (cl:read-line s nil nil) + while l collect l)))) + (multiple-value-bind (types prompt) + (cl:loop for l in args + collect (aref l 0) into type + collect (subseq l 1) into prompt + finally (return (values type prompt))) + `(lambda (p) + (funcall #',function + ,@(cl:loop for type in types + for pr in prompt + for extracollect = nil + collect + (case type + (#\a ;; unimplemented -- function + ) + (#\b ;; existing buffer + `(hemlock-internals:prompt-for-buffer + :prompt :pr + :must-exist nil)) + (#\B ; unimplemented -- buffer name + ; Note, this may need a wrapper to + ; coerce stuff to buffers + `(hemlock-internals:prompt-for-buffer + :prompt :pr + :must-exist nil)) + (#\c ;; unimplemented -- character + ) + (#\d '(hemlock-internals::current-point)) + (#\D ;; unimplemented -- directory name + ) + (#\e ;; unimplemented -- event + ) + (#\f ;; existing file + `(hemlock-internals:prompt-for-file + :prompt ,pr + :must-exist t)) + (#\F ;; file name + `(hemlock-internals:prompt-for-file + :prompt ,pr + :must-exist nil)) + (#\i nil) + (#\k ;; unimplemented -- key sequence + ) + (#\K ;; unimplemented -- key sequence + ) + (#\m '(hemlock::current-mark)) + (#\M ;; any string + `(hemlock-internals:prompt-for-string + :prompt ,pr)) + (#\n ;; number read + `(hemlock-internals:prompt-for-integer + :prompt ,pr)) + (#\N ;; raw prefix or #\n + `(cl:if p + p + (hemlock-internals:prompt-for-integer + :prompt ,pr))) + (#\p ;; raw prefix as number + '(cl:if p p 0)) + (#\P 'p) + (#\r + (setf extracollect + '(cl:let ((mark (hemlock::current-mark)) + (point (hemlock-internals::current-point))) + (if (<= (hemlock-internals::mark-charpos mark) + (hemlock-internals::mark-charpos point)) + point + mark))) + '(cl:let ((mark (hemlock::current-mark)) + (point (hemlock-internals::current-point))) + (if (<= (hemlock-internals::mark-charpos mark) + (hemlock-internals::mark-charpos point)) + mark + point))) + (#\s ; any string + `(hemlock-internals:prompt-for-string + :prompt ,pr)) + (#\S ; any symbol + `(intern (hemlock-internals:prompt-for-string + :prompt ,pr) + *package*)) + (#\v ; variable name + `(hemlock-internals:prompt-for-variable + :prompt ,pr) + ) + (#\x ; lisp expr read but not eval + `(hemlock-internals:prompt-for-expression + :prompt ,pr)) + (#\X ; lisp expr, read and evalled + `(eval (hemlock-internals:prompt-for-expression + :prompt ,pr)) + )) + if extracollect + collect extracollect + ))))) + `(lambda (arg) (declare (ignore arg)) (,function)))) + +(defun get-user-homedir (&optional username) + (unless username + (user-homedir-pathname))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/loadup.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/loadup.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/loadup.lisp (revision 8058) @@ -0,0 +1,11 @@ +;; Files to load +(load "packages") +(load "read-table") +(load "base") +(load "codewalker") +(load "internals") +(load "hemlock-shims") + +;; Functions to call +(let ((*package* (find-package :elisp))) + (elisp-internals:generate-cl-package)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/packages.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/packages.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/packages.lisp (revision 8058) @@ -0,0 +1,66 @@ +(defpackage "ELISP" + (:shadow "=" "DEFUN" "LET" "IF" "SETQ" "ASSOC" "COMMANDP" "AREF") + (:use "COMMON-LISP" "HEMLOCK-INTERNALS") + (:export + "%" + "=" + "ABORT-RECURSIVE-EDIT" + "AREF" + "ASET" + "ASSQ" + "ASSOC" + "AUTOLOAD" + "BOBP" + "BODY" + "BOLP" + "BOOL-VECTOR-P" + "BUFFER-LOCAL-P" + "CAR-LESS-THAN-CAR" + "CAR-SAFE" + "CDR-SAFE" + "COMMANDP" + "DEFMACRO" + "DEFUN" + "DEFVAR" + "FEATURES" + "FILENAME" + "GET-BUFFER" + "GET-BUFFER-CREATE" + "GET-DEFAULT" + "GLOBAL-SET-KEY" + "IF" + "INTERACTIVE" + "KEY" + "KEYMAP" + "LET" + "LEXICAL-LET" + "LOAD-FILE" + "LOAD-LIBRARY" + "LOAD-PATH" + "LOCAL-SET-KEY" + "MAKE-BOOL-VECTOR" + "MAKE-KEYMAP" + "MAKE-VARIABLE-BUFFER-LOCAL" + "MAKE-SPARSE-KEYMAP" + "NOERROR" + "SET-DEFAULT" + "SETQ" + "USE-LOCAL-MAP" + "WHILE" + ) +) +(defpackage "ELISP-INTERNALS" + (:shadow "READ-STRING") + (:use "COMMON-LISP") + (:export + "FIND-LAMBDA-LIST-VARIABLES" + "GENERATE-CL-PACKAGE" + "REQUIRE-LOAD" + "GET-USER-HOMEDIR" + "INTERACTIVE-GLUE" + "*ELISP-READTABLE*" + ) + ) +(defpackage "ELISP-USER" + (:use "ELISP" "ELISP-INTERNALS") + ) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/read-table.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/read-table.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/elisp/read-table.lisp (revision 8058) @@ -0,0 +1,131 @@ +(in-package "ELISP-INTERNALS") + +(defvar *elisp-readtable* (copy-readtable)) + +(cl:defun read-vector (stream char) + (when (char= char #\[) + (coerce (read-delimited-list #\] stream t) 'vector))) + +(cl:defun read-character (stream char) + (if (char= char #\?) + (read-string-char stream :event) + (values))) + +;;; Note to self. Implement this, head hurts, another day. +;;; Is hopefully mostly done... +(cl:defun emit-character (charspec context) + (cl:case context + (:character + (cl:let ((char (char-code (car (last charspec))))) + (if (member :control charspec) + (setf char (mod char 32))) + (if (member :meta charspec) + (setf char (+ 128 char))) + (code-char char) + )) + (:event + (cl:let ((string (with-output-to-string (s) + (write-char #\" s) + (loop for entity in charspec + do (case entity + (:control + (write-char #\C s) + (write-char #\- s)) + (:meta + (write-char #\M s) + (write-char #\- s)) + (t (write-char entity s)))) + (write-char #\" s)))) + (with-input-from-string (hackstring string) + (eval (hemlock-ext::parse-key-fun hackstring #\k 2)))) + ))) + +(defun read-octal (stream acc level) + (cl:if (= level 3) + (code-char acc) + (let ((char (cl:read-char stream nil stream t))) + (case char + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) + (if (and (char= char #\0) (zerop acc)) + (code-char 0) + (let ((value (position char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) :test #'char=))) + (cl:if (< (+ value (* 8 acc)) 256) + (read-octal stream (+ value (* 8 acc)) (1+ level)) + (progn (unread-char char stream) (code-char acc)))))) + (t (if (zerop acc) + char + (progn + (unread-char char stream) + (code-char acc)))))))) + +(cl:defun read-string-char (stream context) + (cl:let ((char (cl:read-char stream nil stream t))) + (if (char= char #\\) + (cl:let ((next (cl:read-char stream nil stream t))) + (case next + (#\a (emit-character '(:control #\g) context)) + (#\n (emit-character '(:control #\j) context)) + (#\b (emit-character '(:control #\h) context)) + (#\r (emit-character '(:control #\m) context)) + (#\v (emit-character '(:control #\k) context)) + (#\f (emit-character '(:control #\l) context)) + (#\t (emit-character '(:control #\i) context)) + (#\e (emit-character '(:control #\[) context)) + (#\\ #\\) + (#\" #\") + (#\d (emit-character '(#\Rubout) context)) + ((#\C #\M) + (unread-char next stream) + (emit-character + (do ((char (read-char stream) (read-char stream)) + (expect-dash nil (not expect-dash)) + (terminate nil) + (collection nil)) + ((or (and expect-dash (not (char= char #\-))) + terminate) + (unread-char char stream) + (nreverse collection)) + (cond (expect-dash) + ((char= char #\M) + (setf collection (cons :meta collection))) + ((char= char #\C) + (setf collection (cons :control collection))) + (t (setf terminate t) + (setf collection (cons char collection))))) + context)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) + (read-octal stream 0 0) + ))) + char))) + +(cl:defun read-string (stream char) + (if (char= char #\") + (with-output-to-string (s) + (loop for char = (read-string-char stream :character) + if (char= char #\") return s + else do (cl:write-char char s))))) + +(cl:defun sharp-ampersand (stream ignore arg) + (declare (ignore ignore arg)) + (let ((length (cl:read stream t stream t))) + (if (not (integerp length)) + (values) + (let ((string (read stream stream stream t)) + (rv (make-array (list length) :element-type 'bit :initial-element 0))) + (if (stringp string) + (progn + (loop for ix from 0 to (1- length) + do (multiple-value-bind (char shift) (truncate ix 8) + (let ((val (char-code (char string char)))) + (unless (zerop (logand val (ash 1 shift))) + (setf (aref rv ix) 1))))) + rv) + (values)))))) + +(set-macro-character #\[ 'read-vector nil *elisp-readtable*) +(set-macro-character #\] (get-macro-character #\)) nil *elisp-readtable*) +(set-macro-character #\? 'read-character nil *elisp-readtable*) +(set-macro-character #\" 'read-string nil *elisp-readtable*) +(set-dispatch-macro-character #\# #\& #'sharp-ampersand *elisp-readtable*) +(set-syntax-from-char #\[ #\() +(set-syntax-from-char #\] #\)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/eval-server.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/eval-server.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/eval-server.lisp (revision 8058) @@ -0,0 +1,1097 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(hemlock-ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code for connecting to eval servers and some command +;;; level stuff too. +;;; +;;; Written by William Lott. +;;; + +(in-package :hemlock) + + + + +;;;; Structures. + +(defstruct (server-info (:print-function print-server-info)) + name ; String name of this server. + wire ; Wire connected to this server. + notes ; List of note objects for operations + ; which have not yet completed. + slave-info ; Ts-Info used in "Slave Lisp" buffer + ; (formerly the "Lisp Listener" buffer). + slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. + background-info ; Ts-Info structure of typescript we use in + ; "background" buffer. + background-buffer ; Buffer "background" typescript is in. + (errors ; Array of errors while compiling + (make-array 16 :adjustable t :fill-pointer 0)) + error-index) ; Index of current error. +;;; +(defun print-server-info (obj stream n) + (declare (ignore n)) + (format stream "#" (server-info-name obj))) + + +(defstruct (error-info (:print-function print-error-info)) + buffer ; Buffer this error is for. + message ; Error Message + line ; Pointer to message in log buffer. + region) ; Region of faulty text +;;; +(defun print-error-info (obj stream n) + (declare (ignore n)) + (format stream "#" (error-info-message obj))) + + +(defvar *server-names* (make-string-table) + "A string-table of the name of all Eval servers and their corresponding + server-info structures.") + +(defvar *abort-operations* nil + "T iff we should ignore any operations sent to us.") + +(defvar *inside-operation* nil + "T iff we are currenly working on an operation. A catcher for the tag + abort-operation will be established whenever this is T.") + +(defconstant *slave-connect-wait* 300) + +;;; Used internally for communications. +;;; +(defvar *newly-created-slave* nil) +(defvar *compiler-wire* nil) +(defvar *compiler-error-stream* nil) +(defvar *compiler-note* nil) + + + + +;;;; Hemlock Variables + +(defhvar "Current Compile Server" + "The Server-Info object for the server currently used for compilation + requests." + :value nil) + +(defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil) + +(defhvar "Slave Utility" + "This is the pathname of the utility to fire up slave Lisps. It defaults + to \"cmucl\"." + :value "cmucl") + +(defhvar "Slave Utility Switches" + "These are additional switches to pass to the Slave Utility. + For example, (list \"-core\" ). The -slave + switch and the editor name are always supplied, and they should + not be present in this variable." + :value nil) + +(defhvar "Ask About Old Servers" + "When set (the default), Hemlock will prompt for an existing server's name + in preference to prompting for a new slave's name and creating it." + :value t) + +(defhvar "Confirm Slave Creation" + "When set (the default), Hemlock always confirms a slave's creation for + whatever reason." + :value t) + + +(defhvar "Slave GC Alarm" + "Determines that is done when the slave notifies that it is GCing. + :MESSAGE prints a message in the echo area, :LOUD-MESSAGE beeps as well. + NIL does nothing." + :value :message) + + + +;;;; Slave destruction. + +;;; WIRE-DIED -- Internal. +;;; +;;; The routine is called whenever a wire dies. We roll through all the +;;; servers looking for any that use this wire and nuke them with server-died. +;;; +(defun wire-died (wire) + (let ((servers nil)) + (do-strings (name info *server-names*) + (declare (ignore name)) + (when (eq wire (server-info-wire info)) + (push info servers))) + (dolist (server servers) + (server-died server)))) + +;;; SERVER-DIED -- Internal. +;;; +;;; Clean up the server. Remove any references to it from variables, etc. +;;; +(defun server-died (server) + (declare (special *breakpoints*)) + (let ((name (server-info-name server))) + (delete-string name *server-names*) + (message "Server ~A just died." name)) + (when (server-info-wire server) + #+NILGB + (let ((fd (hemlock.wire:wire-fd (server-info-wire server)))) + (system:invalidate-descriptor fd) + (unix:unix-close fd)) + (setf (server-info-wire server) nil)) + (when (server-info-slave-info server) + (ts-buffer-wire-died (server-info-slave-info server)) + (setf (server-info-slave-info server) nil)) + (when (server-info-background-info server) + (ts-buffer-wire-died (server-info-background-info server)) + (setf (server-info-background-info server) nil)) + (clear-server-errors server) + (when (eq server (variable-value 'current-eval-server :global)) + (setf (variable-value 'current-eval-server :global) nil)) + (when (eq server (variable-value 'current-compile-server :global)) + (setf (variable-value 'current-compile-server :global) nil)) + (dolist (buffer *buffer-list*) + (dolist (var '(current-eval-server current-compile-server server-info)) + (when (and (hemlock-bound-p var :buffer buffer) + (eq (variable-value var :buffer buffer) server)) + (delete-variable var :buffer buffer)))) + (setf *breakpoints* (delete-if #'(lambda (b) + (eq (breakpoint-info-slave b) server)) + *breakpoints*))) + +;;; SERVER-CLEANUP -- Internal. +;;; +;;; This routine is called as a buffer delete hook. It takes care of any +;;; per-buffer cleanup that is necessary. It clears out all references to the +;;; buffer from server-info structures and that any errors that refer to this +;;; buffer are finalized. +;;; +(defun server-cleanup (buffer) + (let ((info (if (hemlock-bound-p 'server-info :buffer buffer) + (variable-value 'server-info :buffer buffer)))) + (when info + (when (eq buffer (server-info-slave-buffer info)) + (setf (server-info-slave-buffer info) nil) + (setf (server-info-slave-info info) nil)) + (when (eq buffer (server-info-background-buffer info)) + (setf (server-info-background-buffer info) nil) + (setf (server-info-background-info info) nil)))) + (do-strings (string server *server-names*) + (declare (ignore string)) + (clear-server-errors server + #'(lambda (error) + (eq (error-info-buffer error) buffer))))) +;;; +(add-hook delete-buffer-hook 'server-cleanup) + +;;; CLEAR-SERVER-ERRORS -- Public. +;;; +;;; Clears all known errors for the given server and resets it so more can +;;; accumulate. +;;; +(defun clear-server-errors (server &optional test-fn) + "This clears compiler errors for server cleaning up any pointers for GC + purposes and allowing more errors to register." + (let ((array (server-info-errors server)) + (current nil)) + (dotimes (i (fill-pointer array)) + (let ((error (aref array i))) + (when (or (null test-fn) + (funcall test-fn error)) + (let ((region (error-info-region error))) + (when (regionp region) + (delete-mark (region-start region)) + (delete-mark (region-end region)))) + (setf (aref array i) nil)))) + (let ((index (server-info-error-index server))) + (when index + (setf current + (or (aref array index) + (find-if-not #'null array + :from-end t + :end current))))) + (delete nil array) + (setf (server-info-error-index server) + (position current array)))) + + + + +;;;; Slave creation. + +;;; INITIALIZE-SERVER-STUFF -- Internal. +;;; +;;; Reinitialize stuff when a core file is saved. +;;; +(defun initialize-server-stuff () + (clrstring *server-names*)) + + +(defvar *editor-name* nil "Name of this editor.") +(defvar *accept-connections* nil + "When set, allow slaves to connect to the editor.") + +;;; GET-EDITOR-NAME -- Internal. +;;; +;;; Pick a name for the editor. Names consist of machine-name:port-number. If +;;; in ten tries we can't get an unused port, choak. We don't save the result +;;; of HEMLOCK.WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to +;;; ever kill the request server, and we can always inhibit connection with +;;; "Accept Connections". +;;; +(defun get-editor-name () + (if *editor-name* + *editor-name* + (let ((random-state (make-random-state t))) + (dotimes (tries 10 (error "Could not create an internet listener.")) + (let ((port (+ 2000 (random 10000 random-state)))) + (setf port 4711) ;### + (when (handler-case (hemlock.wire:create-request-server + port + #'(lambda (wire addr) + (declare (ignore addr)) + (values *accept-connections* + #'(lambda () (wire-died wire))))) + (error () nil)) + (return (setf *editor-name* + (format nil "~A:~D" (machine-instance) port))))))))) + + +;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal. +;;; +;;; This function returns no values because it is called remotely for value by +;;; connecting slaves. Though we know the system will propagate nil back to +;;; the slave, we indicate here that nil is meaningless. +;;; +(defun make-buffers-for-typescript (slave-name background-name) + "Make the interactive and background buffers slave-name and background-name. + If either is nil, then prompt the user." + (multiple-value-bind (slave-name background-name) + (cond ((not (and slave-name background-name)) + (pick-slave-buffer-names)) + ((getstring slave-name *server-names*) + (multiple-value-bind + (new-sn new-bn) + (pick-slave-buffer-names) + (message "~S is already an eval server; ~ + using ~S instead." + slave-name new-sn) + (values new-sn new-bn))) + (t (values slave-name background-name))) + (let* ((slave-buffer (or (getstring slave-name *buffer-names*) + (make-buffer slave-name :modes '("Lisp")))) + (background-buffer (or (getstring background-name *buffer-names*) + (make-buffer background-name + :modes '("Lisp")))) + (server-info (make-server-info :name slave-name + :wire hemlock.wire:*current-wire* + :slave-buffer slave-buffer + :background-buffer background-buffer)) + (slave-info (typescriptify-buffer slave-buffer server-info + hemlock.wire:*current-wire*)) + (background-info (typescriptify-buffer background-buffer server-info + hemlock.wire:*current-wire*))) + (setf (server-info-slave-info server-info) slave-info) + (setf (server-info-background-info server-info) background-info) + (setf (getstring slave-name *server-names*) server-info) + (unless (variable-value 'current-eval-server :global) + (setf (variable-value 'current-eval-server :global) server-info)) + (hemlock.wire:remote-value + hemlock.wire:*current-wire* + (made-buffers-for-typescript (hemlock.wire:make-remote-object slave-info) + (hemlock.wire:make-remote-object background-info))) + (setf *newly-created-slave* server-info) + (values)))) + + +;;; CREATE-SLAVE -- Public. +;;; +#+NILGB +(defun create-slave (&optional name) + "This creates a slave that tries to connect to the editor. When the slave + connects to the editor, this returns a slave-information structure. Name is + the name of the interactive buffer. If name is nil, this generates a name. + If name is supplied, and a buffer with that name already exists, this + signals an error. In case the slave never connects, this will eventually + timeout and signal an editor-error." + (when (and name (getstring name *buffer-names*)) + (editor-error "Buffer ~A is already in use." name)) + (let ((lisp (unix-namestring (merge-pathnames (value slave-utility) "path:") + t t))) + (unless lisp + (editor-error "Can't find ``~S'' in your path to run." + (value slave-utility))) + (multiple-value-bind (slave background) + (if name + (values name (format nil "Background ~A" name)) + (pick-slave-buffer-names)) + (when (value confirm-slave-creation) + (setf slave (prompt-for-string + :prompt "New slave name? " + :help "Enter the name to use for the newly created slave." + :default slave + :default-string slave)) + (setf background (format nil "Background ~A" slave)) + (when (getstring slave *buffer-names*) + (editor-error "Buffer ~A is already in use." slave)) + (when (getstring background *buffer-names*) + (editor-error "Buffer ~A is already in use." background))) + (message "Spawning slave ... ") + (let ((proc + (ext:run-program lisp + `("-slave" ,(get-editor-name) + ,@(if slave (list "-slave-buffer" slave)) + ,@(if background + (list "-background-buffer" background)) + ,@(value slave-utility-switches)) + :wait nil + :output "/dev/null" + :if-output-exists :append)) + (*accept-connections* t) + (*newly-created-slave* nil)) + (unless proc + (editor-error "Could not start slave.")) + (dotimes (i *slave-connect-wait* + (editor-error + "Client Lisp is still unconnected. ~ + You must use \"Accept Slave Connections\" to ~ + allow the slave to connect at this point.")) + (system:serve-event 1) + (case (ext:process-status proc) + (:exited + (editor-error "The slave lisp exited before connecting.")) + (:signaled + (editor-error "The slave lisp was kill before connecting."))) + (when *newly-created-slave* + (message "DONE") + (return *newly-created-slave*))))))) + +;;; MAYBE-CREATE-SERVER -- Internal interface. +;;; +(defun maybe-create-server () + "If there is an existing server and \"Ask about Old Servers\" is set, then + prompt for a server's name and return that server's info. Otherwise, + create a new server." + (if (value ask-about-old-servers) + (multiple-value-bind (first-server-name first-server-info) + (do-strings (name info *server-names*) + (return (values name info))) + (if first-server-info + (multiple-value-bind + (name info) + (prompt-for-keyword (list *server-names*) + :prompt "Existing server name: " + :default first-server-name + :default-string first-server-name + :help + "Enter the name of an existing eval server." + :must-exist t) + (declare (ignore name)) + (or info (create-slave))) + (create-slave))) + (create-slave))) + + +(defvar *next-slave-index* 0 + "Number to use when creating the next slave.") + +;;; PICK-SLAVE-BUFFER-NAMES -- Internal. +;;; +;;; Return two unused names to use for the slave and background buffers. +;;; +(defun pick-slave-buffer-names () + (loop + (let ((slave (format nil "Slave ~D" (incf *next-slave-index*))) + (background (format nil "Background Slave ~D" *next-slave-index*))) + (unless (or (getstring slave *buffer-names*) + (getstring background *buffer-names*)) + (return (values slave background)))))) + + + + +;;;; Slave selection. + +;;; GET-CURRENT-EVAL-SERVER -- Public. +;;; +(defun get-current-eval-server (&optional errorp) + "Returns the server-info struct for the current eval server. If there is + none, and errorp is non-nil, then signal an editor error. If there is no + current server, and errorp is nil, then create one, prompting the user for + confirmation. Also, set the current server to be the newly created one." + (let ((info (value current-eval-server))) + (cond (info) + (errorp + (editor-error "No current eval server.")) + (t + (setf (value current-eval-server) (maybe-create-server)))))) + +;;; GET-CURRENT-COMPILE-SERVER -- Public. +;;; +;;; If a current compile server is defined, return it, otherwise return the +;;; current eval server using get-current-eval-server. +;;; +(defun get-current-compile-server (&optional errorp) + "Returns the server-info struct for the current compile server. If there is + no current compile server, return the current eval server." + (or (value current-compile-server) + (get-current-eval-server errorp))) + + + + +;;;; Server Manipulation commands. + +(defcommand "Select Slave" (p) + "Switch to the current slave's buffer. When given an argument, create a new + slave." + "Switch to the current slave's buffer. When given an argument, create a new + slave." + (let* ((info (if p (create-slave) (get-current-eval-server))) + (slave (server-info-slave-buffer info))) + (unless slave + (editor-error "The current eval server doesn't have a slave buffer!")) + (change-to-buffer slave))) + +(defcommand "Select Background" (p) + "Switch to the current slave's background buffer. When given an argument, use + the current compile server instead of the current eval server." + "Switch to the current slave's background buffer. When given an argument, use + the current compile server instead of the current eval server." + (let* ((info (if p + (get-current-compile-server t) + (get-current-eval-server t))) + (background (server-info-background-buffer info))) + (unless background + (editor-error "The current ~A server doesn't have a background buffer!" + (if p "compile" "eval"))) + (change-to-buffer background))) + +#+NILGB +(defcommand "Kill Slave" (p) + "This aborts any operations in the slave, tells the slave to QUIT, and shuts + down the connection to the specified eval server. This makes no attempt to + assure the eval server actually dies." + "This aborts any operations in the slave, tells the slave to QUIT, and shuts + down the connection to the specified eval server. This makes no attempt to + assure the eval server actually dies." + (declare (ignore p)) + (let ((default (and (value current-eval-server) + (server-info-name (value current-eval-server))))) + (multiple-value-bind + (name info) + (prompt-for-keyword + (list *server-names*) + :prompt "Kill Slave: " + :help "Enter the name of the eval server you wish to destroy." + :must-exist t + :default default + :default-string default) + (declare (ignore name)) + (let ((wire (server-info-wire info))) + (when wire + (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) + (hemlock.wire:remote wire (ext:quit)) + (hemlock.wire:wire-force-output wire))) + (server-died info)))) + +#+NILGB +(defcommand "Kill Slave and Buffers" (p) + "This is the same as \"Kill Slave\", but it also deletes the slaves + interaction and background buffers." + "This is the same as \"Kill Slave\", but it also deletes the slaves + interaction and background buffers." + (declare (ignore p)) + (let ((default (and (value current-eval-server) + (server-info-name (value current-eval-server))))) + (multiple-value-bind + (name info) + (prompt-for-keyword + (list *server-names*) + :prompt "Kill Slave: " + :help "Enter the name of the eval server you wish to destroy." + :must-exist t + :default default + :default-string default) + (declare (ignore name)) + (let ((wire (server-info-wire info))) + (when wire + (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) + (hemlock.wire:remote wire (ext:quit)) + (hemlock.wire:wire-force-output wire))) + (let ((buffer (server-info-slave-buffer info))) + (when buffer (delete-buffer-if-possible buffer))) + (let ((buffer (server-info-background-buffer info))) + (when buffer (delete-buffer-if-possible buffer))) + (server-died info)))) + +(defcommand "Accept Slave Connections" (p) + "This causes Hemlock to accept slave connections and displays the port of + the editor's connections request server. This is suitable for use with the + Lisp's -slave switch. Given an argument, this inhibits slave connections." + "This causes Hemlock to accept slave connections and displays the port of + the editor's connections request server. This is suitable for use with the + Lisp's -slave switch. Given an argument, this inhibits slave connections." + (let ((accept (not p))) + (setf *accept-connections* accept) + (message "~:[Inhibiting~;Accepting~] connections to ~S" + accept (get-editor-name)))) + + + + +;;;; Slave initialization junk. + +(defvar *original-beep-function* nil + "Handle on original beep function.") + +(defvar *original-gc-notify-before* nil + "Handle on original before-GC notification function.") + +(defvar *original-gc-notify-after* nil + "Handle on original after-GC notification function.") + +(defvar *original-terminal-io* nil + "Handle on original *terminal-io* so we can restore it.") + +(defvar *original-standard-input* nil + "Handle on original *standard-input* so we can restore it.") + +(defvar *original-standard-output* nil + "Handle on original *standard-output* so we can restore it.") + +(defvar *original-error-output* nil + "Handle on original *error-output* so we can restore it.") + +(defvar *original-debug-io* nil + "Handle on original *debug-io* so we can restore it.") + +(defvar *original-query-io* nil + "Handle on original *query-io* so we can restore it.") + +(defvar *original-trace-output* nil + "Handle on original *trace-output* so we can restore it.") + +(defvar *background-io* nil + "Stream connected to the editor's background buffer in case we want to use it + in the future.") + +;;; CONNECT-STREAM -- internal +;;; +;;; Run in the slave to create a new stream and connect it to the supplied +;;; buffer. Returns the stream. +;;; +(defun connect-stream (remote-buffer) + (let ((stream (make-ts-stream hemlock.wire:*current-wire* remote-buffer))) + (hemlock.wire:remote hemlock.wire:*current-wire* + (ts-buffer-set-stream remote-buffer + (hemlock.wire:make-remote-object stream))) + stream)) + +;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface. +;;; +;;; Run in the slave by the editor with the two buffers' info structures, +;;; actually remote-objects in the slave. Does any necessary stream hacking. +;;; Return nil to make sure no weird objects try to go back over the wire +;;; since the editor calls this in the slave for value. The editor does this +;;; for synch'ing, not for values. +;;; +(defun made-buffers-for-typescript (slave-info background-info) + (setf *original-terminal-io* *terminal-io*) + (warn "made-buffers-for-typescript ~S ~S ~S." + (connect-stream slave-info) + *terminal-io* + (connect-stream background-info)) + (sleep 3) + (macrolet ((frob (symbol new-value) + `(setf ,(intern (concatenate 'simple-string + "*ORIGINAL-" + (subseq (string symbol) 1))) + ,symbol + ,symbol ,new-value))) + #+NILGB + (let ((wire hemlock.wire:*current-wire*)) + (frob system:*beep-function* + #'(lambda (&optional stream) + (declare (ignore stream)) + (hemlock.wire:remote-value wire (beep)))) + (frob ext:*gc-notify-before* + #'(lambda (bytes-in-use) + (hemlock.wire:remote wire + (slave-gc-notify-before + slave-info + (format nil + "~%[GC threshold exceeded with ~:D bytes in use. ~ + Commencing GC.]~%" + bytes-in-use))) + (hemlock.wire:wire-force-output wire))) + (frob ext:*gc-notify-after* + #'(lambda (bytes-retained bytes-freed new-trigger) + (hemlock.wire:remote wire + (slave-gc-notify-after + slave-info + (format nil + "[GC completed with ~:D bytes retained and ~:D ~ + bytes freed.]~%[GC will next occur when at least ~ + ~:D bytes are in use.]~%" + bytes-retained bytes-freed new-trigger))) + (hemlock.wire:wire-force-output wire)))) + (warn "#7")(sleep 1) + (frob *terminal-io* (connect-stream slave-info)) + #+NIL + (progn + (setf cl-user::*io* (connect-stream slave-info)) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#8")(sleep 1)) + (frob *standard-input* (make-synonym-stream '*terminal-io*)) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#9")(sleep 1)) + (frob *standard-output* *standard-input*) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#10")(sleep 1)) + ;;### + ;;(frob *error-output* *standard-input*) + ;;(frob *debug-io* *standard-input*) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#11")(sleep 1)) + (frob *query-io* *standard-input*) + (let ((*terminal-io* *original-terminal-io*)) + (warn "#12")(sleep 1))) + (frob *trace-output* *original-terminal-io*) + ) + #+NILGB (setf *background-io* (connect-stream background-info)) + nil) + +;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal +;;; +;;; These two routines are run in the editor by the slave's gc notify routines. +;;; +(defun slave-gc-notify-before (remote-ts message) + (let ((ts (hemlock.wire:remote-object-value remote-ts))) + (ts-buffer-output-string ts message t) + (when (value slave-gc-alarm) + (message "~A is GC'ing." (buffer-name (ts-data-buffer ts))) + (when (eq (value slave-gc-alarm) :loud-message) + (beep))))) + +(defun slave-gc-notify-after (remote-ts message) + (let ((ts (hemlock.wire:remote-object-value remote-ts))) + (ts-buffer-output-string ts message t) + (when (value slave-gc-alarm) + (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts))) + (when (eq (value slave-gc-alarm) :loud-message) + (beep))))) + +;;; EDITOR-DIED -- internal +;;; +;;; Run in the slave when the editor goes belly up. +;;; +(defun editor-died () + (macrolet ((frob (symbol) + (let ((orig (intern (concatenate 'simple-string + "*ORIGINAL-" + (subseq (string symbol) 1))))) + `(when ,orig + (setf ,symbol ,orig))))) + #+NILGB + (progn + (frob system:*beep-function*) + (frob ext:*gc-notify-before*) + (frob ext:*gc-notify-after*)) + (frob *terminal-io*) + (frob *standard-input*) + (frob *standard-output*) + (frob *error-output*) + (frob *debug-io*) + (frob *query-io*) + (frob *trace-output*)) + (setf *background-io* nil) + (format t "~2&Connection to editor died.~%") + #+NILGB + (ext:quit)) + +;;; START-SLAVE -- internal +;;; +;;; Initiate the process by which a lisp becomes a slave. +;;; +(defun start-slave (editor) + (declare (simple-string editor)) + (let ((seperator (position #\: editor :test #'char=))) + (unless seperator + (error "Editor name ~S invalid. ~ + Must be of the form \"MachineName:PortNumber\"." + editor)) + (let ((machine (subseq editor 0 seperator)) + (port (parse-integer editor :start (1+ seperator)))) + (format t "Connecting to ~A:~D~%" machine port) + (connect-to-editor machine port)))) + + +;;; PRINT-SLAVE-STATUS -- Internal +;;; +;;; Print out some useful information about what the slave is up to. +;;; +#+NILGB +(defun print-slave-status () + (ignore-errors + (multiple-value-bind (sys user faults) + (system:get-system-info) + (let* ((seconds (truncate (+ sys user) 1000000)) + (minutes (truncate seconds 60)) + (hours (truncate minutes 60)) + (days (truncate hours 24))) + (format *error-output* "~&; Used ~D:~2,'0D:~2,'0D~V@{!~}, " + hours (rem minutes 60) (rem seconds 60) days)) + (format *error-output* "~D fault~:P. In: " faults) + + (do ((i 0 (1+ i)) + (frame (di:top-frame) (di:frame-down frame))) + (#-x86(= i 3) + #+x86 + (and (> i 6) ; get past extra cruft + (let ((name (di:debug-function-name + (di:frame-debug-function frame)))) + (and (not (string= name "Bogus stack frame")) + (not (string= name "Foreign function call land"))))) + (prin1 (di:debug-function-name (di:frame-debug-function frame)) + *error-output*)) + (unless frame (return))) + (terpri *error-output*) + (force-output *error-output*))) + (values)) + + +;;; CONNECT-TO-EDITOR -- internal +;;; +;;; Do the actual connect to the editor. +;;; +(defun connect-to-editor (machine port + &optional + (slave (find-eval-server-switch "slave-buffer")) + (background (find-eval-server-switch + "background-buffer"))) + (let ((wire (hemlock.wire:connect-to-remote-server machine port 'editor-died))) + #+NILGB + (progn + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\B + #'(lambda () + (system:without-hemlock + (system:with-interrupts + (break "Software Interrupt"))))) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\T + #'(lambda () + (when lisp::*in-top-level-catcher* + (throw 'lisp::top-level-catcher nil)))) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\A + #'abort) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) + #\N + #'(lambda () + (setf *abort-operations* t) + (when *inside-operation* + (throw 'abort-operation + (if debug::*in-the-debugger* + :was-in-debugger))))) + (ext:add-oob-handler (hemlock.wire:wire-fd wire) #\S #'print-slave-status)) + + (hemlock.wire:remote-value wire + (make-buffers-for-typescript slave background)))) + + + +;;;; Eval server evaluation functions. + +(defvar *eval-form-stream* + (make-two-way-stream + #+NILGB + (lisp::make-lisp-stream + :in #'(lambda (&rest junk) + (declare (ignore junk)) + (error "You cannot read when handling an eval_form request."))) + #-NILGB + (make-concatenated-stream) + (make-broadcast-stream))) + +;;; SERVER-EVAL-FORM -- Public. +;;; Evaluates the given form (which is a string to be read from in the given +;;; package) and returns the results as a list. +;;; +(defun server-eval-form (package form) + (declare (type (or string null) package) (simple-string form)) + (handler-bind + ((error #'(lambda (condition) + (hemlock.wire:remote hemlock.wire:*current-wire* + (eval-form-error (format nil "~A~&" condition))) + (return-from server-eval-form nil)))) + (let ((*package* (if package + (lisp::package-or-lose package) + *package*)) + (*terminal-io* *eval-form-stream*)) + (stringify-list (multiple-value-list (eval (read-from-string form))))))) + + +;;; DO-OPERATION -- Internal. +;;; Checks to see if we are aborting operations. If not, do the operation +;;; wrapping it with operation-started and operation-completed calls. Also +;;; deals with setting up *terminal-io* and *package*. +;;; +(defmacro do-operation ((note package terminal-io) &body body) + `(let ((aborted t) + (*terminal-io* (if ,terminal-io + (hemlock.wire:remote-object-value ,terminal-io) + *terminal-io*)) + (*package* (maybe-make-package ,package))) + (unwind-protect + (unless *abort-operations* + (when (eq :was-in-debugger + (catch 'abort-operation + (let ((*inside-operation* t)) + (hemlock.wire:remote hemlock.wire:*current-wire* + (operation-started ,note)) + (hemlock.wire:wire-force-output hemlock.wire:*current-wire*) + ,@body + (setf aborted nil)))) + (format t + "~&[Operation aborted. ~ + You are no longer in this instance of the debugger.]~%"))) + (hemlock.wire:remote hemlock.wire:*current-wire* + (operation-completed ,note aborted)) + (hemlock.wire:wire-force-output hemlock.wire:*current-wire*)))) + + +;;; unique-thingie is a unique eof-value for READ'ing. Its a parameter, so +;;; we can reload the file. +;;; +(defparameter unique-thingie (gensym) + "Used as eof-value in reads to check for the end of a file.") + +;;; SERVER-EVAL-TEXT -- Public. +;;; +;;; Evaluate all the forms read from text in the given package, and send the +;;; results back. The error handler bound does not handle any errors. It +;;; simply notifies the client that an error occurred and then returns. +;;; +(defun server-eval-text (note package text terminal-io) + (do-operation (note package terminal-io) + (with-input-from-string (stream text) + (let ((last-pos 0)) + (handler-bind + ((error + #'(lambda (condition) + (hemlock.wire:remote hemlock.wire:*current-wire* + (lisp-error note last-pos + (file-position stream) + (format nil "~A~&" condition)))))) + (loop + (let ((form (read stream nil unique-thingie))) + (when (eq form unique-thingie) + (return nil)) + (let* ((values (stringify-list (multiple-value-list (eval form)))) + (pos (file-position stream))) + (hemlock.wire:remote hemlock.wire:*current-wire* + (eval-text-result note last-pos pos values)) + (setf last-pos pos))))))))) + +(defun stringify-list (list) + (mapcar #'prin1-to-string list)) +#| +(defun stringify-list (list) + (mapcar #'(lambda (thing) + (with-output-to-string (stream) + (write thing + :stream stream :radix nil :base 10 :circle t + :pretty nil :level nil :length nil :case :upcase + :array t :gensym t))) + list)) +|# + + + +;;;; Eval server compilation stuff. + +;;; DO-COMPILER-OPERATION -- Internal. +;;; +;;; Useful macro that does the operation with *compiler-note* and +;;; *compiler-wire* bound. +;;; +(defmacro do-compiler-operation ((note package terminal-io error) &body body) + #+NILGB + `(let ((*compiler-note* ,note) + (*compiler-error-stream* ,error) + (*compiler-wire* hemlock.wire:*current-wire*) + (c:*compiler-notification-function* #'compiler-note-in-editor)) + (do-operation (*compiler-note* ,package ,terminal-io) + (unwind-protect + (handler-bind ((error #'compiler-error-handler)) + ,@body) + (when *compiler-error-stream* + (force-output *compiler-error-stream*)))))) + +;;; COMPILER-NOTE-IN-EDITOR -- Internal. +;;; +;;; DO-COMPILER-OPERATION binds c:*compiler-notification-function* to this, so +;;; interesting observations in the compilation can be propagated back to the +;;; editor. If there is a notification point defined, we send information +;;; about the position and kind of error. The actual error text is written out +;;; using typescript operations. +;;; +;;; Start and End are the compiler's best guess at the file position where the +;;; error occurred. Function is some string describing where the error was. +;;; +(defun compiler-note-in-editor (severity function name pos) + (declare (ignore name)) + (when *compiler-wire* + (force-output *compiler-error-stream*) + (hemlock.wire:remote *compiler-wire* + (compiler-error *compiler-note* pos pos function severity))) + (hemlock.wire:wire-force-output *compiler-wire*)) + + +;;; COMPILER-ERROR-HANDLER -- Internal. +;;; +;;; The error handler function for the compiler interfaces. +;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the +;;; compilation form. +;;; +(defun compiler-error-handler (condition) + (when *compiler-wire* + (hemlock.wire:remote *compiler-wire* + (lisp-error *compiler-note* nil nil + (format nil "~A~&" condition))))) + + +;;; SERVER-COMPILE-TEXT -- Public. +;;; +;;; Similar to server-eval-text, except that the stuff is compiled. +;;; +#+NILGB +(defun server-compile-text (note package text defined-from + terminal-io error-output) + (let ((error-output (if error-output + (hemlock.wire:remote-object-value error-output)))) + (do-compiler-operation (note package terminal-io error-output) + (with-input-from-string (input-stream text) + (terpri error-output) + (c::compile-from-stream input-stream + :error-stream error-output + :source-info defined-from))))) + +;;; SERVER-COMPILE-FILE -- Public. +;;; +;;; Compiles the file sending error info back to the editor. +;;; +(defun server-compile-file (note package input output error trace + load terminal background) + (macrolet ((frob (x) + `(if (hemlock.wire:remote-object-p ,x) + (hemlock.wire:remote-object-value ,x) + ,x))) + (let ((error-stream (frob background))) + (do-compiler-operation (note package terminal error-stream) + (compile-file (frob input) + :output-file (frob output) + :error-file (frob error) + :trace-file (frob trace) + :load load + :error-output error-stream))))) + + + +;;;; Other random eval server stuff. + +;;; MAYBE-MAKE-PACKAGE -- Internal. +;;; +;;; Returns a package for a name. Creates it if it doesn't already exist. +;;; +(defun maybe-make-package (name) + (cond ((null name) *package*) + ((find-package name)) + (t + (hemlock.wire:remote-value (ts-stream-wire *terminal-io*) + (ts-buffer-output-string + (ts-stream-typescript *terminal-io*) + (format nil "~&Creating package ~A.~%" name) + t)) + (make-package name)))) + +;;; SERVER-SET-PACKAGE -- Public. +;;; +;;; Serves package setting requests. It simply sets +;;; *package* to an already existing package or newly created one. +;;; +(defun server-set-package (package) + (setf *package* (maybe-make-package package))) + +;;; SERVER-ACCEPT-OPERATIONS -- Public. +;;; +;;; Start accepting operations again. +;;; +(defun server-accept-operations () + (setf *abort-operations* nil)) + + + + +;;;; Command line switches. + +#+NILGB +(progn + +;;; FIND-EVAL-SERVER-SWITCH -- Internal. +;;; +;;; This is special to the switches supplied by CREATE-SLAVE and fetched by +;;; CONNECT-EDITOR-SERVER, so we can use STRING=. +;;; +(defun find-eval-server-switch (string) + #+NILGB + (let ((switch (find string ext:*command-line-switches* + :test #'string= + :key #'ext:cmd-switch-name))) + (if switch + (or (ext:cmd-switch-value switch) + (car (ext:cmd-switch-words switch)))))) + + +(defun slave-switch-demon (switch) + (let ((editor (ext:cmd-switch-arg switch))) + (unless editor + (error "Editor to connect to unspecified.")) + (start-slave editor) + (setf debug:*help-line-scroll-count* most-positive-fixnum))) +;;; +(defswitch "slave" 'slave-switch-demon) +(defswitch "slave-buffer") +(defswitch "background-buffer") + + +(defun edit-switch-demon (switch) + (declare (ignore switch)) +#| (let ((arg (or (ext:cmd-switch-value switch) + (car (ext:cmd-switch-words switch))))) + (when (stringp arg) (setq *editor-name* arg)))|# + (let ((initp (not (ext:get-command-line-switch "noinit")))) + (if (stringp (car ext:*command-line-words*)) + (ed (car ext:*command-line-words*) :init initp) + (ed nil :init initp)))) +;;; +(defswitch "edit" 'edit-switch-demon) +) + +#+SBCL +(defun hemlock.wire::serve-all-events () + (sleep .1)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/group.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/group.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/group.lisp (revision 8058) @@ -0,0 +1,238 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; File group stuff for Hemlock. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; +;;; The "Compile Group" and "List Compile Group" commands in lispeval +;;; also know about groups. +;;; +;;; This file provides Hemlock commands for manipulating groups of files +;;; that make up a larger system. A file group is a set of files whose +;;; names are listed in some other file. At any given time one group of +;;; files is the Active group. The Select Group command makes a group the +;;; Active group, prompting for the name of a definition file if the group +;;; has not been selected before. Once a group has been selected once, the +;;; name of the definition file associated with that group is retained. If +;;; one wishes to change the name of the definition file after a group has +;;; been selected, one should call Select Group with a prefix argument. + +(in-package :hemlock) + +(defvar *file-groups* (make-string-table) + "A string table of file groups.") + +(defvar *active-file-group* () + "The list of files in the currently active group.") + +(defvar *active-file-group-name* () + "The name of the currently active group.") + + + + +;;;; Selecting the active group. + +(defcommand "Select Group" (p) + "Makes a group the active group. With a prefix argument, changes the + definition file associated with the group." + "Makes a group the active group." + (let* ((group-name + (prompt-for-keyword + (list *file-groups*) + :must-exist nil + :prompt "Select Group: " + :help + "Type the name of the file group you wish to become the active group.")) + (old (getstring group-name *file-groups*)) + (pathname + (if (and old (not p)) + old + (prompt-for-file :must-exist t + :prompt "From File: " + :default (merge-pathnames + (make-pathname + :name group-name + :type "upd") + (value pathname-defaults)))))) + (setq *active-file-group-name* group-name) + (setq *active-file-group* (nreverse (read-file-group pathname nil))) + (setf (getstring group-name *file-groups*) pathname))) + + +;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames +;;; of the files named in that file. This guy knows about @@ indirection and +;;; ignores empty lines and lines that begin with @ but not @@. A simpler +;;; scheme could be used for non-Spice implementations, but all this hair is +;;; probably useful, so Update format may as well be a standard for this sort +;;; of thing. +;;; +(defun read-file-group (pathname tail) + (with-open-file (file pathname) + (do* ((name (read-line file nil nil) (read-line file nil nil)) + (length (if name (length name)) (if name (length name)))) + ((null name) tail) + (declare (type (or simple-string null) name)) + (cond ((zerop length)) + ((char= (char name 0) #\@) + (when (and (> length 1) (char= (char name 1) #\@)) + (setq tail (read-file-group + (merge-pathnames (subseq name 2) + pathname) + tail)))) + (t + (push (merge-pathnames (pathname name) pathname) tail)))))) + + + + +;;;; DO-ACTIVE-GROUP. + +(defhvar "Group Find File" + "If true, group commands use \"Find File\" to read files, otherwise + non-resident files are read into the \"Group Search\" buffer." + :value nil) + +(defhvar "Group Save File Confirm" + "If true, then the group commands will ask for confirmation before saving + a modified file." :value t) + +(defmacro do-active-group (&rest forms) + "This iterates over the active file group executing forms once for each + file. When forms are executed, the file will be in the current buffer, + and the point will be at the start of the file." + (let ((n-buf (gensym)) + (n-start-buf (gensym)) + (n-save (gensym))) + `(progn + (unless *active-file-group* + (editor-error "There is no active file group.")) + + (let ((,n-start-buf (current-buffer)) + (,n-buf nil)) + (unwind-protect + (dolist (file *active-file-group*) + (catch 'file-not-found + (setq ,n-buf (group-read-file file ,n-buf)) + (with-mark ((,n-save (current-point) :right-inserting)) + (unwind-protect + (progn + (buffer-start (current-point)) + ,@forms) + (move-mark (current-point) ,n-save))) + (group-save-file))) + (if (member ,n-start-buf *buffer-list*) + (setf (current-buffer) ,n-start-buf + (window-buffer (current-window)) ,n-start-buf) + (editor-error "Original buffer deleted!"))))))) + +;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP. +;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't +;;; already been read, to get files in, and then we delete the buffer if it is +;;; newly created and "Group Find File" is false. This lets FIND-FILE-BUFFER +;;; do all the work. We don't actually use the "Find File" command, so the +;;; buffer history isn't affected. +;;; +;;; Search-Buffer is any temporary search buffer left over from the last file +;;; that we want deleted. We don't do the deletion if the buffer is modified. +;;; +(defun group-read-file (name search-buffer) + (unless (probe-file name) + (message "File ~A not found." name) + (throw 'file-not-found nil)) + (multiple-value-bind (buffer created-p) + (find-file-buffer name) + (setf (current-buffer) buffer) + (setf (window-buffer (current-window)) buffer) + + (when (and search-buffer (not (buffer-modified search-buffer))) + (dolist (w (buffer-windows search-buffer)) + (setf (window-buffer w) (current-buffer))) + (delete-buffer search-buffer)) + + (if (and created-p (not (value group-find-file))) + (current-buffer) nil))) + +;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP. +;;; +(defun group-save-file () + (let* ((buffer (current-buffer)) + (pn (buffer-pathname buffer)) + (name (namestring pn))) + (when (and (buffer-modified buffer) + (or (not (value group-save-file-confirm)) + (prompt-for-y-or-n + :prompt (list "Save changes in ~A? " name) + :default t))) + (save-file-command ())))) + + + + +;;;; Searching and Replacing commands. + +(defcommand "Group Search" (p) + "Searches the active group for a specified string, which is prompted for." + "Searches the active group for a specified string." + (declare (ignore p)) + (let ((string (prompt-for-string :prompt "Group Search: " + :help "String to search for in active file group" + :default *last-search-string*))) + (get-search-pattern string :forward) + (do-active-group + (do ((won (find-pattern (current-point) *last-search-pattern*) + (find-pattern (current-point) *last-search-pattern*))) + ((not won)) + (character-offset (current-point) won) + (command-case + (:prompt "Group Search: " + :help "Type a character indicating the action to perform." + :change-window nil) + (:no "Search for the next occurrence.") + (:do-all "Go on to the next file in the group." + (return nil)) + ((:exit :yes) "Exit the search." + (return-from group-search-command)) + (:recursive-edit "Enter a recursive edit." + (do-recursive-edit) + (get-search-pattern string :forward))))) + (message "All files in group ~S searched." *active-file-group-name*))) + +(defcommand "Group Replace" (p) + "Replaces one string with another in the active file group." + "Replaces one string with another in the active file group." + (declare (ignore p)) + (let* ((target (prompt-for-string :prompt "Group Replace: " + :help "Target string" + :default *last-search-string*)) + (replacement (prompt-for-string :prompt "With: " + :help "Replacement string"))) + (do-active-group + (query-replace-function nil target replacement + "Group Replace on previous file" t)) + (message "Replacement done in all files in group ~S." + *active-file-group-name*))) + +(defcommand "Group Query Replace" (p) + "Query Replace for the active file group." + "Query Replace for the active file group." + (declare (ignore p)) + (let ((target (prompt-for-string :prompt "Group Query Replace: " + :help "Target string" + :default *last-search-string*))) + (let ((replacement (prompt-for-string :prompt "With: " + :help "Replacement string"))) + (do-active-group + (unless (query-replace-function + nil target replacement "Group Query Replace on previous file") + (return nil))) + (message "Replacement done in all files in group ~S." + *active-file-group-name*)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/highlight.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/highlight.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/highlight.lisp (revision 8058) @@ -0,0 +1,211 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Highlighting paren and some other good stuff. +;;; +;;; Written by Bill Chiles and Jim Healy. +;;; + +(in-package :hemlock) + + + + +;;;; Open parens. + +(defhvar "Highlight Open Parens" + "When non-nil, causes open parens to be displayed in a different font when + the cursor is directly to the right of the corresponding close paren." + :value nil) + +(defhvar "Open Paren Finder Function" + "Should be a function that takes a mark for input and returns either NIL + if the mark is not after a close paren, or two (temporary) marks + surrounding the corresponding open paren." + :value 'lisp-open-paren-finder-function) + + +(defvar *open-paren-font-marks* nil + "The pair of font-marks surrounding the currently highlighted open- + paren or nil if there isn't one.") + +(defvar *open-paren-highlight-font* 2 + "The index into the font-map for the open paren highlighting font.") + + +;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by +;;; highlighting the corresponding open-paren after a close-paren is +;;; typed. +;;; +(defun maybe-highlight-open-parens (window) + (declare (ignore window)) + (when (value highlight-open-parens) + (if (and (value highlight-active-region) (region-active-p)) + (kill-open-paren-font-marks) + (multiple-value-bind + (start end) + (funcall (value open-paren-finder-function) + (current-point)) + (if (and start end) + (set-open-paren-font-marks start end) + (kill-open-paren-font-marks)))))) +;;; +(add-hook redisplay-hook 'maybe-highlight-open-parens) + +(defun set-open-paren-font-marks (start end) + (if *open-paren-font-marks* + (flet ((maybe-move (dst src) + (unless (mark= dst src) + (move-font-mark dst src)))) + (declare (inline maybe-move)) + (maybe-move (region-start *open-paren-font-marks*) start) + (maybe-move (region-end *open-paren-font-marks*) end)) + (let ((line (mark-line start))) + (setf *open-paren-font-marks* + (region + (font-mark line (mark-charpos start) + *open-paren-highlight-font*) + (font-mark line (mark-charpos end) 0)))))) + +(defun kill-open-paren-font-marks () + (when *open-paren-font-marks* + (delete-font-mark (region-start *open-paren-font-marks*)) + (delete-font-mark (region-end *open-paren-font-marks*)) + (setf *open-paren-font-marks* nil))) + + + + + +;;;; Active regions. + +(defvar *active-region-font-marks* nil) +(defvar *active-region-highlight-font* 3 + "The index into the font-map for the active region highlighting font.") + + +;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions. +;;; Since it is too hard to know how the region may have changed when it is +;;; active and already highlighted, if it does not check out to being exactly +;;; the same, we just delete all the font marks and make new ones. When +;;; the current window is the echo area window, just pretend everything is +;;; okay; this keeps the region highlighted while we're in there. +;;; +(defun highlight-active-region (window) + (unless (eq window *echo-area-window*) + (when (value highlight-active-region) + (cond ((region-active-p) + (cond ((not *active-region-font-marks*) + (set-active-region-font-marks)) + ((check-active-region-font-marks)) + (t (kill-active-region-font-marks) + (set-active-region-font-marks)))) + (*active-region-font-marks* + (kill-active-region-font-marks)))))) +;;; +(add-hook redisplay-hook 'highlight-active-region) + +(defun set-active-region-font-marks () + (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*)) + (push (font-mark (mark-line m) (mark-charpos m) font) + *active-region-font-marks*))) + (let* ((region (current-region nil nil)) + (start (region-start region)) + (end (region-end region))) + (with-mark ((mark start)) + (unless (mark= mark end) + (loop + (stash-a-mark mark) + (unless (line-offset mark 1 0) (return)) + (when (mark>= mark end) (return))) + (unless (start-line-p end) (stash-a-mark end 0)))))) + (setf *active-region-font-marks* (nreverse *active-region-font-marks*))) + +(defun kill-active-region-font-marks () + (dolist (m *active-region-font-marks*) + (delete-font-mark m)) + (setf *active-region-font-marks* nil)) + +;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same +;;; as that what is highlighted on the screen. This assumes +;;; *active-region-font-marks* is non-nil. At the very beginning, our start +;;; mark must not be at the end; it must be at the first font mark; and the +;;; font marks must be in the current buffer. We don't make font marks if the +;;; start is at the end, so if this is the case, then they just moved together. +;;; We return nil in this case to kill all the font marks and make new ones, but +;;; no new ones will be made. +;;; +;;; Sometimes we hack the font marks list and return t because we can easily +;;; adjust the highlighting to be correct. This keeps all the font marks from +;;; being killed and re-established. In the loop, if there are no more font +;;; marks, we either ended a region already highlighted on the next line down, +;;; or we have to revamp the font marks. Before returning here, we see if the +;;; region ends one more line down at the beginning of the line. If this is +;;; true, then the user is simply doing "Next Line" at the beginning of the +;;; line. +;;; +;;; Each time through the loop we look at the top font mark, move our roving +;;; mark down one line, and see if they compare. If they are not equal, the +;;; region may still be the same as that highlighted on the screen. If this +;;; is the last font mark, not at the beginning of the line, and it is at the +;;; region's end, then this last font mark is in the middle of a line somewhere +;;; changing the font from the highlighting font to the default font. Return +;;; t. +;;; +;;; If our roving mark is not at the current font mark, but it is at or after +;;; the end of the active region, then the end of the active region has moved +;;; before its previous location. +;;; +;;; Otherwise, move on to the next font mark. +;;; +;;; If our roving mark never moved onto a next line, then the buffer ends on the +;;; previous line, and the last font mark changes from the highlighting font to +;;; the default font. +;;; +(defun check-active-region-font-marks () + (let* ((region (current-region nil nil)) + (end (region-end region))) + (with-mark ((mark (region-start region))) + (let ((first-active-mark (car *active-region-font-marks*)) + (last-active-mark (last *active-region-font-marks*))) + (if (and (mark/= mark end) + (eq (current-buffer) + (line-buffer (mark-line first-active-mark))) + (mark= first-active-mark mark)) + (let ((marks (cdr *active-region-font-marks*))) + (loop + (unless marks + (let ((res (and (line-offset mark 1 0) + (mark= mark end)))) + (when (and (not res) + (line-offset mark 1 0) + (mark= mark end) + (start-line-p (car last-active-mark))) + (setf (cdr last-active-mark) + (list (font-mark (line-previous (mark-line mark)) + 0 + *active-region-highlight-font*))) + (return t)) + (return res))) + (let ((fmark (car marks))) + (if (line-offset mark 1 0) + (cond ((mark/= mark fmark) + (return (and (not (cdr marks)) + (not (start-line-p fmark)) + (mark= fmark end)))) + ((mark>= mark end) + (return nil)) + (t (setf marks (cdr marks)))) + + (return (and (not (cdr marks)) + (not (start-line-p fmark)) + (mark= fmark end)))))))))))) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/hunk-draw.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/hunk-draw.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/hunk-draw.lisp (revision 8058) @@ -0,0 +1,504 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; +;;; Hemlock screen painting routines for the IBM RT running X. +;;; +(in-package :hemlock-internals) + + +;;;; TODO + +;; . do away with these bogus macros HUNK-PUT-STRING and HUNK-REPLACE-LINE-STRING. + +;; . concentrate these in a single point where we draw a string, so that we +;; can easily introduce foreground and background colors for syntax +;; highlighting and neater region highlighting. + +;; --GB 2003-05-22 + +(defparameter hunk-height-limit 80 "Maximum possible height for any hunk.") +(defparameter hunk-width-limit 200 "Maximum possible width for any hunk.") +(defparameter hunk-top-border 2 "Clear area at beginning.") +(defparameter hunk-left-border 10 "Clear area before first character.") +(defparameter hunk-bottom-border 3 "Minimum Clear area at end.") +(defparameter hunk-thumb-bar-bottom-border 10 + "Minimum Clear area at end including room for thumb bar." ) +(defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.") +(defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.") + + + + +;;;; Character translations for CLX + +;;; HEMLOCK-TRANSLATE-DEFAULT. +;;; +;;; CLX glyph drawing routines allow for a character translation function. The +;;; default one takes a string (any kind) or a vector of numbers and slams them +;;; into the outgoing request buffer. When the argument is a string, it stops +;;; processing if it sees a character that is not GRAPHIC-CHAR-P. For each +;;; graphical character, the function ultimately calls CHAR-CODE. +;;; +;;; Hemlock only passes simple-strings in, and these can only contain graphical +;;; characters because of the line image builder, except for one case -- +;;; *line-wrap-char* which anyone can set. Those who want to do evil things +;;; with this should know what they are doing: if they want a funny glyph as +;;; a line wrap char, then they should use CODE-CHAR on the font index. This +;;; allows the following function to translate everything with CHAR-CODE, and +;;; everybody's happy. +;;; +;;; Actually, Hemlock can passes the line string when doing random-typeout which +;;; does contain ^L's, tabs, etc. Under X10 these came out as funny glyphs, +;;; and under X11 the output is aborted without this function. +;;; +(defun hemlock-translate-default (src src-start src-end font dst dst-start) + (declare (simple-string src) + (fixnum src-start src-end dst-start) + (vector dst) + (ignore font)) + (do ((i src-start (1+ i)) + (j dst-start (1+ j))) + ((>= i src-end) i) + (declare (fixnum i j)) + (setf (aref dst j) (char-code (schar src i))))) + +#+clx +(defvar *glyph-translate-function* #'xlib:translate-default) + + + + +;;;; Drawing a line. + +;;;; We hack along --GB +#+clx +(defun find-color (window color) + (let ((ht (or (getf (xlib:window-plist window) :color-hash) + (setf (getf (xlib:window-plist window) :color-hash) + (make-hash-table :test #'equalp))))) + (or (gethash color ht) + (setf (gethash color ht) (xlib:alloc-color (xlib:window-colormap window) color))))) + +(defparameter *color-map* + #("black" "white" + "black" "white" + "black" "white" + "black" "cornflower blue" + + "black" "white" + "black" "white" + "black" "white" + "black" "white" + + "blue4" "white" ;8 = comments + "green4" "white" ;9 = strings + "red" "white" ;10 = quote + "black" "white" + + "black" "white" + "black" "white" + "black" "white" + "black" "white")) + +;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel +;;; coordinate to draw string with font from start to end. +;;; +(defmacro hunk-put-string (x y font string start end) + (let ((gcontext (gensym))) + `(let ((,gcontext (bitmap-hunk-gcontext hunk))) + (xlib:with-gcontext (,gcontext :font ,font) + (xlib:draw-image-glyphs + (bitmap-hunk-xwindow hunk) ,gcontext + (+ hunk-left-border (* ,x (font-family-width font-family))) + (+ hunk-top-border (* ,y (font-family-height font-family)) + (font-family-baseline font-family)) + ,string :start ,start :end ,end + :translate *glyph-translate-function*))))) + +(defun hunk-put-string* (hunk x y font-family font string start end) + (let ((gcontext (bitmap-hunk-gcontext hunk)) + (font (svref (font-family-map font-family) font)) + (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2)))) + (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2)))))) + (xlib:with-gcontext (gcontext :font font + :foreground fg + :background bg) + (xlib:draw-image-glyphs + (bitmap-hunk-xwindow hunk) gcontext + (+ hunk-left-border (* x (font-family-width font-family))) + (+ hunk-top-border (* y (font-family-height font-family)) + (font-family-baseline font-family)) + string :start start :end end + :translate *glyph-translate-function*)))) + +;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at +;;; which pixel coordinate to draw string with font from start to end. We draw +;;; the text on a pixmap and later blast it out to avoid line flicker since +;;; server on the RT is not very clever; it clears the entire line before +;;; drawing text. + +(defun hunk-replace-line-string* (hunk gcontext x y font-family font string start end) + (declare (ignore y)) + (let ((font (svref (font-family-map font-family) font)) + (fg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (* font 2)))) + (bg (find-color (bitmap-hunk-xwindow hunk) (svref *color-map* (1+ (* font 2)))))) + (xlib:with-gcontext (gcontext :font font + :foreground fg + :background bg) + (xlib:draw-image-glyphs + (hunk-replace-line-pixmap) gcontext + (+ hunk-left-border (* x (font-family-width font-family))) + (font-family-baseline font-family) + string :start start :end end + :translate *glyph-translate-function*)))) + +;;; Hunk-Write-Line -- Internal +;;; +;;; Paint a dis-line on a hunk, taking font-changes into consideration. +;;; The area of the hunk drawn on is assumed to be cleared. If supplied, +;;; the line is written at Position, and the position in the dis-line +;;; is ignored. +;;; +(defun hunk-write-line (hunk dl &optional (position (dis-line-position dl))) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (chars (dis-line-chars dl)) + (length (dis-line-length dl))) + (let ((last 0) + (last-font 0)) + (do ((change (dis-line-font-changes dl) (font-change-next change))) + ((null change) + (hunk-put-string* hunk last position font-family last-font chars last length)) + (let ((x (font-change-x change))) + (hunk-put-string* hunk last position font-family last-font chars last x) + (setq last x + last-font (font-change-font change)) ))))) + + +;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS; +;;; that is, they literally clear the line, and then blast the new glyphs. +;;; We don't hack replacing the line when reverse video is turned on because +;;; this doesn't seem to work too well. Also, hacking replace line on the +;;; color Megapel display is SLOW! +;;; +(defvar *hack-hunk-replace-line* t) + +;;; Hunk-Replace-Line -- Internal +;;; +;;; Similar to Hunk-Write-Line, but the line need not be clear. +;;; +(defun hunk-replace-line (hunk dl &optional + (position (dis-line-position dl))) + (if *hack-hunk-replace-line* + (hunk-replace-line-on-a-pixmap hunk dl position) + (old-hunk-replace-line hunk dl position))) + +(defun old-hunk-replace-line (hunk dl &optional (position (dis-line-position dl))) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (chars (dis-line-chars dl)) + (length (dis-line-length dl)) + (height (font-family-height font-family)) ) + (let ((last 0) + (last-font 0)) + (do ((change (dis-line-font-changes dl) (font-change-next change))) + ((null change) + (hunk-put-string* hunk last position font-family last-font chars last length) + (let ((dx (+ hunk-left-border + (* (font-family-width font-family) length)))) + (xlib:clear-area (bitmap-hunk-xwindow hunk) + :x dx + :y (+ hunk-top-border (* position height)) + :width (- (bitmap-hunk-width hunk) dx) + :height height))) + (let ((x (font-change-x change))) + (hunk-put-string* hunk last position font-family last-font chars last x) + (setq last x last-font (font-change-font change)) ))))) + +(defvar *hunk-replace-line-pixmap* nil) + +(defun hunk-replace-line-pixmap () + (if *hunk-replace-line-pixmap* + *hunk-replace-line-pixmap* + (let* ((hunk (window-hunk *current-window*)) + (gcontext (bitmap-hunk-gcontext hunk)) + (screen (xlib:display-default-screen + (bitmap-device-display (device-hunk-device hunk)))) + (height (font-family-height *default-font-family*)) + (pixmap (xlib:create-pixmap + :width (* hunk-width-limit + (font-family-width *default-font-family*)) + :height height :depth (xlib:screen-root-depth screen) + :drawable (xlib:screen-root screen)))) + (xlib:with-gcontext (gcontext :function boole-1 + :foreground *default-background-pixel*) + (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t)) + (setf *hunk-replace-line-pixmap* pixmap)))) + +(defun hunk-replace-line-on-a-pixmap (hunk dl position) + (let* ((font-family (bitmap-hunk-font-family hunk)) + (chars (dis-line-chars dl)) + (length (dis-line-length dl)) + (height (font-family-height font-family)) + (last 0) + (last-font 0) + (gcontext (bitmap-hunk-gcontext hunk))) + (do ((change (dis-line-font-changes dl) (font-change-next change))) + ((null change) + (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last length) + (let* ((dx (+ hunk-left-border + (* (font-family-width font-family) length))) + (dy (+ hunk-top-border (* position height))) + (xwin (bitmap-hunk-xwindow hunk))) + (xlib:with-gcontext (gcontext :exposures nil) + (xlib:copy-area (hunk-replace-line-pixmap) gcontext + 0 0 dx height xwin 0 dy)) + (xlib:clear-area xwin :x dx :y dy + :width (- (bitmap-hunk-width hunk) dx) + :height height))) + (let ((x (font-change-x change))) + (hunk-replace-line-string* hunk gcontext last position font-family last-font chars last x) + (setq last x last-font (font-change-font change)))))) + + +;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground +;;; color, so the initial bits where no characters go also is highlighted. +;;; Then the text is drawn background on foreground (hightlighted). This +;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil; +;;; that is, there is a modeline. This function should assume the gcontext's +;;; font is the default font of the hunk. We must LET bind the foreground and +;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious +;;; or incorrect implementation. +;;; +(defun hunk-replace-modeline (hunk) + (let* ((dl (bitmap-hunk-modeline-dis-line hunk)) + (font-family (bitmap-hunk-font-family hunk)) + (default-font (svref (font-family-map font-family) 0)) + (modeline-pos (bitmap-hunk-modeline-pos hunk)) + (xwindow (bitmap-hunk-xwindow hunk)) + (gcontext (bitmap-hunk-gcontext hunk))) + (xlib:draw-rectangle xwindow gcontext 0 modeline-pos + (bitmap-hunk-width hunk) + (+ hunk-modeline-top hunk-modeline-bottom + (font-family-height font-family)) + t) + (xlib:with-gcontext (gcontext :foreground + (xlib:gcontext-background gcontext) + :background + (xlib:gcontext-foreground gcontext) + :font default-font) + (xlib:draw-image-glyphs xwindow gcontext hunk-left-border + (+ modeline-pos hunk-modeline-top + (font-family-baseline font-family)) + (dis-line-chars dl) + :end (dis-line-length dl) + :translate *glyph-translate-function*)))) + + + +;;;; Cursor/Border color manipulation. + +;;; *hemlock-listener* is set to t by default because we can't know from X +;;; whether we come up with the pointer in our window. There is no initial +;;; :enter-window event. Defaulting this to nil causes the cursor to be hollow +;;; when the window comes up under the mouse, and you have to know how to fix +;;; it. Defaulting it to t causes the cursor to always come up full, as if +;;; Hemlock is the X listener, but this recovers naturally as you move into the +;;; window. This also coincides with Hemlock's border coming up highlighted, +;;; even when Hemlock is not the listener. +;;; +(defvar *hemlock-listener* t + "Highlight border when the cursor is dropped and Hemlock can receive input.") +(defvar *current-highlighted-border* nil + "When non-nil, the bitmap-hunk with the highlighted border.") + +(defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.") +(defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.") +(defvar *cursor-hunk* nil "Hunk the cursor is displayed on.") +(defvar *cursor-dropped* nil) ; True if the cursor is currently displayed. + +;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk. +;;; If the cursor is currently displayed somewhere, then lift it, and display +;;; it at its new location. +;;; +(defun hunk-show-cursor (hunk x y) + (unless (and (= x *hunk-cursor-x*) + (= y *hunk-cursor-y*) + (eq hunk *cursor-hunk*)) + (let ((cursor-down *cursor-dropped*)) + (when cursor-down (lift-cursor)) + (setf *hunk-cursor-x* x) + (setf *hunk-cursor-y* y) + (setf *cursor-hunk* hunk) + (when cursor-down (drop-cursor))))) + +;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay. We +;;; show a cursor and highlight the listening window's border when waiting +;;; for input. +;;; +(defun frob-cursor (on) + (if on (drop-cursor) (lift-cursor))) + +(declaim (special *default-border-pixmap* *highlight-border-pixmap*)) + +;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR +;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION +;;; and SMART-WINDOW-REDISPLAY). When the cursor is being dropped, since +;;; this means Hemlock is listening in the *cursor-hunk*, make sure the +;;; border of the window is highlighted as well. +;;; +(defun drop-cursor () + (unless *cursor-dropped* + (unless *hemlock-listener* (cursor-invert-center)) + (cursor-invert) + (when *hemlock-listener* + (cond (*current-highlighted-border* + (unless (eq *current-highlighted-border* *cursor-hunk*) + (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *current-highlighted-border*))) + *default-border-pixmap*) + (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *cursor-hunk*))) + *highlight-border-pixmap*) + ;; For complete gratuitous pseudo-generality, should force + ;; output on *current-highlighted-border* device too. + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*))))) + (t (setf (xlib:window-border + (window-group-xparent + (bitmap-hunk-window-group *cursor-hunk*))) + *highlight-border-pixmap*) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*))))) + (setf *current-highlighted-border* *cursor-hunk*)) + (setq *cursor-dropped* t))) + +;;; +(defun lift-cursor () + (when *cursor-dropped* + (unless *hemlock-listener* (cursor-invert-center)) + (cursor-invert) + (setq *cursor-dropped* nil))) + + +(defun cursor-invert-center () + (let ((family (bitmap-hunk-font-family *cursor-hunk*)) + (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) + (xlib:with-gcontext (gcontext :function boole-xor + :foreground *foreground-background-xor*) + (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) + gcontext + (+ hunk-left-border + (* *hunk-cursor-x* (font-family-width family)) + (font-family-cursor-x-offset family) + 1) + (+ hunk-top-border + (* *hunk-cursor-y* (font-family-height family)) + (font-family-cursor-y-offset family) + 1) + (- (font-family-cursor-width family) 2) + (- (font-family-cursor-height family) 2) + t))) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*)))) + +(defun cursor-invert () + (let ((family (bitmap-hunk-font-family *cursor-hunk*)) + (gcontext (bitmap-hunk-gcontext *cursor-hunk*))) + (xlib:with-gcontext (gcontext :function boole-xor + :foreground *foreground-background-xor*) + (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*) + gcontext + (+ hunk-left-border + (* *hunk-cursor-x* (font-family-width family)) + (font-family-cursor-x-offset family)) + (+ hunk-top-border + (* *hunk-cursor-y* (font-family-height family)) + (font-family-cursor-y-offset family)) + (font-family-cursor-width family) + (font-family-cursor-height family) + t))) + (xlib:display-force-output + (bitmap-device-display (device-hunk-device *cursor-hunk*)))) + + + + +;;;; Clearing and Copying Lines. + +(defun hunk-clear-lines (hunk start count) + (let ((height (font-family-height (bitmap-hunk-font-family hunk)))) + (xlib:clear-area (bitmap-hunk-xwindow hunk) + :x 0 :y (+ hunk-top-border (* start height)) + :width (bitmap-hunk-width hunk) + :height (* count height)))) + +(defun hunk-copy-lines (hunk src dst count) + (let ((height (font-family-height (bitmap-hunk-font-family hunk))) + (xwindow (bitmap-hunk-xwindow hunk))) + (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk) + 0 (+ hunk-top-border (* src height)) + (bitmap-hunk-width hunk) (* height count) + xwindow 0 (+ hunk-top-border (* dst height))))) + + + + +;;;; Drawing bottom border meter. + +;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs. The LOGAND +;;; calls in the loop are testing for no remainder when dividing by 8, 4, +;;; and other. This lets us quickly draw longer notches at tab stops and +;;; half way in between. This function assumes that +;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a +;;; modeline. +;;; +(defun hunk-draw-bottom-border (hunk) + (when (bitmap-hunk-thumb-bar-p hunk) + (let* ((xwindow (bitmap-hunk-xwindow hunk)) + (gcontext (bitmap-hunk-gcontext hunk)) + (modeline-pos (bitmap-hunk-modeline-pos hunk)) + (font-family (bitmap-hunk-font-family hunk)) + (font-width (font-family-width font-family))) + (xlib:clear-area xwindow :x 0 :y (- modeline-pos + hunk-thumb-bar-bottom-border) + :width (bitmap-hunk-width hunk) + :height hunk-bottom-border) + (let ((x (+ hunk-left-border (ash font-width -1))) + (y7 (- modeline-pos 7)) + (y5 (- modeline-pos 5)) + (y3 (- modeline-pos 3))) + (dotimes (i (bitmap-hunk-char-width hunk)) + (cond ((zerop (logand i 7)) + (xlib:draw-rectangle xwindow gcontext + x y7 (if (= i 80) 2 1) 7 t)) + ((zerop (logand i 3)) + (xlib:draw-rectangle xwindow gcontext x y5 1 5 t)) + (t + (xlib:draw-rectangle xwindow gcontext x y3 1 3 t))) + (incf x font-width)))))) + +;; $Log$ +;; Revision 1.1 2003/10/19 08:57:15 gb +;; Initial revision +;; +;; Revision 1.1.2.2 2003/09/18 13:40:16 gb +;; Conditionalize for #-CLX, a little more. +;; +;; Revision 1.1.2.1 2003/08/10 19:11:27 gb +;; New files, imported from upstream CVS as of 03/08/09. +;; +;; Revision 1.4 2003/08/05 19:54:17 gilbert +;; - did away with some macros +;; - invested in a left margin for added readability of hemlock frames. +;; Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/input.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/input.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/input.lisp (revision 8058) @@ -0,0 +1,501 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the code that handles input to Hemlock. +;;; +(in-package :hemlock-internals) + +;;; +;;; INPUT-WAITING is exported solely as a hack for the kbdmac definition +;;; mechanism. +;;; + + +;;; These are public variables users hand to the four basic editor input +;;; routines for method dispatching: +;;; GET-KEY-EVENT +;;; UNGET-KEY-EVENT +;;; LISTEN-EDITOR-INPUT +;;; CLEAR-EDITOR-INPUT +;;; +(defvar *editor-input* nil + "A structure used to do various operations on terminal input.") + +(defvar *real-editor-input* () + "Useful when we want to read from the terminal when *editor-input* is + rebound.") + + + + +;;;; editor-input structure. + +(defstruct (editor-input (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#" stream)))) + get ; A function that returns the next key-event in the queue. + unget ; A function that puts a key-event at the front of the queue. + listen ; A function that tells whether the queue is empty. + clear ; A function that empties the queue. + ;; + ;; Queue of events on this stream. The queue always contains at least one + ;; one element, which is the key-event most recently read. If no event has + ;; been read, the event is a dummy with a nil key-event. + head + tail) + + +;;; These are the elements of the editor-input event queue. +;;; +(defstruct (input-event (:constructor make-input-event ())) + next ; Next queued event, or NIL if none. + hunk ; Screen hunk event was read from. + key-event ; Key-event read. + x ; X and Y character position of mouse cursor. + y + unread-p) + +(defvar *free-input-events* ()) + +(defun new-event (key-event x y hunk next &optional unread-p) + (let ((res (if *free-input-events* + (shiftf *free-input-events* + (input-event-next *free-input-events*)) + (make-input-event)))) + (setf (input-event-key-event res) key-event) + (setf (input-event-x res) x) + (setf (input-event-y res) y) + (setf (input-event-hunk res) hunk) + (setf (input-event-next res) next) + (setf (input-event-unread-p res) unread-p) + res)) + +;;; This is a public variable. +;;; +(defvar *last-key-event-typed* () + "This variable contains the last key-event typed by the user and read as + input.") + +;;; This is a public variable. SITE-INIT initializes this. +;;; +(defvar *key-event-history* nil + "This ring holds the last 60 key-events read by the command interpreter.") + +(declaim (special *input-transcript*)) + +;;; DQ-EVENT is used in editor stream methods for popping off input. +;;; If there is an event not yet read in Stream, then pop the queue +;;; and return the character. If there is none, return NIL. +;;; +(defun dq-event (stream) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head))) + (if next + (let ((key-event (input-event-key-event next))) + (setf (editor-input-head stream) next) + (shiftf (input-event-next head) *free-input-events* head) + (ring-push key-event *key-event-history*) + (setf *last-key-event-typed* key-event) + (when *input-transcript* + (vector-push-extend key-event *input-transcript*)) + key-event))))) + +;;; Q-EVENT is used in low level input fetching routines to add input to the +;;; editor stream. +;;; +(defun q-event (stream key-event &optional x y hunk) + (hemlock-ext:without-interrupts + (let ((new (new-event key-event x y hunk nil)) + (tail (editor-input-tail stream))) + (setf (input-event-next tail) new) + (setf (editor-input-tail stream) new)))) + +(defun un-event (key-event stream) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head)) + (new (new-event key-event (input-event-x head) (input-event-y head) + (input-event-hunk head) next t))) + (setf (input-event-next head) new) + (unless next (setf (editor-input-tail stream) new))))) + + + + +;;;; Keyboard macro hacks. + +(defvar *input-transcript* () + "If this variable is non-null then it should contain an adjustable vector + with a fill pointer into which all keyboard input will be pushed.") + +;;; INPUT-WAITING -- Internal +;;; +;;; An Evil hack that tells us whether there is an unread key-event on +;;; *editor-input*. Note that this is applied to the real *editor-input* +;;; rather than to a kbdmac stream. +;;; +(defun input-waiting () + "Returns true if there is a key-event which has been unread-key-event'ed + on *editor-input*. Used by the keyboard macro stuff." + (let ((next (input-event-next + (editor-input-head *real-editor-input*)))) + (and next (input-event-unread-p next)))) + + + + +;;;; Input method macro. + +(defvar *in-hemlock-stream-input-method* nil + "This keeps us from undefined nasties like re-entering Hemlock stream + input methods from input hooks and scheduled events.") + +(declaim (special *screen-image-trashed*)) + +;;; These are the characters GET-KEY-EVENT notices when it pays attention +;;; to aborting input. This happens via EDITOR-INPUT-METHOD-MACRO. +;;; +(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G")) + +#+clx +(defun cleanup-for-wm-closed-display(closed-display) + ;; Remove fd-handlers + (hemlock-ext:disable-clx-event-handling closed-display) + ;; Close file descriptor and note DEAD. + (xlib:close-display closed-display) + ;; + ;; At this point there is not much sense to returning to Lisp + ;; as the editor cannot be re-entered (there are lots of pointers + ;; to the dead display around that will cause subsequent failures). + ;; Maybe could switch to tty mode then (save-all-files-and-exit)? + ;; For now, just assume user wanted an easy way to kill the session. + (hemlock-ext:quit)) + +(defmacro abort-key-event-p (key-event) + `(member ,key-event editor-abort-key-events)) + +;;; EDITOR-INPUT-METHOD-MACRO -- Internal. +;;; +;;; WINDOWED-GET-KEY-EVENT and TTY-GET-KEY-EVENT use this. Somewhat odd stuff +;;; goes on here because this is the place where Hemlock waits, so this is +;;; where we redisplay, check the time for scheduled events, etc. In the loop, +;;; we call the input hook when we get a character and leave the loop. If +;;; there isn't any input, invoke any scheduled events whose time is up. +;;; Unless SERVE-EVENT returns immediately and did something, (serve-event 0), +;;; call redisplay, note that we are going into a read wait, and call +;;; SERVE-EVENT with a wait or infinite timeout. Upon exiting the loop, turn +;;; off the read wait note and check for the abort character. Return the +;;; key-event we got. We bind an error condition handler here because the +;;; default Hemlock error handler goes into a little debugging prompt loop, but +;;; if we got an error in getting input, we should prompt the user using the +;;; input method (recursively even). +;;; +(eval-when (:compile-toplevel :execute) + +(defmacro editor-input-method-macro () + `(handler-bind + ((error + (lambda (condition) + (when (typep condition 'stream-error) + (let* ((stream (stream-error-stream condition)) + (display *editor-windowed-input*) + (display-stream + #+CLX + (and display (xlib::display-input-stream display)))) + (when (eq stream display-stream) + ;;(format *error-output* "~%Hemlock: Display died!~%~%") + (cleanup-for-wm-closed-display display) + (exit-hemlock nil)) + (let ((device + (device-hunk-device (window-hunk (current-window))))) + (funcall (device-exit device) device)) + (invoke-debugger condition))))) + #+(and CLX ) + (xlib:closed-display + (lambda(condition) + (let ((display (xlib::closed-display-display condition))) + (format *error-output* + "Closed display on stream ~a~%" + (xlib::display-input-stream display))) + (exit-hemlock nil))) + ) +; (when *in-hemlock-stream-input-method* +; (error "Entering Hemlock stream input method recursively!")) + (let ((*in-hemlock-stream-input-method* t) + (nrw-fun (device-note-read-wait + (device-hunk-device (window-hunk (current-window))))) + key-event) + (loop + (when (setf key-event (dq-event stream)) + (dolist (f (variable-value 'hemlock::input-hook)) (funcall f)) + (return)) + (invoke-scheduled-events) + (unless (or (hemlock-ext:serve-event 0) + (internal-redisplay)) + (internal-redisplay) + (when nrw-fun (funcall nrw-fun t)) + (let ((wait (next-scheduled-event-wait))) + (if wait (hemlock-ext:serve-event wait) (hemlock-ext:serve-event))))) + (when nrw-fun (funcall nrw-fun nil)) + (when (and (abort-key-event-p key-event) + ;; ignore-abort-attempts-p must exist outside the macro. + ;; in this case it is bound in GET-KEY-EVENT. + (not ignore-abort-attempts-p)) + (beep) + (throw 'editor-top-level-catcher nil)) + key-event))) +) ;eval-when + + + + +;;;; Editor input from windowing system. +#+clx +(defstruct (windowed-editor-input + (:include editor-input + (get #'windowed-get-key-event) + (unget #'windowed-unget-key-event) + (listen #'windowed-listen) + (clear #'windowed-clear-input)) + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#" stream))) + (:constructor make-windowed-editor-input + (&optional (head (make-input-event)) (tail head)))) + hunks) ; List of bitmap-hunks which input to this stream. + +#+clx +;;; There's actually no difference from the TTY case... +(defun windowed-get-key-event (stream ignore-abort-attempts-p) + (tty-get-key-event stream ignore-abort-attempts-p)) + +#+clx +(defun windowed-unget-key-event (key-event stream) + (un-event key-event stream)) + +#+clx +(defun windowed-clear-input (stream) + (loop (unless (hemlock-ext:serve-event 0) (return))) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head))) + (when next + (setf (input-event-next head) nil) + (shiftf (input-event-next (editor-input-tail stream)) + *free-input-events* next) + (setf (editor-input-tail stream) head))))) + +#+clx +(defun windowed-listen (stream) + (loop + ;; Don't service anymore events if we just got some input. + (when (input-event-next (editor-input-head stream)) + (return t)) + ;; + ;; If nothing is pending, check the queued input. + (unless (hemlock-ext:serve-event 0) + (return (not (null (input-event-next (editor-input-head stream)))))))) + + + +;;;; Editor input from a tty. + +(defstruct (tty-editor-input + (:include editor-input + (get #'tty-get-key-event) + (unget #'tty-unget-key-event) + (listen #'tty-listen) + (clear #'tty-clear-input)) + (:print-function + (lambda (obj stream n) + (declare (ignore obj n)) + (write-string "#" stream))) + (:constructor make-tty-editor-input + (fd &optional (head (make-input-event)) (tail head)))) + fd) + +(defun tty-get-key-event (stream ignore-abort-attempts-p) + (editor-input-method-macro)) + +(defun tty-unget-key-event (key-event stream) + (un-event key-event stream)) + +(defun tty-clear-input (stream) + (hemlock-ext:without-interrupts + (let* ((head (editor-input-head stream)) + (next (input-event-next head))) + (when next + (setf (input-event-next head) nil) + (shiftf (input-event-next (editor-input-tail stream)) + *free-input-events* next) + (setf (editor-input-tail stream) head))))) + +;;; Note that we never return NIL as long as there are events to be served with +;;; SERVE-EVENT. Thus non-keyboard input (i.e. process output) +;;; effectively causes LISTEN to block until either all the non-keyboard input +;;; has happened, or there is some real keyboard input. +;;; +(defun tty-listen (stream) + (loop + ;; Don't service anymore events if we just got some input. + (when (or (input-event-next (editor-input-head stream)) + (editor-tty-listen stream)) + (return t)) + ;; If nothing is pending, check the queued input. + (unless (hemlock-ext:serve-event 0) + (return (not (null (input-event-next (editor-input-head stream)))))))) + + + +;;;; GET-KEY-EVENT, UNGET-KEY-EVENT, LISTEN-EDITOR-INPUT, CLEAR-EDITOR-INPUT. + +;;; GET-KEY-EVENT -- Public. +;;; +(defun get-key-event (editor-input &optional ignore-abort-attempts-p) + "This function returns a key-event as soon as it is available on + editor-input. Editor-input is either *editor-input* or *real-editor-input*. + Ignore-abort-attempts-p indicates whether #k\"C-g\" and #k\"C-G\" throw to + the editor's top-level command loop; when this is non-nil, this function + returns those key-events when the user types them. Otherwise, it aborts the + editor's current state, returning to the command loop." + (funcall (editor-input-get editor-input) editor-input ignore-abort-attempts-p)) + +;;; UNGET-KEY-EVENT -- Public. +;;; +(defun unget-key-event (key-event editor-input) + "This function returns the key-event to editor-input, so the next invocation + of GET-KEY-EVENT will return the key-event. If the key-event is #k\"C-g\" + or #k\"C-G\", then whether GET-KEY-EVENT returns it depends on its second + argument. Editor-input is either *editor-input* or *real-editor-input*." + (funcall (editor-input-unget editor-input) key-event editor-input)) + +;;; CLEAR-EDITOR-INPUT -- Public. +;;; +(defun clear-editor-input (editor-input) + "This function flushes any pending input on editor-input. Editor-input + is either *editor-input* or *real-editor-input*." + (funcall (editor-input-clear editor-input) editor-input)) + +;;; LISTEN-EDITOR-INPUT -- Public. +;;; +(defun listen-editor-input (editor-input) + "This function returns whether there is any input available on editor-input. + Editor-input is either *editor-input* or *real-editor-input*." + (funcall (editor-input-listen editor-input) editor-input)) + + + + +;;;; LAST-KEY-EVENT-CURSORPOS and WINDOW-INPUT-HANDLER. + +;;; LAST-KEY-EVENT-CURSORPOS -- Public +;;; +;;; Just look up the saved info in the last read key event. +;;; +(defun last-key-event-cursorpos () + "Return as values, the (X, Y) character position and window where the + last key event happened. If this cannot be determined, Nil is returned. + If in the modeline, return a Y position of NIL and the correct X and window. + Returns nil for terminal input." + (let* ((ev (editor-input-head *real-editor-input*)) + (hunk (input-event-hunk ev)) + (window (and hunk (device-hunk-window hunk)))) + (when window + (values (input-event-x ev) (input-event-y ev) window)))) + +;;; WINDOW-INPUT-HANDLER -- Internal +;;; +;;; This is the input-handler function for hunks that implement windows. It +;;; just queues the events on *real-editor-input*. +;;; +(defun window-input-handler (hunk char x y) + (q-event *real-editor-input* char x y hunk)) + + + + +;;;; Random typeout input routines. + +(defun wait-for-more (stream) + (let ((key-event (more-read-key-event))) + (cond ((logical-key-event-p key-event :yes)) + ((or (logical-key-event-p key-event :do-all) + (logical-key-event-p key-event :exit)) + (setf (random-typeout-stream-no-prompt stream) t) + (random-typeout-cleanup stream)) + ((logical-key-event-p key-event :keep) + (setf (random-typeout-stream-no-prompt stream) t) + (maybe-keep-random-typeout-window stream) + (random-typeout-cleanup stream)) + ((logical-key-event-p key-event :no) + (random-typeout-cleanup stream) + (throw 'more-punt nil)) + (t + (unget-key-event key-event *editor-input*) + (random-typeout-cleanup stream) + (throw 'more-punt nil))))) + +(declaim (special *more-prompt-action*)) + +(defun maybe-keep-random-typeout-window (stream) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (start (buffer-start-mark buffer))) + (when (typep (hi::device-hunk-device (hi::window-hunk window)) + 'hi::bitmap-device) + (let ((*more-prompt-action* :normal)) + (update-modeline-field buffer window :more-prompt) + (random-typeout-redisplay window)) + (buffer-start (buffer-point buffer)) + (let* ((xwindow (make-xwindow-like-hwindow window)) + (window (make-window start :window xwindow))) + (unless window + #+clx(xlib:destroy-window xwindow) + (editor-error "Could not create random typeout window.")))))) + +(defun end-random-typeout (stream) + (let ((*more-prompt-action* :flush) + (window (random-typeout-stream-window stream))) + (update-modeline-field (window-buffer window) window :more-prompt) + (random-typeout-redisplay window)) + (unless (random-typeout-stream-no-prompt stream) + (let* ((key-event (more-read-key-event)) + (keep-p (logical-key-event-p key-event :keep))) + (when keep-p (maybe-keep-random-typeout-window stream)) + (random-typeout-cleanup stream) + (unless (or (logical-key-event-p key-event :do-all) + (logical-key-event-p key-event :exit) + (logical-key-event-p key-event :no) + (logical-key-event-p key-event :yes) + keep-p) + (unget-key-event key-event *editor-input*))))) + +;;; MORE-READ-KEY-EVENT -- Internal. +;;; +;;; This gets some input from the type of stream bound to *editor-input*. Need +;;; to loop over SERVE-EVENT since it returns on any kind of event (not +;;; necessarily a key or button event). +;;; +;;; Currently this does not work for keyboard macro streams! +;;; +(defun more-read-key-event () + (clear-editor-input *editor-input*) + (let ((key-event (loop + (let ((key-event (dq-event *editor-input*))) + (when key-event (return key-event)) + (hemlock-ext:serve-event))))) + (when (abort-key-event-p key-event) + (beep) + (throw 'editor-top-level-catcher nil)) + key-event)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lisp-lib.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lisp-lib.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lisp-lib.lisp (revision 8058) @@ -0,0 +1,175 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code to peruse the CMU Common Lisp library of hacks. +;;; +;;; Written by Blaine Burks. +;;; + +(in-package :hemlock) + + +(defmode "Lisp-Lib" :major-p t) + +;;; The library should be in *lisp-library-directory* + +(defvar *lisp-library-directory* "/afs/cs.cmu.edu/project/clisp/library/") + +(defvar *selected-library-buffer* nil) + + + +;;;; Commands. + +(defcommand "Lisp Library" (p) + "Goto buffer in 'Lisp-Lib' mode, creating one if necessary." + "Goto buffer in 'Lisp-Lib' mode, creating one if necessary." + (declare (ignore p)) + (when (not (and *selected-library-buffer* + (member *selected-library-buffer* *buffer-list*))) + (when (getstring "Lisp Library" *buffer-names*) + (editor-error "There is already a buffer named \"Lisp Library\".")) + (setf *selected-library-buffer* + (make-buffer "Lisp Library" :modes '("Lisp-Lib"))) + (message "Groveling library ...") + (let ((lib-directory (directory *lisp-library-directory*)) + (lib-entries ())) + (with-output-to-mark (s (buffer-point *selected-library-buffer*)) + (dolist (lib-spec lib-directory) + (let* ((path-parts (pathname-directory lib-spec)) + (last (elt path-parts (1- (length path-parts)))) + (raw-pathname (merge-pathnames last lib-spec))) + (when (and (directoryp lib-spec) + (probe-file (merge-pathnames + (make-pathname :type "catalog") + raw-pathname))) + (push raw-pathname lib-entries) + (format s "~d~%" last))))) + (defhvar "Library Entries" + "Holds a list of library entries for the 'Lisp Library' buffer" + :buffer *selected-library-buffer* + :value (coerce (nreverse lib-entries) 'simple-vector)))) + (setf (buffer-writable *selected-library-buffer*) nil) + (setf (buffer-modified *selected-library-buffer*) nil) + (change-to-buffer *selected-library-buffer*) + (buffer-start (current-point))) + +(defcommand "Describe Pointer Library Entry" (p) + "Finds the file that describes the lisp library entry indicated by the + pointer." + "Finds the file that describes the lisp library entry indicated by the + pointer." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (describe-library-entry (array-element-from-pointer-pos + (value library-entries) "No entry on current line"))) + +(defcommand "Describe Library Entry" (p) + "Find the file that describes the lisp library entry on the current line." + "Find the file that describes the lisp library entry on the current line." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (describe-library-entry (array-element-from-mark (current-point) + (value library-entries) "No entry on current line"))) + +(defun describe-library-entry (pathname) + (let ((lisp-buf (current-buffer)) + (buffer (view-file-command + nil + (merge-pathnames (make-pathname :type "catalog") pathname)))) + (push #'(lambda (buffer) + (declare (ignore buffer)) + (setf lisp-buf nil)) + (buffer-delete-hook lisp-buf)) + (setf (variable-value 'view-return-function :buffer buffer) + #'(lambda () (if lisp-buf + (change-to-buffer lisp-buf) + (lisp-library-command nil)))))) + +(defcommand "Load Library Entry" (p) + "Loads the current library entry into the current slave." + "Loads the current library entry into the current slave." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (string-eval (format nil "(load ~S)" + (namestring (library-entry-load-file nil))))) + +(defcommand "Load Pointer Library Entry" (p) + "Loads the library entry indicated by the mouse into the current slave." + "Loads the library entry indicated by the mouse into the current slave." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (string-eval (format nil "(load ~S)" + (namestring (library-entry-load-file t))))) + +(defcommand "Editor Load Library Entry" (p) + "Loads the current library entry into the editor Lisp." + "Loads the current library entry into the editor Lisp." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (in-lisp (load (library-entry-load-file nil)))) + +(defcommand "Editor Load Pointer Library Entry" (p) + "Loads the library entry indicated by the mouse into the editor Lisp." + "Loads the library entry indicated by the mouse into the editor Lisp." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (in-lisp (load (library-entry-load-file t)))) + +;;; LIBRARY-ENTRY-LOAD-FILE uses the mouse's position or the current point, +;;; depending on pointerp, to return a file that will load that library entry. +;;; +(defun library-entry-load-file (pointerp) + (let* ((lib-entries (value library-entries)) + (error-msg "No entry on current-line") + (base-name (if pointerp + (array-element-from-pointer-pos lib-entries error-msg) + (array-element-from-mark (current-point) lib-entries + error-msg))) + (parts (pathname-directory base-name)) + (load-name (concatenate 'simple-string + "load-" (elt parts (1- (length parts))))) + (load-pathname (merge-pathnames load-name base-name)) + (file-to-load + (or + (probe-file (compile-file-pathname load-pathname)) + (probe-file (merge-pathnames (make-pathname :type "fasl") + load-pathname)) + (probe-file (merge-pathnames (make-pathname :type "lisp") + load-pathname)) + (probe-file (compile-file-pathname base-name)) + (probe-file (merge-pathnames (make-pathname :type "fasl") + base-name)) + (probe-file (merge-pathnames (make-pathname :type "lisp") + base-name))))) + (unless file-to-load (editor-error "You'll have to load it yourself.")) + file-to-load)) + +(defcommand "Exit Lisp Library" (p) + "Exit Lisp-Lib Mode, deleting the buffer when possible." + "Exit Lisp-Lib Mode, deleting the buffer when possible." + (declare (ignore p)) + (unless (hemlock-bound-p 'library-entries :buffer (current-buffer)) + (editor-error "Not in a Lisp Library buffer.")) + (delete-buffer-if-possible (getstring "Lisp Library" *buffer-names*))) + +(defcommand "Lisp Library Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Lisp-Lib")) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lispbuf.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lispbuf.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lispbuf.lisp (revision 8058) @@ -0,0 +1,794 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to do a little lisp hacking in the editor's Lisp environment. +;;; + +(in-package :hemlock) + + +(defmacro in-lisp (&body body) + "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package + named by \"Current Package\" if it is non-nil." + (let ((name (gensym)) (package (gensym))) + `(handle-lisp-errors + (let* ((,name (value current-package)) + (,package (and ,name (find-package ,name)))) + (progv (if ,package '(*package*)) (if ,package (list ,package)) + ,@body))))) + + +(define-file-option "Package" (buffer value) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value + (let* ((eof (list nil)) + (thing (read-from-string value nil eof))) + (when (eq thing eof) (error "Bad package file option value.")) + (cond + ((stringp thing) + thing) + ((symbolp thing) + (symbol-name thing)) + ((characterp thing) + (string thing)) + (t + (message + "Ignoring \"package\" file option -- cannot convert to a string.")))) + :hooks (list 'package-name-change-hook))) + + + +;;;; Eval Mode Interaction. + +(declaim (special * ** *** - + ++ +++ / // ///)) + + +(defun get-prompt () + #+cmu (locally (declare (special ext:*prompt*)) + (if (functionp ext:*prompt*) + (funcall ext:*prompt*) + ext:*prompt*)) + #+sbcl (with-output-to-string (out) + (funcall sb-int:*repl-prompt-fun* out)) + #-(or cmu sbcl) "* ") + + +(defun show-prompt (&optional (stream *standard-output*)) + #-sbcl (princ (get-prompt) stream) + #+sbcl (funcall sb-int:*repl-prompt-fun* stream)) + + +(defun setup-eval-mode (buffer) + (let ((point (buffer-point buffer))) + (setf (buffer-minor-mode buffer "Eval") t) + (setf (buffer-minor-mode buffer "Editor") t) + (setf (buffer-major-mode buffer) "Lisp") + (buffer-end point) + (defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil + :buffer buffer) + (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer) + (defhvar "Buffer Input Mark" + "Mark used for Eval Mode input." + :buffer buffer + :value (copy-mark point :right-inserting)) + (defhvar "Eval Output Stream" + "Output stream used for Eval Mode output in this buffer." + :buffer buffer + :value (make-hemlock-output-stream point)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0)) + (let ((*standard-output* + (variable-value 'eval-output-stream :buffer buffer))) + (fresh-line) + (show-prompt)) + (move-mark (variable-value 'buffer-input-mark :buffer buffer) point))) + +(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode) + +(defun eval-mode-lisp-mode-hook (buffer on) + "Turn on Lisp mode when we go into Eval Mode." + (when on + (setf (buffer-major-mode buffer) "Lisp"))) +;;; +(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook) + +(defhvar "Editor Definition Info" + "When this is non-nil, the editor Lisp is used to determine definition + editing information; otherwise, the slave Lisp is used." + :value t + :mode "Eval") + + +(defvar *selected-eval-buffer* nil) + +(defcommand "Select Eval Buffer" (p) + "Goto buffer in \"Eval\" mode, creating one if necessary." + "Goto buffer in \"Eval\" mode, creating one if necessary." + (declare (ignore p)) + (unless *selected-eval-buffer* + (when (getstring "Eval" *buffer-names*) + (editor-error "There is already a buffer named \"Eval\"!")) + (setf *selected-eval-buffer* + (make-buffer "Eval" + :delete-hook + (list #'(lambda (buf) + (declare (ignore buf)) + (setf *selected-eval-buffer* nil))))) + (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t)) + (change-to-buffer *selected-eval-buffer*)) + + +(defvar lispbuf-eof '(nil)) + +(defhvar "Unwedge Interactive Input Confirm" + "When set (the default), trying to confirm interactive input when the + point is not after the input mark causes Hemlock to ask the user if he + needs to be unwedged. When not set, an editor error is signaled + informing the user that the point is before the input mark." + :value t) + +(defun unwedge-eval-buffer () + (abort-eval-input-command nil)) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-eval-buffer + :mode "Eval") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Prompt again at the end of the buffer? " + :mode "Eval") + +(defcommand "Confirm Eval Input" (p) + "Evaluate Eval Mode input between point and last prompt." + "Evaluate Eval Mode input between point and last prompt." + (declare (ignore p)) + (let ((input-region (get-interactive-input))) + (when input-region + (let* ((output (value eval-output-stream)) + (*standard-output* output) + (*error-output* output) + (*trace-output* output)) + (fresh-line) + (in-lisp + ;; Copy the region to keep the output and input streams from interacting + ;; since input-region is made of permanent marks into the buffer. + (with-input-from-region (stream (copy-region input-region)) + (loop + (let ((form (read stream nil lispbuf-eof))) + (when (eq form lispbuf-eof) + ;; Move the buffer's input mark to the end of the buffer. + (move-mark (region-start input-region) + (region-end input-region)) + (return)) + (setq +++ ++ ++ + + - - form) + (let ((this-eval (multiple-value-list (eval form)))) + (fresh-line) + (dolist (x this-eval) (prin1 x) (terpri)) + (show-prompt) + (setq /// // // / / this-eval) + (setq *** ** ** * * (car this-eval))))))))))) + +(defcommand "Abort Eval Input" (p) + "Move to the end of the buffer and prompt." + "Move to the end of the buffer and prompt." + (declare (ignore p)) + (let ((point (current-point))) + (buffer-end point) + (insert-character point #\newline) + (insert-string point "Aborted.") + (insert-character point #\newline) + (insert-string point (get-prompt)) + (move-mark (value buffer-input-mark) point))) + + + + +;;;; General interactive commands used in eval and typescript buffers. + +(defun get-interactive-input () + "Tries to return a region. When the point is not past the input mark, and + the user has \"Unwedge Interactive Input Confirm\" set, the buffer is + optionally fixed up, and nil is returned. Otherwise, an editor error is + signalled. When a region is returned, the start is the current buffer's + input mark, and the end is the current point moved to the end of the buffer." + (let ((point (current-point)) + (mark (value buffer-input-mark))) + (cond + ((mark>= point mark) + (buffer-end point) + (let* ((input-region (region mark point)) + (string (region-to-string input-region)) + (ring (value interactive-history))) + (when (and (or (zerop (ring-length ring)) + (string/= string (region-to-string (ring-ref ring 0)))) + (> (length string) (value minimum-interactive-input-length))) + (ring-push (copy-region input-region) ring)) + input-region)) + ((value unwedge-interactive-input-confirm) + (beep) + (when (prompt-for-y-or-n + :prompt (concatenate 'simple-string + "Point not past input mark. " + (value unwedge-interactive-input-string)) + :must-exist t :default t :default-string "yes") + (funcall (value unwedge-interactive-input-fun)) + (message "Unwedged.")) + nil) + (t + (editor-error "Point not past input mark."))))) + +(defhvar "Interactive History Length" + "This is the length used for the history ring in interactive buffers. + It must be set before turning on the mode." + :value 10) + +(defhvar "Minimum Interactive Input Length" + "When the number of characters in an interactive buffer exceeds this value, + it is pushed onto the interactive history, otherwise it is lost forever." + :value 2) + + +(defvar *previous-input-search-string* "ignore") + +(defvar *previous-input-search-pattern* + ;; Give it a bogus string since you can't give it the empty string. + (new-search-pattern :string-insensitive :forward "ignore")) + +(defun get-previous-input-search-pattern (string) + (if (string= *previous-input-search-string* string) + *previous-input-search-pattern* + (new-search-pattern :string-insensitive :forward + (setf *previous-input-search-string* string) + *previous-input-search-pattern*))) + +(defcommand "Search Previous Interactive Input" (p) + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + (declare (ignore p)) + (let* ((mark (value buffer-input-mark)) + (ring (value interactive-history)) + (point (current-point)) + (just-invoked (eq (last-command-type) :searching-interactive-input))) + (when (mark<= point mark) + (editor-error "Point not past input mark.")) + (when (zerop (ring-length ring)) + (editor-error "No previous input in this buffer.")) + (unless just-invoked + (get-previous-input-search-pattern (region-to-string (region mark point)))) + (let ((found-it (find-previous-input ring just-invoked))) + (unless found-it + (editor-error "Couldn't find ~a." *previous-input-search-string*)) + (delete-region (region mark point)) + (insert-region point (ring-ref ring found-it)) + (setf (value searching-interactive-pointer) found-it)) + (setf (last-command-type) :searching-interactive-input))) + +(defun find-previous-input (ring againp) + (let ((ring-length (ring-length ring)) + (base (if againp + (+ (value searching-interactive-pointer) 1) + 0))) + (loop + (when (= base ring-length) + (if againp + (setf base 0) + (return nil))) + (with-mark ((m (region-start (ring-ref ring base)))) + (when (find-pattern m *previous-input-search-pattern*) + (return base))) + (incf base)))) + +(defcommand "Previous Interactive Input" (p) + "Insert the previous input in an interactive mode (Eval or Typescript). + If repeated, keep rotating the history. With prefix argument, rotate + that many times." + "Pop the *interactive-history* at the point." + (let* ((point (current-point)) + (mark (value buffer-input-mark)) + (ring (value interactive-history)) + (length (ring-length ring)) + (p (or p 1))) + (when (or (mark< point mark) (zerop length)) (editor-error)) + (cond + ((eq (last-command-type) :interactive-history) + (let ((base (mod (+ (value interactive-pointer) p) length))) + (delete-region (region mark point)) + (insert-region point (ring-ref ring base)) + (setf (value interactive-pointer) base))) + (t + (let ((base (mod (if (minusp p) p (1- p)) length)) + (region (delete-and-save-region (region mark point)))) + (insert-region point (ring-ref ring base)) + (when (mark/= (region-start region) (region-end region)) + (ring-push region ring) + (incf base)) + (setf (value interactive-pointer) base))))) + (setf (last-command-type) :interactive-history)) + +(defcommand "Next Interactive Input" (p) + "Rotate the interactive history backwards. The region is left around the + inserted text. With prefix argument, rotate that many times." + "Call previous-interactive-input-command with negated arg." + (previous-interactive-input-command (- (or p 1)))) + +(defcommand "Kill Interactive Input" (p) + "Kill any input to an interactive mode (Eval or Typescript)." + "Kill any input to an interactive mode (Eval or Typescript)." + (declare (ignore p)) + (let ((point (buffer-point (current-buffer))) + (mark (value buffer-input-mark))) + (when (mark< point mark) (editor-error)) + (kill-region (region mark point) :kill-backward))) + +(defcommand "Interactive Beginning of Line" (p) + "If on line with current prompt, go to after it, otherwise do what + \"Beginning of Line\" always does." + "Go to after prompt when on prompt line." + (let ((mark (value buffer-input-mark)) + (point (current-point))) + (if (and (same-line-p point mark) (or (not p) (= p 1))) + (move-mark point mark) + (beginning-of-line-command p)))) + +(defcommand "Reenter Interactive Input" (p) + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + (declare (ignore p)) + (unless (hemlock-bound-p 'buffer-input-mark) + (editor-error "Not in an interactive buffer.")) + (let ((point (current-point))) + (let ((region (if (region-active-p) + ;; Copy this, so moving point doesn't affect the region. + (copy-region (current-region)) + (with-mark ((start point) + (end point)) + (pre-command-parse-check start) + (unless (form-offset start -1) + (editor-error "Not after complete form.")) + (region (copy-mark start) (copy-mark end)))))) + (buffer-end point) + (push-buffer-mark (copy-mark point)) + (insert-region point region) + (setf (last-command-type) :ephemerally-active)))) + + + + +;;; Other stuff. + +(defmode "Editor") + +(defcommand "Editor Mode" (p) + "Turn on \"Editor\" mode in the current buffer. If it is already on, turn it + off. When in editor mode, most lisp compilation and evaluation commands + manipulate the editor process instead of the current eval server." + "Toggle \"Editor\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Editor") + (not (buffer-minor-mode (current-buffer) "Editor")))) + +(define-file-option "Editor" (buffer value) + (declare (ignore value)) + (setf (buffer-minor-mode buffer "Editor") t)) + +(defhvar "Editor Definition Info" + "When this is non-nil, the editor Lisp is used to determine definition + editing information; otherwise, the slave Lisp is used." + :value t + :mode "Editor") + +(defcommand "Editor Compile Defun" (p) + "Compiles the current or next top-level form in the editor Lisp. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, this + compiles the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-compile-region (current-region)) + (editor-compile-region (defun-region (current-point)) t))) + +(defcommand "Editor Compile Region" (p) + "Compiles lisp forms between the point and the mark in the editor Lisp." + "Compiles lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (editor-compile-region (current-region))) + +(defun defun-region (mark) + "This returns a region around the current or next defun with respect to mark. + Mark is not used to form the region. If there is no appropriate top level + form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK." + (with-mark ((start mark) + (end mark)) + (pre-command-parse-check start) + (cond ((not (mark-top-level-form start end)) + (editor-error "No current or next top level form.")) + (t (region start end))))) + +(defun editor-compile-region (region &optional quiet) + (unless quiet (message "Compiling region ...")) + (in-lisp + (with-input-from-region (stream region) + (with-pop-up-display (*error-output* :height 19) + ;; JDz: We don't record source locations and what not, but this + ;; is portable. CMUCL specific implementation removed because + ;; it does not work on HEMLOCK-REGION-STREAM (but it can be + ;; added back later if CMUCL starts using user-extensible + ;; streams internally.) + (funcall (compile nil `(lambda () + ,@(loop for form = (read stream nil stream) + until (eq form stream) + collect form)))))))) + + +(defcommand "Editor Evaluate Defun" (p) + "Evaluates the current or next top-level form in the editor Lisp. + If the current region is active, this evaluates the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-evaluate-region-command nil) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (message "Editor Evaluation returned ~S" + (eval (read stream))))))) + +(defcommand "Editor Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark in the editor Lisp." + "Evaluates lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (current-region)) + (clear-echo-area) + (write-string "Evaluating region in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object))) + (message "Evaluation complete."))) + +(defcommand "Editor Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (let ((form (read stream))) + (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR.")) + (makunbound (cadr form)) + (message "Evaluation returned ~S" (eval form)))))) + +(defcommand "Editor Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (let ((point (buffer-point (current-buffer)))) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (in-lisp + (with-pop-up-display (rts) + (write-string (with-input-from-region (s (region start end)) + (prin1-to-string (funcall (if p + 'macroexpand + 'macroexpand-1) + (read s)))) + rts))))))) + +(defcommand "Editor Evaluate Expression" (p) + "Prompt for an expression to evaluate in the editor Lisp." + "Prompt for an expression to evaluate in the editor Lisp." + (declare (ignore p)) + (in-lisp + (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}" + (eval (prompt-for-expression + :prompt "Editor Eval: " + :help "Expression to evaluate"))))) + +(defcommand "Editor Evaluate Buffer" (p) + "Evaluates the text in the current buffer in the editor Lisp." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. This occurs in the editor Lisp. The prefix argument is + ignored." + (declare (ignore p)) + (clear-echo-area) + (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (with-input-from-region (stream (buffer-region (current-buffer))) + (let ((*standard-output* *echo-area-stream*)) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object)))) + (message "Evaluation complete."))) + + + +;;; With-Output-To-Window -- Internal +;;; +;;; +(defmacro with-output-to-window ((stream name) &body forms) + "With-Output-To-Window (Stream Name) {Form}* + Bind Stream to a stream that writes into the buffer named Name a la + With-Output-To-Mark. The buffer is created if it does not exist already + and a window is created to display the buffer if it is not displayed. + For the duration of the evaluation this window is made the current window." + (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) + (window (gensym)) (old-window (gensym))) + `(let* ((,nam ,name) + (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam))) + (,point (buffer-end (buffer-point ,buffer))) + (,window (or (car (buffer-windows ,buffer)) (make-window ,point))) + (,old-window (current-window))) + (unwind-protect + (progn (setf (current-window) ,window) + (buffer-end ,point) + (with-output-to-mark (,stream ,point) ,@forms)) + (setf (current-window) ,old-window))))) + +(defcommand "Editor Compile File" (p) + "Prompts for file to compile in the editor Lisp. Does not compare source + and binary write dates. Does not check any buffer for that file for + whether the buffer needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + + +(defun older-or-non-existent-fasl-p (pathname &optional definitely) + (let ((obj-pn (probe-file (compile-file-pathname pathname)))) + (or definitely + (not obj-pn) + (< (file-write-date obj-pn) (file-write-date pathname))))) + + +(defcommand "Editor Compile Buffer File" (p) + "Compile the file in the current buffer in the editor Lisp if its associated + binary file (of type .fasl) is older than the source or doesn't exist. When + the binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the file + without checking the binary file. When \"Compile Buffer File Confirm\" is + set, this command will ask for confirmation when it otherwise would not." + "Compile the file in the current buffer in the editor Lisp if the fasl file + isn't up to date. When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))) + (t (when (or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))) + +(defcommand "Editor Compile Group" (p) + "Compile each file in the current group which needs it in the editor Lisp. + If a file has type LISP and there is a curresponding file with type + FASL which has been written less recently (or it doesn't exit), then + the file is compiled, with error output directed to the \"Compiler Warnings\" + buffer. If a prefix argument is provided, then all the files are compiled. + All modified files are saved beforehand." + "Do a Compile-File in each file in the current group that seems to need it + in the editor Lisp." + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (message "File ~A not found." (namestring file))) + ((older-or-non-existent-fasl-p tn p) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring tn) #+cmu :error-file #+cmu nil))))))))) + +(defcommand "List Compile Group" (p) + "List any files that would be compiled by \"Compile Group\". All Modified + files are saved before checking to generate a consistent list." + "Do a Compile-File in each file in the current group that seems to need it." + (declare (ignore p)) + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (with-pop-up-display (s) + (write-line "\"Compile Group\" would compile the following files:" s) + (force-output s) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (format s "File ~A not found.~%" (namestring file))) + ((older-or-non-existent-fasl-p tn) + (write-line (namestring tn) s))) + (force-output s)))))) + +(defhvar "Load Pathname Defaults" + "The default pathname used by the load command.") + +(defcommand "Editor Load File" (p) + "Prompt for a file to load into Editor Lisp." + "Prompt for a file to load into the Editor Lisp." + (declare (ignore p)) + (let ((name (truename (prompt-for-file + :default + (or (value load-pathname-defaults) + (buffer-default-pathname (current-buffer))) + :prompt "Editor file to load: " + :help "The name of the file to load")))) + (setv load-pathname-defaults name) + (in-lisp (load name)))) + + + + +;;;; Lisp documentation stuff. + +;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and +;;; "Describe Function Call". +;;; +(defmacro function-to-describe (var error-name) + `(cond ((not (symbolp ,var)) + (,error-name "~S is not a symbol." ,var)) + ((macro-function ,var)) + ((fboundp ,var) + (if (listp (symbol-function ,var)) + ,var + (symbol-function ,var))) + (t + (,error-name "~S is not a function." ,var)))) + +(defcommand "Editor Describe Function Call" (p) + "Describe the most recently typed function name in the editor Lisp." + "Describe the most recently typed function name in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let* ((sym (read s)) + (fun (function-to-describe sym editor-error))) + (with-pop-up-display (*standard-output*) + (editor-describe-function fun sym))))))) + + +(defcommand "Editor Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol in the editor Lisp." + "Describe the previous s-expression if it is a symbol in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let ((thing (read s))) + (if (symbolp thing) + (with-pop-up-display (*standard-output*) + (describe thing)) + (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (with-pop-up-display (*standard-output*) + (describe (cadr thing))) + (editor-error "~S is not a symbol, or 'symbol, or #'symbol." + thing)))))))) + +;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol. +;;; However, if the marks are immediately before the first constituent char +;;; of the symbol name, we use the next symbol since the marks probably +;;; correspond to the point, and Hemlock's cursor display makes it look like +;;; the point is within the symbol name. This also tries to ignore :prefix +;;; characters such as quotes, commas, etc. +;;; +(defun mark-symbol (mark1 mark2) + (pre-command-parse-check mark1) + (with-mark ((tmark1 mark1) + (tmark2 mark1)) + (cond ((and (form-offset tmark1 1) + (form-offset (move-mark tmark2 tmark1) -1) + (or (mark= mark1 tmark2) + (and (find-attribute tmark2 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (mark= mark1 tmark2)))) + (form-offset mark2 1)) + (t + (form-offset mark1 -1) + (find-attribute mark1 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (form-offset (move-mark mark2 mark1) 1))))) + + +(defcommand "Editor Describe" (p) + "Call Describe on a Lisp object. + Prompt for an expression which is evaluated to yield the object." + "Prompt for an object to describe." + (declare (ignore p)) + (in-lisp + (let* ((exp (prompt-for-expression + :prompt "Object: " + :help "Expression to evaluate to get object to describe.")) + (obj (eval exp))) + (with-pop-up-display (*standard-output*) + (describe obj))))) + + +(defcommand "Filter Region" (p) + "Apply a Lisp function to each line of the region. + An expression is prompted for which should evaluate to a Lisp function + from a string to a string. The function must neither modify its argument + nor modify the return value after it is returned." + "Call prompt for a function, then call Filter-Region with it and the region." + (declare (ignore p)) + (let* ((exp (prompt-for-expression + :prompt "Function: " + :help "Expression to evaluate to get function to use as filter.")) + (fun (in-lisp (eval exp))) + (region (current-region))) + (let* ((start (copy-mark (region-start region) :left-inserting)) + (end (copy-mark (region-end region) :left-inserting)) + (region (region start end)) + (undo-region (copy-region region))) + (filter-region fun region) + (make-region-undo :twiddle "Filter Region" region undo-region)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lispeval.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lispeval.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/lispeval.lisp (revision 8058) @@ -0,0 +1,978 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code for sending requests to eval servers and the +;;; commands based on that code. +;;; +;;; Written by William Lott and Rob MacLachlan. +;;; + +(in-package :hemlock) + + +;;; The note structure holds everything we need to know about an +;;; operation. Not all operations use all the available fields. +;;; +(defstruct (note (:print-function %print-note)) + (state :unsent) ; :unsent, :pending, :running, :aborted or :dead. + server ; Server-Info for the server this op is on. + context ; Short string describing what this op is doing. + kind ; Either :eval, :compile, or :compile-file + buffer ; Buffer source came from. + region ; Region of request + package ; Package or NIL if none + text ; string containing request + input-file ; File to compile or where stuff was found + net-input-file ; Net version of above. + output-file ; Temporary output file for compiler fasl code. + net-output-file ; Net version of above + output-date ; Temp-file is created before calling compiler, + ; and this is its write date. + lap-file ; The lap file for compiles + error-file ; The file to dump errors into + load ; Load compiled file or not? + (errors 0) ; Count of compiler errors. + (warnings 0) ; Count of compiler warnings. + (notes 0)) ; Count of compiler notes. +;;; +(defun %print-note (note stream d) + (declare (ignore d)) + (format stream "#" + (note-context note) + (note-state note))) + + + + +;;;; Note support routines. + +;;; QUEUE-NOTE -- Internal. +;;; +;;; This queues note for server. SERVER-INFO-NOTES keeps notes in stack order, +;;; not queue order. We also link the note to the server and try to send it +;;; to the server. If we didn't send this note, we tell the user the server +;;; is busy and that we're queuing his note to be sent later. +;;; +(defun queue-note (note server) + (push note (server-info-notes server)) + (setf (note-server note) server) + (maybe-send-next-note server) + (when (eq (note-state note) :unsent) + (message "Server ~A busy, ~A queued." + (server-info-name server) + (note-context note)))) + +;;; MAYBE-SEND-NEXT-NOTE -- Internal. +;;; +;;; Loop over all notes in server. If we see any :pending or :running, then +;;; punt since we can't send one. Otherwise, by the end of the list, we may +;;; have found an :unsent one, and if we did, next will be the last :unsent +;;; note. Remember, SERVER-INFO-NOTES is kept in stack order not queue order. +;;; +(defun maybe-send-next-note (server) + (let ((busy nil) + (next nil)) + (dolist (note (server-info-notes server)) + (ecase (note-state note) + ((:pending :running) + (setf busy t) + (return)) + (:unsent + (setf next note)) + (:aborted :dead))) + (when (and (not busy) next) + (send-note next)))) + +(defun send-note (note) + (let* ((remote (hemlock.wire:make-remote-object note)) + (server (note-server note)) + (ts (server-info-slave-info server)) + (bg (server-info-background-info server)) + (wire (server-info-wire server))) + (setf (note-state note) :pending) + (message "Sending ~A." (note-context note)) + (case (note-kind note) + (:eval + (hemlock.wire:remote wire + (server-eval-text remote + (note-package note) + (note-text note) + (and ts (ts-data-stream ts))))) + (:compile + (hemlock.wire:remote wire + (server-compile-text remote + (note-package note) + (note-text note) + (note-input-file note) + (and ts (ts-data-stream ts)) + (and bg (ts-data-stream bg))))) + (:compile-file + (macrolet ((frob (x) + `(if (pathnamep ,x) + (namestring ,x) + ,x))) + (hemlock.wire:remote wire + (server-compile-file remote + (note-package note) + (frob (or (note-net-input-file note) + (note-input-file note))) + (frob (or (note-net-output-file note) + (note-output-file note))) + (frob (note-error-file note)) + (frob (note-lap-file note)) + (note-load note) + (and ts (ts-data-stream ts)) + (and bg (ts-data-stream bg)))))) + (t + (error "Unknown note kind ~S" (note-kind note)))) + (hemlock.wire:wire-force-output wire))) + + + +;;;; Server Callbacks. + +(defun operation-started (note) + (let ((note (hemlock.wire:remote-object-value note))) + (setf (note-state note) :running) + (message "The ~A started." (note-context note))) + (values)) + +(defun eval-form-error (message) + (editor-error message)) + +(defun lisp-error (note start end msg) + (declare (ignore start end)) + (let ((note (hemlock.wire:remote-object-value note))) + (loud-message "During ~A: ~A" + (note-context note) + msg)) + (values)) + +(defun compiler-error (note start end function severity) + (let* ((note (hemlock.wire:remote-object-value note)) + (server (note-server note)) + (line (mark-line + (buffer-end-mark + (server-info-background-buffer server)))) + (message (format nil "~:(~A~) ~@[in ~A ~]during ~A." + severity + function + (note-context note))) + (error (make-error-info :buffer (note-buffer note) + :message message + :line line))) + (message "~A" message) + (case severity + (:error (incf (note-errors note))) + (:warning (incf (note-warnings note))) + (:note (incf (note-notes note)))) + (let ((region (case (note-kind note) + (:compile + (note-region note)) + (:compile-file + (let ((buff (note-buffer note))) + (and buff (buffer-region buff)))) + (t + (error "Compiler error in ~S?" note))))) + (when region + (let* ((region-end (region-end region)) + (m1 (copy-mark (region-start region) :left-inserting)) + (m2 (copy-mark m1 :left-inserting))) + (when start + (character-offset m1 start) + (when (mark> m1 region-end) + (move-mark m1 region-end))) + (unless (and end (character-offset m2 end)) + (move-mark m2 region-end)) + + (setf (error-info-region error) + (region m1 m2))))) + + (vector-push-extend error (server-info-errors server))) + + (values)) + +(defun eval-text-result (note start end values) + (declare (ignore note start end)) + (message "=> ~{~#[~;~A~:;~A, ~]~}" values) + (values)) + +(defun operation-completed (note abortp) + (let* ((note (hemlock.wire:remote-object-value note)) + (server (note-server note)) + (file (note-output-file note))) + (hemlock.wire:forget-remote-translation note) + (setf (note-state note) :dead) + (setf (server-info-notes server) + (delete note (server-info-notes server) + :test #'eq)) + (setf (note-server note) nil) + + (if abortp + (loud-message "The ~A aborted." (note-context note)) + (let ((errors (note-errors note)) + (warnings (note-warnings note)) + (notes (note-notes note))) + (message "The ~A complete.~ + ~@[ ~D error~:P~]~@[ ~D warning~:P~]~@[ ~D note~:P~]" + (note-context note) + (and (plusp errors) errors) + (and (plusp warnings) warnings) + (and (plusp notes) notes)))) + + (let ((region (note-region note))) + (when (regionp region) + (delete-mark (region-start region)) + (delete-mark (region-end region)) + (setf (note-region note) nil))) + + (when (and (eq (note-kind note) + :compile-file) + (not (eq file t)) + file) + (if (> (file-write-date file) + (note-output-date note)) + (let ((new-name (make-pathname :type "fasl" + :defaults (note-input-file note)))) + (rename-file file new-name) + #+NILGB + (unix:unix-chmod (namestring new-name) #o644)) + (delete-file file))) + (maybe-send-next-note server)) + (values)) + + + +;;;; Stuff to send noise to the server. + +;;; EVAL-FORM-IN-SERVER -- Public. +;;; +(defun eval-form-in-server (server-info form + &optional (package (value current-package))) + "This evals form, a simple-string, in the server for server-info. Package + is the name of the package in which the server reads form, and it defaults + to the value of \"Current Package\". If package is nil, then the slave uses + the value of *package*. If server is busy with other requests, this signals + an editor-error to prevent commands using this from hanging. If the server + dies while evaluating form, then this signals an editor-error. This returns + a list of strings which are the printed representation of all the values + returned by form in the server." + (declare (simple-string form)) + (when (server-info-notes server-info) + (editor-error "Server ~S is currently busy. See \"List Operations\"." + (server-info-name server-info))) + (multiple-value-bind (values error) + (hemlock.wire:remote-value (server-info-wire server-info) + (server-eval-form package form)) + (when error + (editor-error "The server died before finishing")) + values)) + +;;; EVAL-FORM-IN-SERVER-1 -- Public. +;;; +;;; We use VALUES to squelch the second value of READ-FROM-STRING. +;;; +(defun eval-form-in-server-1 (server-info form + &optional (package (value current-package))) + "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from + the first string EVAL-FORM-IN-SERVER returns." + (values (read-from-string + (car (eval-form-in-server server-info form package))))) + +(defun string-eval (string + &key + (server (get-current-eval-server)) + (package (value current-package)) + (context (format nil + "evaluation of ~S" + string))) + "Queues the evaluation of string on an eval server. String is a simple + string. If package is not supplied, the string is eval'ed in the slave's + current package." + (declare (simple-string string)) + (queue-note (make-note :kind :eval + :context context + :package package + :text string) + server) + (values)) + +(defun region-eval (region + &key + (server (get-current-eval-server)) + (package (value current-package)) + (context (region-context region "evaluation"))) + "Queues the evaluation of a region of text on an eval server. If package + is not supplied, the string is eval'ed in the slave's current package." + (let ((region (region (copy-mark (region-start region) :left-inserting) + (copy-mark (region-end region) :left-inserting)))) + (queue-note (make-note :kind :eval + :context context + :region region + :package package + :text (region-to-string region)) + server)) + (values)) + +(defun region-compile (region + &key + (server (get-current-eval-server)) + (package (value current-package))) + "Queues a compilation on an eval server. If package is not supplied, the + string is eval'ed in the slave's current package." + (let* ((region (region (copy-mark (region-start region) :left-inserting) + (copy-mark (region-end region) :left-inserting))) + (buf (line-buffer (mark-line (region-start region)))) + (pn (and buf (buffer-pathname buf))) + (defined-from (if pn (namestring pn) "unknown"))) + (queue-note (make-note :kind :compile + :context (region-context region "compilation") + :buffer (and region + (region-start region) + (mark-line (region-start region)) + (line-buffer (mark-line + (region-start region)))) + :region region + :package package + :text (region-to-string region) + :input-file defined-from) + server)) + (values)) + + + + +;;;; File compiling noise. + +(defhvar "Remote Compile File" + "When set (the default), this causes slave file compilations to assume the + compilation is occurring on a remote machine. This means the source file + must be world readable. Unsetting this, causes no file accesses to go + through the super root." + :value nil) + +;;; FILE-COMPILE compiles files in a client Lisp. Because of Unix file +;;; protection, one cannot write files over the net unless they are publicly +;;; writeable. To get around this, we create a temporary file that is +;;; publicly writeable for compiler output. This file is renamed to an +;;; ordinary output name if the compiler wrote anything to it, or deleted +;;; otherwise. No temporary file is created when output-file is not t. +;;; + +(defun file-compile (file + &key + buffer + (output-file t) + error-file + lap-file + load + (server (get-current-compile-server)) + (package (value current-package))) + "Compiles file in a client Lisp. When output-file is t, a temporary + output file is used that is publicly writeable in case the client is on + another machine. This file is renamed or deleted after compilation. + Setting \"Remote Compile File\" to nil, inhibits this. If package is not + supplied, the string is eval'ed in the slave's current package." + + (let* ((file (truename file)) ; in case of search-list in pathname. + (namestring (namestring file)) + (note (make-note + :kind :compile-file + :context (format nil "compilation of ~A" namestring) + :buffer buffer + :region nil + :package package + :input-file file + :output-file output-file + :error-file error-file + :lap-file lap-file + :load load))) + + (when (and (value remote-compile-file) + (eq output-file t)) + (multiple-value-bind (net-infile ofile net-ofile date) + (file-compile-temp-file file) + (setf (note-net-input-file note) net-infile) + (setf (note-output-file note) ofile) + (setf (note-net-output-file note) net-ofile) + (setf (note-output-date note) date))) + + (clear-server-errors server + #'(lambda (error) + (eq (error-info-buffer error) + buffer))) + (queue-note note server))) + +;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly +;;; writable in the directory file is in and with a .fasl type. Four values +;;; are returned -- a pathname suitable for referencing file remotely, the +;;; pathname of the temporary file created, a pathname suitable for referencing +;;; the temporary file remotely, and the write date of the temporary file. +;;; + +#+NILGB +(defun file-compile-temp-file (file) + (let ((ofile (loop (let* ((sym (gensym)) + (f (merge-pathnames + (format nil "compile-file-~A.fasl" sym) + file))) + (unless (probe-file f) (return f)))))) + (multiple-value-bind (fd err) + (unix:unix-open (namestring ofile) + unix:o_creat #o666) + (unless fd + (editor-error "Couldn't create compiler temporary output file:~%~ + ~A" (unix:get-unix-error-msg err))) + (unix:unix-fchmod fd #o666) + (unix:unix-close fd)) + (let ((net-ofile (pathname-for-remote-access ofile))) + (values (make-pathname :directory (pathname-directory net-ofile) + :defaults file) + ofile + net-ofile + (file-write-date ofile))))) + +(defun pathname-for-remote-access (file) + (let* ((machine (machine-instance)) + (usable-name (nstring-downcase + (the simple-string + (subseq machine 0 (position #\. machine)))))) + (declare (simple-string machine usable-name)) + (make-pathname :directory (concatenate 'simple-string + "/../" + usable-name + (directory-namestring file)) + :defaults file))) + +;;; REGION-CONTEXT -- internal +;;; +;;; Return a string which describes the code in a region. Thing is the +;;; thing being done to the region. "compilation" or "evaluation"... + +(defun region-context (region thing) + (declare (simple-string thing)) + (pre-command-parse-check (region-start region)) + (let ((start (region-start region))) + (with-mark ((m1 start)) + (unless (start-defun-p m1) + (top-level-offset m1 1)) + (with-mark ((m2 m1)) + (mark-after m2) + (form-offset m2 2) + (format nil + "~A of ~S" + thing + (if (eq (mark-line m1) (mark-line m2)) + (region-to-string (region m1 m2)) + (concatenate 'simple-string + (line-string (mark-line m1)) + "..."))))))) + + + +;;;; Commands (Gosh, wow gee!) + +(defcommand "Editor Server Name" (p) + "Echos the editor server's name which can be supplied with the -slave switch + to connect to a designated editor." + "Echos the editor server's name which can be supplied with the -slave switch + to connect to a designated editor." + (declare (ignore p)) + (if *editor-name* + (message "This editor is named ~S." *editor-name*) + (message "This editor is not currently named."))) + +(defcommand "Set Buffer Package" (p) + "Set the package to be used by Lisp evaluation and compilation commands + while in this buffer. When in a slave's interactive buffers, do NOT + set the editor's package variable, but changed the slave's *package*." + "Prompt for a package to make into a buffer-local variable current-package." + (declare (ignore p)) + (let* ((name (string (prompt-for-expression + :prompt "Package name: " + :help "Name of package to associate with this buffer."))) + (buffer (current-buffer)) + (info (value current-eval-server))) + (cond ((and info + (or (eq (server-info-slave-buffer info) buffer) + (eq (server-info-background-buffer info) buffer))) + (hemlock.wire:remote (server-info-wire info) + (server-set-package name)) + (hemlock.wire:wire-force-output (server-info-wire info))) + ((eq buffer *selected-eval-buffer*) + (setf *package* (maybe-make-package name))) + (t + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer :value name))) + (when (buffer-modeline-field-p buffer :package) + (dolist (w (buffer-windows buffer)) + (update-modeline-field buffer w :package))))) + +(defcommand "Current Compile Server" (p) + "Echos the current compile server's name. With prefix argument, + shows global one. Does not signal an error or ask about creating a slave." + "Echos the current compile server's name. With prefix argument, + shows global one." + (let ((info (if p + (variable-value 'current-compile-server :global) + (value current-compile-server)))) + (if info + (message "~A" (server-info-name info)) + (message "No ~:[current~;global~] compile server." p)))) + +(defcommand "Set Compile Server" (p) + "Specifies the name of the server used globally for file compilation requests." + "Call select-current-compile-server." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (setf (variable-value 'current-compile-server :global) + (maybe-create-server)))) + +(defcommand "Set Buffer Compile Server" (p) + "Specifies the name of the server used for file compilation requests in + the current buffer." + "Call select-current-compile-server after making a buffer local variable." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (defhvar "Current Compile Server" + "The Server-Info object for the server currently used for compilation requests." + :buffer (current-buffer) + :value (maybe-create-server)))) + +(defcommand "Current Eval Server" (p) + "Echos the current eval server's name. With prefix argument, shows + global one. Does not signal an error or ask about creating a slave." + "Echos the current eval server's name. With prefix argument, shows + global one. Does not signal an error or ask about creating a slave." + (let ((info (if p + (variable-value 'current-eval-server :global) + (value current-eval-server)))) + (if info + (message "~A" (server-info-name info)) + (message "No ~:[current~;global~] eval server." p)))) + +(defcommand "Set Eval Server" (p) + "Specifies the name of the server used globally for evaluation and + compilation requests." + "Call select-current-server." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (setf (variable-value 'current-eval-server :global) + (maybe-create-server)))) + +(defcommand "Set Buffer Eval Server" (p) + "Specifies the name of the server used for evaluation and compilation + requests in the current buffer." + "Call select-current-server after making a buffer local variable." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (defhvar "Current Eval Server" + "The Server-Info for the eval server used in this buffer." + :buffer (current-buffer) + :value (maybe-create-server)))) + +(defcommand "Evaluate Defun" (p) + "Evaluates the current or next top-level form. + If the current region is active, then evaluate it." + "Evaluates the current or next top-level form." + (declare (ignore p)) + (if (region-active-p) + (evaluate-region-command nil) + (region-eval (defun-region (current-point))))) + +(defcommand "Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound." + (declare (ignore p)) + (let* ((form (defun-region (current-point))) + (start (region-start form))) + (with-mark ((var-start start) + (var-end start)) + (mark-after var-start) + (form-offset var-start 1) + (form-offset (move-mark var-end var-start) 1) + (let ((exp (concatenate 'simple-string + "(makunbound '" + (region-to-string (region var-start var-end)) + ")"))) + (eval-form-in-server (get-current-eval-server) exp))) + (region-eval form))) + +;;; We use Prin1-To-String in the client so that the expansion gets pretty +;;; printed. Since the expansion can contain unreadable stuff, we can't expect +;;; to be able to read that string back in the editor. We shove the region +;;; at the client Lisp as a string, so it can read from the string with the +;;; right package environment. +;;; + +(defcommand "Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (let ((point (current-point))) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (with-pop-up-display (s) + (write-string + (eval-form-in-server-1 + (get-current-eval-server) + (format nil "(prin1-to-string (~S (read-from-string ~S)))" + (if p 'macroexpand 'macroexpand-1) + (region-to-string (region start end)))) + s)))))) + +(defcommand "Evaluate Expression" (p) + "Prompt for an expression to evaluate." + "Prompt for an expression to evaluate." + (declare (ignore p)) + (let ((exp (prompt-for-string + :prompt "Eval: " + :help "Expression to evaluate."))) + (message "=> ~{~#[~;~A~:;~A, ~]~}" + (eval-form-in-server (get-current-eval-server) exp)))) + +(defcommand "Compile Defun" (p) + "Compiles the current or next top-level form. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, compile + the region." + "Evaluates the current or next top-level form." + (declare (ignore p)) + (if (region-active-p) + (compile-region-command nil) + (region-compile (defun-region (current-point))))) + +(defcommand "Compile Region" (p) + "Compiles lisp forms between the point and the mark." + "Compiles lisp forms between the point and the mark." + (declare (ignore p)) + (region-compile (current-region))) + +(defcommand "Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark." + "Evaluates lisp forms between the point and the mark." + (declare (ignore p)) + (region-eval (current-region))) + +(defcommand "Evaluate Buffer" (p) + "Evaluates the text in the current buffer." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. The prefix argument is ignored." + (declare (ignore p)) + (let ((b (current-buffer))) + (region-eval (buffer-region b) + :context (format nil + "evaluation of buffer ``~A''" + (buffer-name b))))) + +(defcommand "Load File" (p) + "Prompt for a file to load into the current eval server." + "Prompt for a file to load into the current eval server." + (declare (ignore p)) + (let ((name (truename (prompt-for-file + :default + (or (value load-pathname-defaults) + (buffer-default-pathname (current-buffer))) + :prompt "File to load: " + :help "The name of the file to load")))) + (setv load-pathname-defaults name) + (string-eval (format nil "(load ~S)" + (namestring + (if (value remote-compile-file) + (pathname-for-remote-access name) + name)))))) + +(defcommand "Compile File" (p) + "Prompts for file to compile. Does not compare source and binary write + dates. Does not check any buffer for that file for whether the buffer + needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (file-compile pn))) + +(defhvar "Compile Buffer File Confirm" + "When set, \"Compile Buffer File\" prompts before doing anything." + :value t) + +(defcommand "Compile Buffer File" (p) + "Compile the file in the current buffer if its associated binary file + (of type .fasl) is older than the source or doesn't exist. When the + binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the + file without checking the binary file. When \"Compile Buffer File + Confirm\" is set, this command will ask for confirmation when it + otherwise would not." + "Compile the file in the current buffer if the fasl file isn't up to date. + When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (file-compile pn :buffer buf))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (file-compile pn :buffer buf))) + ((or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (file-compile pn :buffer buf))))) + +(defcommand "Compile Group" (p) + "Compile each file in the current group which needs it. + If a file has type LISP and there is a curresponding file with type + FASL which has been written less recently (or it doesn't exit), then + the file is compiled, with error output directed to the \"Compiler Warnings\" + buffer. If a prefix argument is provided, then all the files are compiled. + All modified files are saved beforehand." + "Do a Compile-File in each file in the current group that seems to need it." + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (message "File ~A not found." (namestring file))) + ((older-or-non-existent-fasl-p tn p) + (file-compile tn))))))) + + + +;;;; Error hacking stuff. + +(defcommand "Flush Compiler Error Information" (p) + "Flushes all infomation about errors encountered while compiling using the + current server" + "Flushes all infomation about errors encountered while compiling using the + current server" + (declare (ignore p)) + (clear-server-errors (get-current-compile-server t))) + +(defcommand "Next Compiler Error" (p) + "Move to the next compiler error for the current server. If an argument is + given, advance that many errors." + "Move to the next compiler error for the current server. If an argument is + given, advance that many errors." + (let* ((server (get-current-compile-server t)) + (errors (server-info-errors server)) + (fp (fill-pointer errors))) + (when (zerop fp) + (editor-error "There are no compiler errors.")) + (let* ((old-index (server-info-error-index server)) + (new-index (+ (or old-index -1) (or p 1)))) + (when (< new-index 0) + (if old-index + (editor-error "Can't back up ~R, only at the ~:R compiler error." + (- p) (1+ old-index)) + (editor-error "Not even at the first compiler error."))) + (when (>= new-index fp) + (if (= (1+ (or old-index -1)) fp) + (editor-error "No more compiler errors.") + (editor-error "Only ~R remaining compiler error~:P." + (- fp old-index 1)))) + (setf (server-info-error-index server) new-index) + ;; Display the silly error. + (let ((error (aref errors new-index))) + (let ((region (error-info-region error))) + (if region + (let* ((start (region-start region)) + (buffer (line-buffer (mark-line start)))) + (change-to-buffer buffer) + (move-mark (buffer-point buffer) start)) + (message "Hmm, no region for this error."))) + (let* ((line (error-info-line error)) + (buffer (line-buffer line))) + (if (and line (bufferp buffer)) + (let ((mark (mark line 0))) + (unless (buffer-windows buffer) + (let ((window (find-if-not + #'(lambda (window) + (or (eq window (current-window)) + (eq window *echo-area-window*))) + *window-list*))) + (if window + (setf (window-buffer window) buffer) + (make-window mark)))) + (move-mark (buffer-point buffer) mark) + (dolist (window (buffer-windows buffer)) + (move-mark (window-display-start window) mark) + (move-mark (window-point window) mark)) + (delete-mark mark)) + (message "Hmm, no line for this error."))))))) + +(defcommand "Previous Compiler Error" (p) + "Move to the previous compiler error. If an argument is given, move back + that many errors." + "Move to the previous compiler error. If an argument is given, move back + that many errors." + (next-compiler-error-command (- (or p 1)))) + + + + +;;;; Operation management commands: + +(defcommand "Abort Operations" (p) + "Abort all operations on current eval server connection." + "Abort all operations on current eval server connection." + (declare (ignore p)) + (let* ((server (get-current-eval-server)) + (wire (server-info-wire server))) + ;; Tell the slave to abort the current operation and to ignore any further + ;; operations. + (dolist (note (server-info-notes server)) + (setf (note-state note) :aborted)) + #+NILGB (ext:send-character-out-of-band (hemlock.wire:wire-fd wire) #\N) + (hemlock.wire:remote-value wire (server-accept-operations)) + ;; Synch'ing with server here, causes any operations queued at the socket or + ;; in the server to be ignored, and the last thing evaluated is an + ;; instruction to go on accepting operations. + (hemlock.wire:wire-force-output wire) + (dolist (note (server-info-notes server)) + (when (eq (note-state note) :pending) + ;; The HEMLOCK.WIRE:REMOTE-VALUE call should have allowed a handshake to + ;; tell the editor anything :pending was aborted. + (error "Operation ~S is still around after we aborted it?" note))) + ;; Forget anything queued in the editor. + (setf (server-info-notes server) nil))) + +(defcommand "List Operations" (p) + "List all eval server operations which have not yet completed." + "List all eval server operations which have not yet completed." + (declare (ignore p)) + (let ((notes nil)) + ;; Collect all notes, reversing them since they act like a queue but + ;; are not in queue order. + (do-strings (str val *server-names*) + (declare (ignore str)) + (setq notes (nconc notes (reverse (server-info-notes val))))) + (if notes + (with-pop-up-display (s) + (dolist (note notes) + (format s "~@(~8A~) ~A on ~A.~%" + (note-state note) + (note-context note) + (server-info-name (note-server note))))) + (message "No uncompleted operations."))) + (values)) + + + +;;;; Describing in the client lisp. + +;;; "Describe Function Call" gets the function name from the current form +;;; as a string. This string is used as the argument to a call to +;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp. The +;;; auxiliary function's name is qualified since it is read in the client +;;; Lisp with *package* bound to the buffer's package. The result comes +;;; back as a list of strings, so we read the first string to get out the +;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp. +;;; +(defcommand "Describe Function Call" (p) + "Describe the current function call." + "Describe the current function call." + (let ((info (value current-eval-server))) + (cond + ((not info) + (message "Describing from the editor Lisp ...") + (editor-describe-function-call-command p)) + (t + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (let* ((package (value current-package)) + (package-exists + (eval-form-in-server-1 + info + (format nil + "(if (find-package ~S) t (package-name *package*))" + package) + nil))) + (unless (eq package-exists t) + (message "Using package ~S in ~A since ~ + ~:[there is no current package~;~:*~S does not exist~]." + package-exists (server-info-name info) package)) + (with-pop-up-display (s) + (write-string (eval-form-in-server-1 + info + (format nil "(hemlock::describe-function-call-aux ~S)" + (region-to-string (region mark1 mark2))) + (if (eq package-exists t) package nil)) + s)))))))) + +;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some +;;; editor, relying on the fact that the cores have the same functions. String +;;; is the name of a function that is read (in the client Lisp). The result is +;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION. +;;; +(defun describe-function-call-aux (string) + (let* ((sym (read-from-string string)) + (fun (function-to-describe sym error))) + (with-output-to-string (*standard-output*) + (editor-describe-function fun sym)))) + +;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a +;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp. The +;;; auxiliary function's name is qualified since it is read in the client Lisp +;;; with *package* bound to the buffer's package. The result comes back as a +;;; list of strings, so we read the first string to get out the string value +;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp. +;;; + +(defcommand "Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol." + "Describe the previous s-expression if it is a symbol." + (declare (ignore p)) + (let ((info (value current-eval-server))) + (cond + ((not info) + (message "Describing from the editor Lisp ...") + (editor-describe-symbol-command nil)) + (t + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-pop-up-display (s) + (write-string (eval-form-in-server-1 + info + (format nil "(hemlock::describe-symbol-aux '~A)" + (region-to-string (region mark1 mark2)))) + s))))))) + +(defun describe-symbol-aux (thing) + (with-output-to-string (*standard-output*) + (describe (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (cadr thing) + thing)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/mh.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/mh.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/mh.lisp (revision 8058) @@ -0,0 +1,3180 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This is a mailer interface to MH. +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock) + + + + +;;;; General stuff. + +(defvar *new-mail-buffer* nil) + +(defvar *mh-utility-bit-bucket* (make-broadcast-stream)) + + +(defattribute "Digit" + "This is just a (mod 2) attribute for base 10 digit characters.") +;;; +(dotimes (i 10) + (setf (character-attribute :digit (digit-char i)) 1)) + + +(defmacro number-string (number) + `(let ((*print-base* 10)) + (prin1-to-string ,number))) + + +(defmacro do-headers-buffers ((buffer-var folder &optional hinfo-var) + &rest forms) + "The Forms are evaluated with Buffer-Var bound to each buffer containing + headers lines for folder. Optionally Hinfo-Var is bound to the + headers-information structure." + (let ((folder-var (gensym)) + (hinfo (gensym))) + `(let ((,folder-var ,folder)) + (declare (simple-string ,folder-var)) + (dolist (,buffer-var *buffer-list*) + (when (hemlock-bound-p 'headers-information :buffer ,buffer-var) + (let ((,hinfo (variable-value 'headers-information + :buffer ,buffer-var))) + (when (string= (the simple-string (headers-info-folder ,hinfo)) + ,folder-var) + ,@(if hinfo-var + `((let ((,hinfo-var ,hinfo)) + ,@forms)) + forms)))))))) + +(defmacro do-headers-lines ((hbuffer &key line-var mark-var) &rest forms) + "Forms are evaluated for each non-blank line. When supplied Line-Var and + Mark-Var are to the line and a :left-inserting mark at the beginning of the + line. This works with DELETE-HEADERS-BUFFER-LINE, but one should be careful + using this to modify the hbuffer." + (let ((line-var (or line-var (gensym))) + (mark-var (or mark-var (gensym))) + (id (gensym))) + `(with-mark ((,mark-var (buffer-point ,hbuffer) :left-inserting)) + (buffer-start ,mark-var) + (loop + (let* ((,line-var (mark-line ,mark-var)) + (,id (line-message-id ,line-var))) + (unless (blank-line-p ,line-var) + ,@forms) + (if (or (not (eq ,line-var (mark-line ,mark-var))) + (string/= ,id (line-message-id ,line-var))) + (line-start ,mark-var) + (unless (line-offset ,mark-var 1 0) (return)))))))) + +(defmacro with-headers-mark ((mark-var hbuffer msg) &rest forms) + "Forms are executed with Mark-Var bound to a :left-inserting mark at the + beginning of the headers line representing msg. If no such line exists, + no execution occurs." + (let ((line (gensym))) + `(do-headers-lines (,hbuffer :line-var ,line :mark-var ,mark-var) + (when (string= (the simple-string (line-message-id ,line)) + (the simple-string ,msg)) + ,@forms + (return))))) + + + + +;;;; Headers Mode. + +(defmode "Headers" :major-p t) + +(defhvar "Headers Information" + "This holds the information about the current headers buffer." + :value nil) + +(defstruct (headers-info (:print-function print-headers-info)) + buffer ;Buffer for these headers. + folder ;String name of folder with leading MH "+". + msg-seq ;MH sequence of messages in buffer. + msg-strings ;List of strings representing msg-seq. + other-msg-bufs ;List of message buffers referencing this headers buffer. + draft-bufs ;List of draft buffers referencing this headers buffer. + msg-buffer) + +(defun print-headers-info (obj str n) + (declare (ignore n)) + (format str "#" (headers-info-folder obj))) + +(defmacro line-message-deleted (line) + `(getf (line-plist ,line) 'mh-msg-deleted)) + +(defmacro line-message-id (line) + `(getf (line-plist ,line) 'mh-msg-id)) + +(defun headers-current-message (hinfo) + (let* ((point (buffer-point (headers-info-buffer hinfo))) + (line (mark-line point))) + (unless (blank-line-p line) + (values (line-message-id line) + (copy-mark point))))) + +(defcommand "Message Headers" (p) + "Prompts for a folder and messages, displaying headers in a buffer in the + current window. With an argument, prompt for a pick expression." + "Show some headers." + (let ((folder (prompt-for-folder))) + (new-message-headers + folder + (prompt-for-message :prompt (if p + "MH messages to pick from: " + "MH messages: ") + :folder folder + :messages "all") + p))) + +(defcommand "Pick Headers" (p) + "Further narrow the selection of this folders headers. + Prompts for a pick expression to pick over the headers in the current + buffer. Entering an empty expression displays all the headers for that + folder." + "Prompts for a pick expression to pick over the headers in the current + buffer." + (declare (ignore p)) + (let ((hinfo (value headers-information))) + (unless hinfo + (editor-error "Pick Headers only works in a headers buffer.")) + (pick-message-headers hinfo))) + +;;; PICK-MESSAGE-HEADERS picks messages from info's messages based on an +;;; expression provided by the user. If the expression is empty, we do +;;; headers on all the messages in folder. The buffer's name is changed to +;;; reflect the messages picked over and the expression used. +;;; +(defun pick-message-headers (hinfo) + (let ((folder (headers-info-folder hinfo)) + (msgs (headers-info-msg-strings hinfo))) + (multiple-value-bind (pick user-pick) + (prompt-for-pick-expression) + (let* ((hbuffer (headers-info-buffer hinfo)) + (new-mail-buf-p (eq hbuffer *new-mail-buffer*)) + (region (cond (pick + (message-headers-to-region + folder (pick-messages folder msgs pick))) + (new-mail-buf-p + (maybe-get-new-mail-msg-hdrs folder)) + (t (message-headers-to-region folder + (list "all")))))) + (with-writable-buffer (hbuffer) + (revamp-headers-buffer hbuffer hinfo) + (when region (insert-message-headers hbuffer hinfo region))) + (setf (buffer-modified hbuffer) nil) + (buffer-start (buffer-point hbuffer)) + (setf (buffer-name hbuffer) + (cond (pick (format nil "Headers ~A ~A ~A" folder msgs user-pick)) + (new-mail-buf-p (format nil "Unseen Headers ~A" folder)) + (t (format nil "Headers ~A (all)" folder)))))))) + +;;; NEW-MESSAGE-HEADERS picks over msgs if pickp is non-nil, or it just scans +;;; msgs. It is important to pick and get the message headers region before +;;; making the buffer and info structures since PICK-MESSAGES and +;;; MESSAGE-HEADERS-TO-REGION will call EDITOR-ERROR if they fail. The buffer +;;; name is chosen based on folder, msgs, and an optional pick expression. +;;; +(defun new-message-headers (folder msgs &optional pickp) + (multiple-value-bind (pick-exp user-pick) + (if pickp (prompt-for-pick-expression)) + (let* ((pick (if pick-exp (pick-messages folder msgs pick-exp))) + (region (message-headers-to-region folder (or pick msgs))) + (hbuffer (maybe-make-mh-buffer (format nil "Headers ~A ~A~:[~; ~S~]" + folder msgs pick user-pick) + :headers)) + (hinfo (make-headers-info :buffer hbuffer :folder folder))) + (insert-message-headers hbuffer hinfo region) + (defhvar "Headers Information" + "This holds the information about the current headers buffer." + :value hinfo :buffer hbuffer) + (setf (buffer-modified hbuffer) nil) + (setf (buffer-writable hbuffer) nil) + (buffer-start (buffer-point hbuffer)) + (change-to-buffer hbuffer)))) + +(defhvar "MH Scan Line Form" + "This is a pathname of a file containing an MH format expression for headers + lines." + :value (pathname "library:mh-scan")) + +;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into +;;; buffer for folder and msgs. +;;; +;;; (value fill-column) should really be done as if the buffer were current, +;;; but Hemlock doesn't let you do this without the buffer being current. +;;; +(defun message-headers-to-region (folder msgs &optional width) + (let ((region (make-empty-region))) + (with-output-to-mark (*standard-output* (region-end region) :full) + (mh "scan" + `(,folder ,@msgs + "-form" ,(namestring (truename (value mh-scan-line-form))) + "-width" ,(number-string (or width (value fill-column))) + "-noheader"))) + region)) + +(defun insert-message-headers (hbuffer hinfo region) + (ninsert-region (buffer-point hbuffer) region) + (let ((seq (set-message-headers-ids hbuffer :return-seq))) + (setf (headers-info-msg-seq hinfo) seq) + (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) + (when (value virtual-message-deletion) + (note-deleted-headers hbuffer + (mh-sequence-list (headers-info-folder hinfo) + "hemlockdeleted")))) + +(defun set-message-headers-ids (hbuffer &optional return-seq) + (let ((msgs nil)) + (do-headers-lines (hbuffer :line-var line) + (let* ((line-str (line-string line)) + (num (parse-integer line-str :junk-allowed t))) + (declare (simple-string line-str)) + (unless num + (editor-error "MH scan lines must contain the message id as the ~ + first thing on the line for the Hemlock interface.")) + (setf (line-message-id line) (number-string num)) + (when return-seq (setf msgs (mh-sequence-insert num msgs))))) + msgs)) + +(defun note-deleted-headers (hbuffer deleted-seq) + (when deleted-seq + (do-headers-lines (hbuffer :line-var line :mark-var hmark) + (if (mh-sequence-member-p (line-message-id line) deleted-seq) + (note-deleted-message-at-mark hmark) + (setf (line-message-deleted line) nil))))) + +;;; PICK-MESSAGES -- Internal Interface. +;;; +;;; This takes a folder (with a + in front of the name), messages to pick +;;; over, and an MH pick expression (in the form returned by +;;; PROMPT-FOR-PICK-EXPRESSION). Sequence is an MH sequence to set to exactly +;;; those messages chosen by the pick when zerop is non-nil; when zerop is nil, +;;; pick adds the messages to the sequence along with whatever messages were +;;; already in the sequence. This returns a list of message specifications. +;;; +(defun pick-messages (folder msgs expression &optional sequence (zerop t)) + (let* ((temp (with-output-to-string (*standard-output*) + (unless + ;; If someone bound *signal-mh-errors* to nil around this + ;; function, MH pick outputs bogus messages (for example, + ;; "0"), and MH would return without calling EDITOR-ERROR. + (mh "pick" `(,folder + ,@msgs + ,@(if sequence `("-sequence" ,sequence)) + ,@(if zerop '("-zero")) + "-list" ; -list must follow -sequence. + ,@expression)) + (return-from pick-messages nil)))) + (len (length temp)) + (start 0) + (result nil)) + (declare (simple-string temp)) + (loop + (let ((end (position #\newline temp :start start :test #'char=))) + (cond ((not end) + (return (nreverse (cons (subseq temp start) result)))) + ((= start end) + (return (nreverse result))) + (t + (push (subseq temp start end) result) + (when (>= (setf start (1+ end)) len) + (return (nreverse result))))))))) + + +(defcommand "Delete Headers Buffer and Message Buffers" (p &optional buffer) + "Prompts for a headers buffer to delete along with its associated message + buffers. Any associated draft buffers are left alone, but their associated + message buffers will be deleted." + "Deletes the current headers buffer and its associated message buffers." + (declare (ignore p)) + (let* ((default (cond ((value headers-information) (current-buffer)) + ((value message-information) (value headers-buffer)))) + (buffer (or buffer + (prompt-for-buffer :default default + :default-string + (if default (buffer-name default)))))) + (unless (hemlock-bound-p 'headers-information :buffer buffer) + (editor-error "Not a headers buffer -- ~A" (buffer-name buffer))) + (let* ((hinfo (variable-value 'headers-information :buffer buffer)) + ;; Copy list since buffer cleanup hook is destructive. + (other-bufs (copy-list (headers-info-other-msg-bufs hinfo))) + (msg-buf (headers-info-msg-buffer hinfo))) + (when msg-buf (delete-buffer-if-possible msg-buf)) + (dolist (b other-bufs) (delete-buffer-if-possible b)) + (delete-buffer-if-possible (headers-info-buffer hinfo))))) + +(defhvar "Expunge Messages Confirm" + "When set (the default), \"Expunge Messages\" and \"Quit Headers\" will ask + for confirmation before expunging messages and packing the folder's message + id's." + :value t) + +(defhvar "Temporary Draft Folder" + "This is the folder name where MH fcc: messages are kept that are intended + to be deleted and expunged when messages are expunged for any other + folder -- \"Expunge Messages\" and \"Quit Headers\"." + :value nil) + +;;; "Quit Headers" doesn't expunge or compact unless there is a deleted +;;; sequence. This collapses other headers buffers into the same folder +;;; differently than "Expunge Messages" since the latter assumes there will +;;; always be one remaining headers buffer. This command folds all headers +;;; buffers into the folder that are not the current buffer or the new mail +;;; buffer into one buffer. When the current buffer is the new mail buffer +;;; we do not check for more unseen headers since we are about to delete +;;; the buffer anyway. The other headers buffers must be deleted before +;;; making the new one due to aliasing the buffer structure and +;;; MAYBE-MAKE-MH-BUFFER. +;;; +(defcommand "Quit Headers" (p) + "Quit headers buffer possibly expunging deleted messages. + This affects the current headers buffer. When there are deleted messages + the user is asked for confirmation on expunging the messages and packing the + folder's message id's. Then the buffer and all its associated message + buffers are deleted. Setting \"Quit Headers Confirm\" to nil inhibits + prompting. When \"Temporary Draft Folder\" is bound, this folder's messages + are deleted and expunged." + "This affects the current headers buffer. When there are deleted messages + the user is asked for confirmation on expunging the messages and packing + the folder. Then the buffer and all its associated message buffers are + deleted." + (declare (ignore p)) + (let* ((hinfo (value headers-information)) + (minfo (value message-information)) + (hdrs-buf (cond (hinfo (current-buffer)) + (minfo (value headers-buffer))))) + (unless hdrs-buf + (editor-error "Not in or associated with any headers buffer.")) + (let* ((folder (cond (hinfo (headers-info-folder hinfo)) + (minfo (message-info-folder minfo)))) + (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + (when (and deleted-seq + (or (not (value expunge-messages-confirm)) + (prompt-for-y-or-n + :prompt (list "Expunge messages and pack folder ~A? " + folder) + :default t + :default-string "Y"))) + (message "Deleting messages ...") + (mh "rmm" (list folder "hemlockdeleted")) + (let ((*standard-output* *mh-utility-bit-bucket*)) + (message "Compacting folder ...") + (mh "folder" (list folder "-fast" "-pack"))) + (message "Maintaining consistency ...") + (let (hbufs) + (declare (list hbufs)) + (do-headers-buffers (b folder) + (unless (or (eq b hdrs-buf) (eq b *new-mail-buffer*)) + (push b hbufs))) + (dolist (b hbufs) + (delete-headers-buffer-and-message-buffers-command nil b)) + (when hbufs + (new-message-headers folder (list "all")))) + (expunge-messages-fix-draft-buffers folder) + (unless (eq hdrs-buf *new-mail-buffer*) + (expunge-messages-fix-unseen-headers folder)) + (delete-and-expunge-temp-drafts))) + (delete-headers-buffer-and-message-buffers-command nil hdrs-buf))) + +;;; DELETE-AND-EXPUNGE-TEMP-DRAFTS deletes all the messages in the +;;; temporary draft folder if there is one defined. Any headers buffers +;;; into this folder are deleted with their message buffers. We have to +;;; create a list of buffers to delete since buffer deletion destructively +;;; modifies the same list DO-HEADERS-BUFFERS uses. "rmm" is run without +;;; error reporting since it signals an error if there are no messages to +;;; delete. This function must return; for example, "Quit Headers" would +;;; not complete successfully if this ended up calling EDITOR-ERROR. +;;; +(defun delete-and-expunge-temp-drafts () + (let ((temp-draft-folder (value temporary-draft-folder))) + (when temp-draft-folder + (setf temp-draft-folder (coerce-folder-name temp-draft-folder)) + (message "Deleting and expunging temporary drafts ...") + (when (mh "rmm" (list temp-draft-folder "all") :errorp nil) + (let (hdrs) + (declare (list hdrs)) + (do-headers-buffers (b temp-draft-folder) + (push b hdrs)) + (dolist (b hdrs) + (delete-headers-buffer-and-message-buffers-command nil b))))))) + + + + +;;;; Message Mode. + +(defmode "Message" :major-p t) + +(defhvar "Message Information" + "This holds the information about the current message buffer." + :value nil) + +(defstruct message/draft-info + headers-mark) ;Mark pointing to a headers line in a headers buffer. + +(defstruct (message-info (:include message/draft-info) + (:print-function print-message-info)) + folder ;String name of folder with leading MH "+". + msgs ;List of strings representing messages to be shown. + draft-buf ;Possible draft buffer reference. + keep) ;Whether message buffer may be re-used. + +(defun print-message-info (obj str n) + (declare (ignore n)) + (format str "#" + (message-info-folder obj) (message-info-msgs obj))) + + +(defcommand "Next Message" (p) + "Show the next message. + When in a message buffer, shows the next message in the associated headers + buffer. When in a headers buffer, moves point down a line and shows that + message." + "When in a message buffer, shows the next message in the associated headers + buffer. When in a headers buffer, moves point down a line and shows that + message." + (declare (ignore p)) + (show-message-offset 1)) + +(defcommand "Previous Message" (p) + "Show the previous message. + When in a message buffer, shows the previous message in the associated + headers buffer. When in a headers buffer, moves point up a line and shows + that message." + "When in a message buffer, shows the previous message in the associated + headers buffer. When in a headers buffer, moves point up a line and + shows that message." + (declare (ignore p)) + (show-message-offset -1)) + +(defcommand "Next Undeleted Message" (p) + "Show the next undeleted message. + When in a message buffer, shows the next undeleted message in the associated + headers buffer. When in a headers buffer, moves point down to a line + without a deleted message and shows that message." + "When in a message buffer, shows the next undeleted message in the associated + headers buffer. When in a headers buffer, moves point down to a line without + a deleted message and shows that message." + (declare (ignore p)) + (show-message-offset 1 :undeleted)) + +(defcommand "Previous Undeleted Message" (p) + "Show the previous undeleted message. + When in a message buffer, shows the previous undeleted message in the + associated headers buffer. When in a headers buffer, moves point up a line + without a deleted message and shows that message." + "When in a message buffer, shows the previous undeleted message in the + associated headers buffer. When in a headers buffer, moves point up a line + without a deleted message and shows that message." + (declare (ignore p)) + (show-message-offset -1 :undeleted)) + +(defun show-message-offset (offset &optional undeleted) + (let ((minfo (value message-information))) + (cond + ((not minfo) + (let ((hinfo (value headers-information))) + (unless hinfo (editor-error "Not in a message or headers buffer.")) + (show-message-offset-hdrs-buf hinfo offset undeleted))) + ((message-info-keep minfo) + (let ((hbuf (value headers-buffer))) + (unless hbuf (editor-error "Not associated with a headers buffer.")) + (let ((hinfo (variable-value 'headers-information :buffer hbuf)) + (point (buffer-point hbuf))) + (move-mark point (message-info-headers-mark minfo)) + (show-message-offset-hdrs-buf hinfo offset undeleted)))) + (t + (show-message-offset-msg-buf minfo offset undeleted))))) + +(defun show-message-offset-hdrs-buf (hinfo offset undeleted) + (unless hinfo (editor-error "Not in a message or headers buffer.")) + (unless (show-message-offset-mark (buffer-point (headers-info-buffer hinfo)) + offset undeleted) + (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." + (plusp offset) undeleted)) + (show-headers-message hinfo)) + +(defun show-message-offset-msg-buf (minfo offset undeleted) + (let ((msg-mark (message-info-headers-mark minfo))) + (unless msg-mark (editor-error "Not associated with a headers buffer.")) + (unless (show-message-offset-mark msg-mark offset undeleted) + (let ((hbuf (value headers-buffer)) + (mbuf (current-buffer))) + (setf (current-buffer) hbuf) + (setf (window-buffer (current-window)) hbuf) + (delete-buffer-if-possible mbuf)) + (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message." + (plusp offset) undeleted)) + (move-mark (buffer-point (line-buffer (mark-line msg-mark))) msg-mark) + (let* ((next-msg (line-message-id (mark-line msg-mark))) + (folder (message-info-folder minfo)) + (mbuffer (current-buffer))) + (with-writable-buffer (mbuffer) + (delete-region (buffer-region mbuffer)) + (setf (buffer-name mbuffer) (get-storable-msg-buf-name folder next-msg)) + (setf (message-info-msgs minfo) next-msg) + (read-mh-file (merge-pathnames next-msg + (merge-relative-pathnames + (strip-folder-name folder) + (mh-directory-pathname))) + mbuffer) + (let ((unseen-seq (mh-profile-component "unseen-sequence"))) + (when unseen-seq + (mark-one-message folder next-msg unseen-seq :delete)))))) + (let ((dbuffer (message-info-draft-buf minfo))) + (when dbuffer + (delete-variable 'message-buffer :buffer dbuffer) + (setf (message-info-draft-buf minfo) nil)))) + +(defun get-storable-msg-buf-name (folder msg) + (let ((name (format nil "Message ~A ~A" folder msg))) + (if (not (getstring name *buffer-names*)) + name + (let ((n 2)) + (loop + (setf name (format nil "Message ~A ~A copy ~D" folder msg n)) + (unless (getstring name *buffer-names*) + (return name)) + (incf n)))))) + +(defun show-message-offset-mark (msg-mark offset undeleted) + (with-mark ((temp msg-mark)) + (let ((winp + (cond (undeleted + (loop + (unless (and (line-offset temp offset 0) + (not (blank-line-p (mark-line temp)))) + (return nil)) + (unless (line-message-deleted (mark-line temp)) + (return t)))) + ((and (line-offset temp offset 0) + (not (blank-line-p (mark-line temp))))) + (t nil)))) + (if winp (move-mark msg-mark temp))))) + + +(defcommand "Show Message" (p) + "Shows the current message. + Prompts for a folder and message(s), displaying this in the current window. + When invoked in a headers buffer, shows the message on the current line." + "Show a message." + (declare (ignore p)) + (let ((hinfo (value headers-information))) + (if hinfo + (show-headers-message hinfo) + (let ((folder (prompt-for-folder))) + (show-prompted-message folder (prompt-for-message :folder folder)))))) + +;;; SHOW-HEADERS-MESSAGE shows the current message for hinfo. If there is a +;;; main message buffer, clobber it, and we don't have to deal with kept +;;; messages or draft associations since those operations should have moved +;;; the message buffer into the others list. Remove the message from the +;;; unseen sequence, and make sure the message buffer is displayed in some +;;; window. +;;; +(defun show-headers-message (hinfo) + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (let* ((mbuffer (headers-info-msg-buffer hinfo)) + (folder (headers-info-folder hinfo)) + (buf-name (get-storable-msg-buf-name folder cur-msg)) + (writable nil)) + (cond (mbuffer + (setf (buffer-name mbuffer) buf-name) + (setf writable (buffer-writable mbuffer)) + (setf (buffer-writable mbuffer) t) + (delete-region (buffer-region mbuffer)) + (let ((minfo (variable-value 'message-information :buffer mbuffer))) + (move-mark (message-info-headers-mark minfo) cur-mark) + (delete-mark cur-mark) + (setf (message-info-msgs minfo) cur-msg))) + (t (setf mbuffer (maybe-make-mh-buffer buf-name :message)) + (setf (headers-info-msg-buffer hinfo) mbuffer) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder + :msgs cur-msg + :headers-mark cur-mark) + :buffer mbuffer) + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their + associated headers buffer." + :value (headers-info-buffer hinfo) :buffer mbuffer))) + (read-mh-file (merge-pathnames + cur-msg + (merge-relative-pathnames (strip-folder-name folder) + (mh-directory-pathname))) + mbuffer) + (setf (buffer-writable mbuffer) writable) + (let ((unseen-seq (mh-profile-component "unseen-sequence"))) + (when unseen-seq (mark-one-message folder cur-msg unseen-seq :delete))) + (get-message-buffer-window mbuffer)))) + +;;; SHOW-PROMPTED-MESSAGE takes an arbitrary message spec and blasts those +;;; messages into a message buffer. First we pick the message to get them +;;; individually specified as normalized message ID's -- all integers and +;;; no funny names such as "last". +;;; +(defun show-prompted-message (folder msgs) + (let* ((msgs (pick-messages folder msgs nil)) + (mbuffer (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msgs) + :message))) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder :msgs msgs) + :buffer mbuffer) + (let ((*standard-output* (make-hemlock-output-stream (buffer-point mbuffer) + :full))) + (mh "show" `(,folder ,@msgs "-noshowproc" "-noheader")) + (setf (buffer-modified mbuffer) nil)) + (buffer-start (buffer-point mbuffer)) + (setf (buffer-writable mbuffer) nil) + (get-message-buffer-window mbuffer))) + +;;; GET-MESSAGE-BUFFER-WINDOW currently just changes to buffer, unless buffer +;;; has any windows, in which case it uses the first one. It could prompt for +;;; a window, split the current window, split the current window or use the +;;; next one if there is one, funcall an Hvar. It could take a couple +;;; arguments to control its behaviour. Whatever. +;;; +(defun get-message-buffer-window (mbuffer) + (let ((wins (buffer-windows mbuffer))) + (cond (wins + (setf (current-buffer) mbuffer) + (setf (current-window) (car wins))) + (t (change-to-buffer mbuffer))))) + + +(defhvar "Scroll Message Showing Next" + "When this is set, \"Scroll Message\" shows the next message when the end + of the current message is visible." + :value t) + +(defcommand "Scroll Message" (p) + "Scroll the current window down through the current message. + If the end of the message is visible, then show the next undeleted message + if \"Scroll Message Showing Next\" is non-nil." + "Scroll the current window down through the current message." + (if (and (not p) + (displayed-p (buffer-end-mark (current-buffer)) (current-window)) + (value scroll-message-showing-next)) + (show-message-offset 1 :undeleted) + (scroll-window-down-command p))) + + +(defcommand "Keep Message" (p) + "Keeps the current message buffer from being re-used. Also, if the buffer + would be deleted due to a draft completion, it will not be." + "Keeps the current message buffer from being re-used. Also, if the buffer + would be deleted due to a draft completion, it will not be." + (declare (ignore p)) + (let ((minfo (value message-information))) + (unless minfo (editor-error "Not in a message buffer.")) + (let ((hbuf (value headers-buffer))) + (when hbuf + (let ((mbuf (current-buffer)) + (hinfo (variable-value 'headers-information :buffer hbuf))) + (when (eq (headers-info-msg-buffer hinfo) mbuf) + (setf (headers-info-msg-buffer hinfo) nil) + (push mbuf (headers-info-other-msg-bufs hinfo)))))) + (setf (message-info-keep minfo) t))) + +(defcommand "Edit Message Buffer" (p) + "Recursively edit message buffer. + Puts the current message buffer into \"Text\" mode allowing modifications in + a recursive edit. While in this state, the buffer is associated with the + pathname of the message, so saving the file is possible." + "Puts the current message buffer into \"Text\" mode allowing modifications in + a recursive edit. While in this state, the buffer is associated with the + pathname of the message, so saving the file is possible." + (declare (ignore p)) + (let* ((minfo (value message-information))) + (unless minfo (editor-error "Not in a message buffer.")) + (let* ((msgs (message-info-msgs minfo)) + (mbuf (current-buffer)) + (mbuf-name (buffer-name mbuf)) + (writable (buffer-writable mbuf)) + (abortp t)) + (when (consp msgs) + (editor-error + "There appears to be more than one message in this buffer.")) + (unwind-protect + (progn + (setf (buffer-writable mbuf) t) + (setf (buffer-pathname mbuf) + (merge-pathnames + msgs + (merge-relative-pathnames + (strip-folder-name (message-info-folder minfo)) + (mh-directory-pathname)))) + (setf (buffer-major-mode mbuf) "Text") + (do-recursive-edit) + (setf abortp nil)) + (when (and (not abortp) + (buffer-modified mbuf) + (prompt-for-y-or-n + :prompt "Message buffer modified, save it? " + :default t)) + (save-file-command nil mbuf)) + (setf (buffer-modified mbuf) nil) + ;; "Save File", which the user may have used, changes the buffer's name. + (unless (getstring mbuf-name *buffer-names*) + (setf (buffer-name mbuf) mbuf-name)) + (setf (buffer-writable mbuf) writable) + (setf (buffer-pathname mbuf) nil) + (setf (buffer-major-mode mbuf) "Message"))))) + + + + +;;;; Draft Mode. + +(defmode "Draft") + +(defhvar "Draft Information" + "This holds the information about the current draft buffer." + :value nil) + +(defstruct (draft-info (:include message/draft-info) + (:print-function print-draft-info)) + folder ;String name of draft folder with leading MH "+". + message ;String id of draft folder message. + pathname ;Pathname of draft in the draft folder directory. + delivered ;This is set when the draft was really sent. + replied-to-folder ;Folder of message draft is in reply to. + replied-to-msg) ;Message draft is in reply to. + +(defun print-draft-info (obj str n) + (declare (ignore n)) + (format str "#" (draft-info-message obj))) + + +(defhvar "Reply to Message Prefix Action" + "This is one of :cc-all, :no-cc-all, or nil. When an argument is supplied to + \"Reply to Message\", this value determines how arguments passed to the + MH utility." + :value nil) + +(defcommand "Reply to Message" (p) + "Sets up a draft in reply to the current message. + Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message. With an argument, regard \"Reply to Message Prefix + Action\" for carbon copy arguments to the MH utility." + "Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message." + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (setup-reply-draft (headers-info-folder hinfo) + cur-msg hinfo cur-mark p))) + (minfo + (setup-message-buffer-draft (current-buffer) minfo :reply p)) + (t + (let ((folder (prompt-for-folder))) + (setup-reply-draft folder + (car (prompt-for-message :folder folder)) + nil nil p)))))) + +;;; SETUP-REPLY-DRAFT takes a folder and msg to draft a reply to. Optionally, +;;; a headers buffer and mark are associated with the draft. First, the draft +;;; buffer is associated with the headers buffer if there is one. Then the +;;; message buffer is created and associated with the drafter buffer and +;;; headers buffer. Argument may be used to pass in the argument from the +;;; command. +;;; +(defun setup-reply-draft (folder msg &optional hinfo hmark argument) + (let* ((dbuffer (sub-setup-message-draft + "repl" :end-of-buffer + `(,folder ,msg + ,@(if argument + (case (value reply-to-message-prefix-action) + (:no-cc-all '("-nocc" "all")) + (:cc-all '("-cc" "all"))))))) + (dinfo (variable-value 'draft-information :buffer dbuffer)) + (h-buf (if hinfo (headers-info-buffer hinfo)))) + (setf (draft-info-replied-to-folder dinfo) folder) + (setf (draft-info-replied-to-msg dinfo) msg) + (when h-buf + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer dbuffer) + (setf (draft-info-headers-mark dinfo) hmark) + (push dbuffer (headers-info-draft-bufs hinfo))) + (let ((msg-buf (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msg) + :message))) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder :msgs msg + :headers-mark + (if h-buf (copy-mark hmark) hmark) + :draft-buf dbuffer) + :buffer msg-buf) + (when h-buf + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer msg-buf) + (push msg-buf (headers-info-other-msg-bufs hinfo))) + (read-mh-file (merge-pathnames + msg + (merge-relative-pathnames (strip-folder-name folder) + (mh-directory-pathname))) + msg-buf) + (setf (buffer-writable msg-buf) nil) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value msg-buf :buffer dbuffer)) + (get-draft-buffer-window dbuffer))) + + +(defcommand "Forward Message" (p) + "Forward current message. + Prompts for a folder and message to forward. When in a headers buffer, + forwards the message on the current line. When in a message buffer, + forwards that message." + "Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (setup-forward-draft (headers-info-folder hinfo) + cur-msg hinfo cur-mark))) + (minfo + (setup-message-buffer-draft (current-buffer) minfo :forward)) + (t + (let ((folder (prompt-for-folder))) + (setup-forward-draft folder + (car (prompt-for-message :folder folder)))))))) + +;;; SETUP-FORWARD-DRAFT sets up a draft forwarding folder's msg. When there +;;; is a headers buffer involved (hinfo and hmark), the draft is associated +;;; with it. +;;; +;;; This function is like SETUP-REPLY-DRAFT (in addition to "forw" and +;;; :to-field), but it does not setup a message buffer. If this is added as +;;; something forward drafts want, then SETUP-REPLY-DRAFT should be +;;; parameterized and renamed. +;;; +(defun setup-forward-draft (folder msg &optional hinfo hmark) + (let* ((dbuffer (sub-setup-message-draft "forw" :to-field + (list folder msg))) + (dinfo (variable-value 'draft-information :buffer dbuffer)) + (h-buf (if hinfo (headers-info-buffer hinfo)))) + (when h-buf + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer dbuffer) + (setf (draft-info-headers-mark dinfo) hmark) + (push dbuffer (headers-info-draft-bufs hinfo))) + (get-draft-buffer-window dbuffer))) + + +(defcommand "Send Message" (p) + "Setup a draft buffer. + Setup a draft buffer, reserving a draft folder message. When invoked in a + headers buffer, the current message is available in an associated message + buffer." + "Setup a draft buffer, reserving a draft folder message. When invoked in + a headers buffer, the current message is available in an associated + message buffer." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo (setup-headers-message-draft hinfo)) + (minfo (setup-message-buffer-draft (current-buffer) minfo :compose)) + (t (setup-message-draft))))) + +(defun setup-message-draft () + (get-draft-buffer-window (sub-setup-message-draft "comp" :to-field))) + +;;; SETUP-HEADERS-MESSAGE-DRAFT sets up a draft buffer associated with a +;;; headers buffer and a message buffer. The headers current message is +;;; inserted in the message buffer which is also associated with the headers +;;; buffer. The draft buffer is associated with the message buffer. +;;; +(defun setup-headers-message-draft (hinfo) + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (message "Draft not associated with any message.")) + (let* ((dbuffer (sub-setup-message-draft "comp" :to-field)) + (dinfo (variable-value 'draft-information :buffer dbuffer)) + (h-buf (headers-info-buffer hinfo))) + (when cur-msg + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated headers + buffer." + :value h-buf :buffer dbuffer) + (push dbuffer (headers-info-draft-bufs hinfo))) + (when cur-msg + (setf (draft-info-headers-mark dinfo) cur-mark) + (let* ((folder (headers-info-folder hinfo)) + (msg-buf (maybe-make-mh-buffer + (format nil "Message ~A ~A" folder cur-msg) + :message))) + (defhvar "Message Information" + "This holds the information about the current headers buffer." + :value (make-message-info :folder folder :msgs cur-msg + :headers-mark (copy-mark cur-mark) + :draft-buf dbuffer) + :buffer msg-buf) + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value h-buf :buffer msg-buf) + (push msg-buf (headers-info-other-msg-bufs hinfo)) + (read-mh-file (merge-pathnames + cur-msg + (merge-relative-pathnames (strip-folder-name folder) + (mh-directory-pathname))) + msg-buf) + (setf (buffer-writable msg-buf) nil) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value msg-buf :buffer dbuffer))) + (get-draft-buffer-window dbuffer)))) + +;;; SETUP-MESSAGE-BUFFER-DRAFT takes a message buffer and its message +;;; information. A draft buffer is created according to type, and the two +;;; buffers are associated. Any previous association of the message buffer and +;;; a draft buffer is dropped. Any association between the message buffer and +;;; a headers buffer is propagated to the draft buffer, and if the message +;;; buffer is the headers buffer's main message buffer, it is moved to "other" +;;; status. Argument may be used to pass in the argument from the command. +;;; +(defun setup-message-buffer-draft (msg-buf minfo type &optional argument) + (let* ((msgs (message-info-msgs minfo)) + (cur-msg (if (consp msgs) (car msgs) msgs)) + (folder (message-info-folder minfo)) + (dbuffer + (ecase type + (:reply + (sub-setup-message-draft + "repl" :end-of-buffer + `(,folder ,cur-msg + ,@(if argument + (case (value reply-to-message-prefix-action) + (:no-cc-all '("-nocc" "all")) + (:cc-all '("-cc" "all"))))))) + (:compose + (sub-setup-message-draft "comp" :to-field)) + (:forward + (sub-setup-message-draft "forw" :to-field + (list folder cur-msg))))) + (dinfo (variable-value 'draft-information :buffer dbuffer))) + (when (message-info-draft-buf minfo) + (delete-variable 'message-buffer :buffer (message-info-draft-buf minfo))) + (setf (message-info-draft-buf minfo) dbuffer) + (when (eq type :reply) + (setf (draft-info-replied-to-folder dinfo) folder) + (setf (draft-info-replied-to-msg dinfo) cur-msg)) + (when (hemlock-bound-p 'headers-buffer :buffer msg-buf) + (let* ((hbuf (variable-value 'headers-buffer :buffer msg-buf)) + (hinfo (variable-value 'headers-information :buffer hbuf))) + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers buffer." + :value hbuf :buffer dbuffer) + (setf (draft-info-headers-mark dinfo) + (copy-mark (message-info-headers-mark minfo))) + (push dbuffer (headers-info-draft-bufs hinfo)) + (when (eq (headers-info-msg-buffer hinfo) msg-buf) + (setf (headers-info-msg-buffer hinfo) nil) + (push msg-buf (headers-info-other-msg-bufs hinfo))))) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value msg-buf :buffer dbuffer) + (get-draft-buffer-window dbuffer))) + +(defvar *draft-to-pattern* + (new-search-pattern :string-insensitive :forward "To:")) + +(defun sub-setup-message-draft (utility point-action &optional args) + (mh utility `(,@args "-nowhatnowproc")) + (let* ((folder (mh-draft-folder)) + (draft-msg (mh-current-message folder)) + (msg-pn (merge-pathnames draft-msg (mh-draft-folder-pathname))) + (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" draft-msg) + :draft))) + (read-mh-file msg-pn dbuffer) + (setf (buffer-pathname dbuffer) msg-pn) + (defhvar "Draft Information" + "This holds the information about the current draft buffer." + :value (make-draft-info :folder (coerce-folder-name folder) + :message draft-msg + :pathname msg-pn) + :buffer dbuffer) + (let ((point (buffer-point dbuffer))) + (ecase point-action + (:to-field + (when (find-pattern point *draft-to-pattern*) + (line-end point))) + (:end-of-buffer (buffer-end point)))) + dbuffer)) + +(defun read-mh-file (pathname buffer) + (unless (probe-file pathname) + (editor-error "No such message -- ~A" (namestring pathname))) + (read-file pathname (buffer-point buffer)) + (setf (buffer-write-date buffer) (file-write-date pathname)) + (buffer-start (buffer-point buffer)) + (setf (buffer-modified buffer) nil)) + + +(defvar *draft-buffer-window-fun* 'change-to-buffer + "This is called by GET-DRAFT-BUFFER-WINDOW to display a new draft buffer. + The default is CHANGE-TO-BUFFER which uses the current window.") + +;;; GET-DRAFT-BUFFER-WINDOW is called to display a new draft buffer. +;;; +(defun get-draft-buffer-window (dbuffer) + (funcall *draft-buffer-window-fun* dbuffer)) + + +(defcommand "Reply to Message in Other Window" (p) + "Reply to message, creating another window for draft buffer. + Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message. The current window is split displaying the draft + buffer in the new window and the message buffer in the current." + "Prompts for a folder and message to reply to. When in a headers buffer, + replies to the message on the current line. When in a message buffer, + replies to that message." + (let ((*draft-buffer-window-fun* #'draft-buffer-in-other-window)) + (reply-to-message-command p))) + +(defun draft-buffer-in-other-window (dbuffer) + (when (hemlock-bound-p 'message-buffer :buffer dbuffer) + (let ((mbuf (variable-value 'message-buffer :buffer dbuffer))) + (when (not (eq (current-buffer) mbuf)) + (change-to-buffer mbuf)))) + (setf (current-buffer) dbuffer) + (setf (current-window) (make-window (buffer-start-mark dbuffer))) + (defhvar "Split Window Draft" + "Indicates window needs to be cleaned up for draft." + :value t :buffer dbuffer)) + +(defhvar "Deliver Message Confirm" + "When set, \"Deliver Message\" will ask for confirmation before sending the + draft. This is off by default since \"Deliver Message\" is not bound to + any key by default." + :value t) + +(defcommand "Deliver Message" (p) + "Save and deliver the current draft buffer. + When in a draft buffer, this saves the file and uses SEND to deliver the + draft. Otherwise, this prompts for a draft message id, invoking SEND." + "When in a draft buffer, this saves the file and uses SEND to deliver the + draft. Otherwise, this prompts for a draft message id, invoking SEND." + (declare (ignore p)) + (let ((dinfo (value draft-information))) + (cond (dinfo + (deliver-draft-buffer-message dinfo)) + (t + (let* ((folder (coerce-folder-name (mh-draft-folder))) + (msg (prompt-for-message :folder folder))) + (mh "send" `("-draftfolder" ,folder "-draftmessage" ,@msg))))))) + +(defun deliver-draft-buffer-message (dinfo) + (when (draft-info-delivered dinfo) + (editor-error "This draft has already been delivered.")) + (when (or (not (value deliver-message-confirm)) + (prompt-for-y-or-n :prompt "Deliver message? " :default t)) + (let ((dbuffer (current-buffer))) + (when (buffer-modified dbuffer) + (write-buffer-file dbuffer (buffer-pathname dbuffer))) + (message "Delivering draft ...") + (mh "send" `("-draftfolder" ,(draft-info-folder dinfo) + "-draftmessage" ,(draft-info-message dinfo))) + (setf (draft-info-delivered dinfo) t) + (let ((replied-folder (draft-info-replied-to-folder dinfo)) + (replied-msg (draft-info-replied-to-msg dinfo))) + (when replied-folder + (message "Annotating message being replied to ...") + (mh "anno" `(,replied-folder ,replied-msg "-component" "replied")) + (do-headers-buffers (hbuf replied-folder) + (with-headers-mark (hmark hbuf replied-msg) + (mark-to-note-replied-msg hmark) + (with-writable-buffer (hbuf) + (setf (next-character hmark) #\A)))) + (dolist (b *buffer-list*) + (when (and (hemlock-bound-p 'message-information :buffer b) + (buffer-modeline-field-p b :replied-to-message)) + (dolist (w (buffer-windows b)) + (update-modeline-field b w :replied-to-message)))))) + (maybe-delete-extra-draft-window dbuffer (current-window)) + (let ((mbuf (value message-buffer))) + (when (and mbuf + (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (and minfo (not (message-info-keep minfo))) + (delete-buffer-if-possible mbuf))))) + (delete-buffer-if-possible dbuffer)))) + +(defcommand "Delete Draft and Buffer" (p) + "Delete the current draft and associated message and buffer." + "Delete the current draft and associated message and buffer." + (declare (ignore p)) + (let ((dinfo (value draft-information)) + (dbuffer (current-buffer))) + (unless dinfo (editor-error "No draft associated with buffer.")) + (maybe-delete-extra-draft-window dbuffer (current-window)) + (delete-file (draft-info-pathname dinfo)) + (let ((mbuf (value message-buffer))) + (when (and mbuf + (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (and minfo (not (message-info-keep minfo))) + (delete-buffer-if-possible mbuf))))) + (delete-buffer-if-possible dbuffer))) + +;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW -- Internal. +;;; +;;; This takes a draft buffer and a window into it that should not be deleted. +;;; If "Split Window Draft" is bound in the buffer, and there are at least two +;;; windows in dbuffer-window's group, then we delete some window. Blow away +;;; the variable, so we don't think this is still a split window draft buffer. +;;; +(defun maybe-delete-extra-draft-window (dbuffer dbuffer-window) + (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer) + ;; Since we know bitmap devices have window groups, this loop is + ;; more correct than testing the length of *window-list* and + ;; accounting for *echo-area-window* being in there. + (do ((start dbuffer-window) + (count 1 (1+ count)) + (w (next-window dbuffer-window) (next-window w))) + ((eq start w) (> count 1)))) + (delete-window (next-window dbuffer-window)) + (delete-variable 'split-window-draft :buffer dbuffer))) + +(defcommand "Remail Message" (p) + "Prompts for a folder and message to remail. Prompts for a resend-to + address string and resend-cc address string. When in a headers buffer, + remails the message on the current line. When in a message buffer, + remails that message." + "Prompts for a folder and message to remail. Prompts for a resend-to + address string and resend-cc address string. When in a headers buffer, + remails the message on the current line. When in a message buffer, + remails that message." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (remail-message (headers-info-folder hinfo) cur-msg + (prompt-for-string :prompt "Resend To: ") + (prompt-for-string :prompt "Resend Cc: ")))) + (minfo + (remail-message (message-info-folder minfo) + (message-info-msgs minfo) + (prompt-for-string :prompt "Resend To: ") + (prompt-for-string :prompt "Resend Cc: "))) + (t + (let ((folder (prompt-for-folder))) + (remail-message folder + (car (prompt-for-message :folder folder)) + (prompt-for-string :prompt "Resend To: ") + (prompt-for-string :prompt "Resend Cc: ")))))) + (message "Message remailed.")) + + +;;; REMAIL-MESSAGE claims a draft folder message with "dist". This is then +;;; sucked into a buffer and modified by inserting the supplied addresses. +;;; "send" is used to deliver the draft, but it requires certain evironment +;;; variables to make it do the right thing. "mhdist" says the draft is only +;;; remailing information, and "mhaltmsg" is the message to send. "mhannotate" +;;; must be set due to a bug in MH's "send"; it will not notice the "mhdist" +;;; flag unless there is some message to be annotated. This command does not +;;; provide for annotation of the remailed message. +;;; +(defun remail-message (folder msg resend-to resend-cc) + (mh "dist" `(,folder ,msg "-nowhatnowproc")) + (let* ((draft-folder (mh-draft-folder)) + (draft-msg (mh-current-message draft-folder))) + (setup-remail-draft-message draft-msg resend-to resend-cc) + (mh "send" `("-draftfolder" ,draft-folder "-draftmessage" ,draft-msg) + :environment + `((:|mhdist| . "1") + (:|mhannotate| . "1") + (:|mhaltmsg| . ,(namestring + (merge-pathnames msg (merge-relative-pathnames + (strip-folder-name folder) + (mh-directory-pathname))))))))) + +;;; SETUP-REMAIL-DRAFT-MESSAGE takes a draft folder and message that have been +;;; created with the MH "dist" utility. A buffer is created with this +;;; message's pathname, searching for "resent-to:" and "resent-cc:", filling in +;;; the supplied argument values. After writing out the results, the buffer +;;; is deleted. +;;; +(defvar *draft-resent-to-pattern* + (new-search-pattern :string-insensitive :forward "resent-to:")) +(defvar *draft-resent-cc-pattern* + (new-search-pattern :string-insensitive :forward "resent-cc:")) + +(defun setup-remail-draft-message (msg resend-to resend-cc) + (let* ((msg-pn (merge-pathnames msg (mh-draft-folder-pathname))) + (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" msg) + :draft)) + (point (buffer-point dbuffer))) + (read-mh-file msg-pn dbuffer) + (when (find-pattern point *draft-resent-to-pattern*) + (line-end point) + (insert-string point resend-to)) + (buffer-start point) + (when (find-pattern point *draft-resent-cc-pattern*) + (line-end point) + (insert-string point resend-cc)) + (write-file (buffer-region dbuffer) msg-pn :keep-backup nil) + ;; The draft buffer delete hook expects this to be bound. + (defhvar "Draft Information" + "This holds the information about the current draft buffer." + :value :ignore + :buffer dbuffer) + (delete-buffer dbuffer))) + + + + +;;;; Message and Draft Stuff. + +(defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated headers + buffer." + :value nil) + +(defcommand "Goto Headers Buffer" (p) + "Selects associated headers buffer if it exists. + The headers buffer's point is moved to the appropriate line, pushing a + buffer mark where point was." + "Selects associated headers buffer if it exists." + (declare (ignore p)) + (let ((h-buf (value headers-buffer))) + (unless h-buf (editor-error "No associated headers buffer.")) + (let ((info (or (value message-information) (value draft-information)))) + (change-to-buffer h-buf) + (push-buffer-mark (copy-mark (current-point))) + (move-mark (current-point) (message/draft-info-headers-mark info))))) + +(defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value nil) + +(defcommand "Goto Message Buffer" (p) + "Selects associated message buffer if it exists." + "Selects associated message buffer if it exists." + (declare (ignore p)) + (let ((msg-buf (value message-buffer))) + (unless msg-buf (editor-error "No associated message buffer.")) + (change-to-buffer msg-buf))) + + +(defhvar "Message Insertion Prefix" + "This is a fill prefix that is used when inserting text from a message buffer + into a draft buffer by \"Insert Message Region\". It defaults to three + spaces." + :value " ") + +(defhvar "Message Insertion Column" + "This is a fill column that is used when inserting text from a message buffer + into a draft buffer by \"Insert Message Region\"." + :value 75) + +(defcommand "Insert Message Region" (p) + "Copy the current region into the associated draft or post buffer. When + in a message buffer that has an associated draft or post buffer, the + current active region is copied into the draft or post buffer. It is + filled using \"Message Insertion Prefix\" and \"Message Insertion + Column\". If an argument is supplied, the filling is inhibited. + If both a draft buffer and post buffer are associated with this, then it + is inserted into the draft buffer." + "When in a message buffer that has an associated draft or post buffer, + the current active region is copied into the post or draft buffer. It is + filled using \"Message Insertion Prefix\" and \"Message Insertion + Column\". If an argument is supplied, the filling is inhibited." + (let* ((minfo (value message-information)) + (nm-info (if (hemlock-bound-p 'netnews-message-info) + (value netnews-message-info))) + (post-buffer (and nm-info (nm-info-post-buffer nm-info))) + (post-info (and post-buffer + (variable-value 'post-info :buffer post-buffer))) + dbuf kind) + (cond (minfo + (setf kind :mail) + (setf dbuf (message-info-draft-buf minfo))) + (nm-info + (setf kind :netnews) + (setf dbuf (or (nm-info-draft-buffer nm-info) + (nm-info-post-buffer nm-info)))) + (t (editor-error "Not in a netnews message or message buffer."))) + (unless dbuf + (editor-error "Message buffer not associated with any draft or post ~ + buffer.")) + (let* ((region (copy-region (current-region))) + (dbuf-point (buffer-point dbuf)) + (dbuf-mark (copy-mark dbuf-point))) + (cond ((and (eq kind :mail) + (hemlock-bound-p 'split-window-draft :buffer dbuf) + (> (length (the list *window-list*)) 2) + (buffer-windows dbuf)) + (setf (current-buffer) dbuf + (current-window) (car (buffer-windows dbuf)))) + ((and (eq kind :netnews) + (and (member (post-info-message-window post-info) + *window-list*) + (member (post-info-reply-window post-info) + *window-list*))) + (setf (current-buffer) dbuf + (current-window) (post-info-reply-window post-info))) + (t (change-to-buffer dbuf))) + (push-buffer-mark dbuf-mark) + (ninsert-region dbuf-point region) + (unless p + (fill-region-by-paragraphs (region dbuf-mark dbuf-point) + (value message-insertion-prefix) + (value message-insertion-column))))) + (setf (last-command-type) :ephemerally-active)) + + +(defhvar "Message Buffer Insertion Prefix" + "This is a line prefix that is inserted at the beginning of every line in + a message buffer when inserting those lines into a draft buffer with + \"Insert Message Buffer\". It defaults to four spaces." + :value " ") + +(defcommand "Insert Message Buffer" (p) + "Insert entire (associated) message buffer into (associated) draft or + post buffer. When in a draft or post buffer with an associated message + buffer, or when in a message buffer that has an associated draft or post + buffer, the message buffer is inserted into the draft buffer. When + there are both an associated draft and post buffer, the text is inserted + into the draft buffer. Each inserted line is modified by prefixing it + with \"Message Buffer Insertion Prefix\". If an argument is supplied + the prefixing is inhibited." + "When in a draft or post buffer with an associated message buffer, or + when in a message buffer that has an associated draft or post buffer, the + message buffer is inserted into the draft buffer. Each inserted line is + modified by prefixing it with \"Message Buffer Insertion Prefix\". If an + argument is supplied the prefixing is inhibited." + (let ((minfo (value message-information)) + (dinfo (value draft-information)) + mbuf dbuf message-kind) + (cond (minfo + (setf message-kind :mail) + (setf dbuf (message-info-draft-buf minfo)) + (unless dbuf + (editor-error + "Message buffer not associated with any draft buffer.")) + (setf mbuf (current-buffer)) + (change-to-buffer dbuf)) + (dinfo + (setf message-kind :mail) + (setf mbuf (value message-buffer)) + (unless mbuf + (editor-error + "Draft buffer not associated with any message buffer.")) + (setf dbuf (current-buffer))) + ((hemlock-bound-p 'netnews-message-info) + (setf message-kind :netnews) + (setf mbuf (current-buffer)) + (let ((nm-info (value netnews-message-info))) + (setf dbuf (or (nm-info-draft-buffer nm-info) + (nm-info-post-buffer nm-info))) + (unless dbuf + (editor-error "Message buffer not associated with any draft ~ + or post buffer."))) + (change-to-buffer dbuf)) + ((hemlock-bound-p 'post-info) + (setf message-kind :netnews) + (let ((post-info (value post-info))) + (setf mbuf (post-info-message-buffer post-info)) + (unless mbuf + (editor-error "Post buffer not associated with any message ~ + buffer."))) + (setf dbuf (current-buffer))) + (t (editor-error "Not in a draft, message, news-message, or post ~ + buffer."))) + (let* ((dbuf-point (buffer-point dbuf)) + (dbuf-mark (copy-mark dbuf-point))) + (push-buffer-mark dbuf-mark) + (insert-region dbuf-point (buffer-region mbuf)) + (unless p + (let ((prefix (value message-buffer-insertion-prefix))) + (with-mark ((temp dbuf-mark :left-inserting)) + (loop + (when (mark>= temp dbuf-point) (return)) + (insert-string temp prefix) + (unless (line-offset temp 1 0) (return))))))) + (ecase message-kind + (:mail + (insert-message-buffer-cleanup-split-draft dbuf mbuf)) + (:netnews + (nn-reply-cleanup-split-windows dbuf)))) + (setf (last-command-type) :ephemerally-active)) + +;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window +;;; due to "Reply to Message in Other Window". Since we just inserted the +;;; message buffer in the draft buffer, we don't need the other window into +;;; the message buffer. +;;; +(defun insert-message-buffer-cleanup-split-draft (dbuf mbuf) + (when (and (hemlock-bound-p 'split-window-draft :buffer dbuf) + (> (length (the list *window-list*)) 2)) + (let ((win (car (buffer-windows mbuf)))) + (cond + (win + (when (eq win (current-window)) + (let ((dwin (car (buffer-windows dbuf)))) + (unless dwin + (editor-error "Couldn't fix windows for split window draft.")) + (setf (current-buffer) dbuf) + (setf (current-window) dwin))) + (delete-window win)) + (t ;; This happens when invoked with the message buffer current. + (let ((dwins (buffer-windows dbuf))) + (when (> (length (the list dwins)) 1) + (delete-window (find-if #'(lambda (w) + (not (eq w (current-window)))) + dwins))))))) + (delete-variable 'split-window-draft :buffer dbuf))) + + +;;; CLEANUP-MESSAGE-BUFFER is called when a buffer gets deleted. It cleans +;;; up references to a message buffer. +;;; +(defun cleanup-message-buffer (buffer) + (let ((minfo (variable-value 'message-information :buffer buffer))) + (when (hemlock-bound-p 'headers-buffer :buffer buffer) + (let* ((hinfo (variable-value 'headers-information + :buffer (variable-value 'headers-buffer + :buffer buffer))) + (msg-buf (headers-info-msg-buffer hinfo))) + (if (eq msg-buf buffer) + (setf (headers-info-msg-buffer hinfo) nil) + (setf (headers-info-other-msg-bufs hinfo) + (delete buffer (headers-info-other-msg-bufs hinfo) + :test #'eq)))) + (delete-mark (message-info-headers-mark minfo)) + ;; + ;; Do this for MAYBE-MAKE-MH-BUFFER since it isn't necessary for GC. + (delete-variable 'headers-buffer :buffer buffer)) + (when (message-info-draft-buf minfo) + (delete-variable 'message-buffer + :buffer (message-info-draft-buf minfo))))) + +;;; CLEANUP-DRAFT-BUFFER is called when a buffer gets deleted. It cleans +;;; up references to a draft buffer. +;;; +(defun cleanup-draft-buffer (buffer) + (let ((dinfo (variable-value 'draft-information :buffer buffer))) + (when (hemlock-bound-p 'headers-buffer :buffer buffer) + (let* ((hinfo (variable-value 'headers-information + :buffer (variable-value 'headers-buffer + :buffer buffer)))) + (setf (headers-info-draft-bufs hinfo) + (delete buffer (headers-info-draft-bufs hinfo) :test #'eq)) + (delete-mark (draft-info-headers-mark dinfo)))) + (when (hemlock-bound-p 'message-buffer :buffer buffer) + (setf (message-info-draft-buf + (variable-value 'message-information + :buffer (variable-value 'message-buffer + :buffer buffer))) + nil)))) + +;;; CLEANUP-HEADERS-BUFFER is called when a buffer gets deleted. It cleans +;;; up references to a headers buffer. +;;; +(defun cleanup-headers-buffer (buffer) + (let* ((hinfo (variable-value 'headers-information :buffer buffer)) + (msg-buf (headers-info-msg-buffer hinfo))) + (when msg-buf + (cleanup-headers-reference + msg-buf (variable-value 'message-information :buffer msg-buf))) + (dolist (b (headers-info-other-msg-bufs hinfo)) + (cleanup-headers-reference + b (variable-value 'message-information :buffer b))) + (dolist (b (headers-info-draft-bufs hinfo)) + (cleanup-headers-reference + b (variable-value 'draft-information :buffer b))))) + +(defun cleanup-headers-reference (buffer info) + (delete-mark (message/draft-info-headers-mark info)) + (setf (message/draft-info-headers-mark info) nil) + (delete-variable 'headers-buffer :buffer buffer) + (when (typep info 'draft-info) + (setf (draft-info-replied-to-folder info) nil) + (setf (draft-info-replied-to-msg info) nil))) + +;;; REVAMP-HEADERS-BUFFER cleans up a headers buffer for immediate re-use. +;;; After deleting the buffer's region, there will be one line in the buffer +;;; because of how Hemlock regions work, so we have to delete that line's +;;; plist. Then we clean up any references to the buffer and delete the +;;; main message buffer. The other message buffers are left alone assuming +;;; they are on the "others" list because they are being used in some +;;; particular way (for example, a draft buffer refers to one or the user has +;;; kept it). Then some slots of the info structure are set to nil. +;;; +(defun revamp-headers-buffer (hbuffer hinfo) + (delete-region (buffer-region hbuffer)) + (setf (line-plist (mark-line (buffer-point hbuffer))) nil) + (let ((msg-buf (headers-info-msg-buffer hinfo))) + ;; Deleting the buffer sets the slot to nil. + (when msg-buf (delete-buffer-if-possible msg-buf)) + (cleanup-headers-buffer hbuffer)) + (setf (headers-info-other-msg-bufs hinfo) nil) + (setf (headers-info-draft-bufs hinfo) nil) + (setf (headers-info-msg-seq hinfo) nil) + (setf (headers-info-msg-strings hinfo) nil)) + + + + +;;;; Incorporating new mail. + +(defhvar "New Mail Folder" + "This is the folder new mail is incorporated into." + :value "+inbox") + +(defcommand "Incorporate New Mail" (p) + "Incorporates new mail into \"New Mail Folder\", displaying INC output in + a pop-up window." + "Incorporates new mail into \"New Mail Folder\", displaying INC output in + a pop-up window." + (declare (ignore p)) + (with-pop-up-display (s) + (incorporate-new-mail s))) + +(defhvar "Unseen Headers Message Spec" + "This is an MH message spec suitable any message prompt. It is used to + supply headers for the unseen headers buffer, in addition to the + unseen-sequence name that is taken from the user's MH profile, when + incorporating new mail and after expunging. This value is a string." + :value nil) + +(defcommand "Incorporate and Read New Mail" (p) + "Incorporates new mail and generates a headers buffer. + Incorporates new mail into \"New Mail Folder\", and creates a headers buffer + with the new messages. To use this, you must define an unseen- sequence in + your profile. Each time this is invoked the unseen-sequence is SCAN'ed, and + the headers buffer's contents are replaced." + "Incorporates new mail into \"New Mail Folder\", and creates a headers + buffer with the new messages. This buffer will be appended to with + successive uses of this command." + (declare (ignore p)) + (let ((unseen-seq (mh-profile-component "unseen-sequence"))) + (unless unseen-seq + (editor-error "No unseen-sequence defined in MH profile.")) + (incorporate-new-mail) + (let* ((folder (value new-mail-folder)) + ;; Stash current message before fetching unseen headers. + (cur-msg (mh-current-message folder)) + (region (get-new-mail-msg-hdrs folder unseen-seq))) + ;; Fetch message headers before possibly making buffer in case we error. + (when (not (and *new-mail-buffer* + (member *new-mail-buffer* *buffer-list* :test #'eq))) + (let ((name (format nil "Unseen Headers ~A" folder))) + (when (getstring name *buffer-names*) + (editor-error "There already is a buffer named ~S!" name)) + (setf *new-mail-buffer* + (make-buffer name :modes (list "Headers") + :delete-hook '(new-mail-buf-delete-hook))) + (setf (buffer-writable *new-mail-buffer*) nil))) + (cond ((hemlock-bound-p 'headers-information + :buffer *new-mail-buffer*) + (let ((hinfo (variable-value 'headers-information + :buffer *new-mail-buffer*))) + (unless (string= (headers-info-folder hinfo) folder) + (editor-error + "An unseen headers buffer already exists but into another ~ + folder. Your mail has already been incorporated into the ~ + specified folder.")) + (with-writable-buffer (*new-mail-buffer*) + (revamp-headers-buffer *new-mail-buffer* hinfo)) + ;; Restore the name in case someone used "Pick Headers". + (setf (buffer-name *new-mail-buffer*) + (format nil "Unseen Headers ~A" folder)) + (insert-new-mail-message-headers hinfo region cur-msg))) + (t + (let ((hinfo (make-headers-info :buffer *new-mail-buffer* + :folder folder))) + (defhvar "Headers Information" + "This holds the information about the current headers buffer." + :value hinfo :buffer *new-mail-buffer*) + (insert-new-mail-message-headers hinfo region cur-msg))))))) + +;;; NEW-MAIL-BUF-DELETE-HOOK is invoked whenever the new mail buffer is +;;; deleted. +;;; +(defun new-mail-buf-delete-hook (buffer) + (declare (ignore buffer)) + (setf *new-mail-buffer* nil)) + +;;; GET-NEW-MAIL-MSG-HDRS takes a folder and the unseen-sequence name. It +;;; returns a region with the unseen message headers and any headers due to +;;; the "Unseen Headers Message Spec" variable. +;;; +(defun get-new-mail-msg-hdrs (folder unseen-seq) + (let* ((unseen-headers-message-spec (value unseen-headers-message-spec)) + (other-msgs (if unseen-headers-message-spec + (breakup-message-spec + (string-trim '(#\space #\tab) + unseen-headers-message-spec)))) + (msg-spec (cond ((null other-msgs) + (list unseen-seq)) + ((member unseen-seq other-msgs :test #'string=) + other-msgs) + (t (cons unseen-seq other-msgs))))) + (message-headers-to-region folder msg-spec))) + +;;; INSERT-NEW-MAIL-MESSAGE-HEADERS inserts region in the new mail buffer. +;;; Then we look for the header line with cur-msg id, moving point there. +;;; There may have been unseen messages before incorporating new mail, and +;;; cur-msg should be the first new message. Then we either switch to the +;;; new mail headers, or show the current message. +;;; +(defun insert-new-mail-message-headers (hinfo region cur-msg) + (declare (simple-string cur-msg)) + (with-writable-buffer (*new-mail-buffer*) + (insert-message-headers *new-mail-buffer* hinfo region)) + (let ((point (buffer-point *new-mail-buffer*))) + (buffer-start point) + (with-headers-mark (cur-mark *new-mail-buffer* cur-msg) + (move-mark point cur-mark))) + (change-to-buffer *new-mail-buffer*)) + + +(defhvar "Incorporate New Mail Hook" + "Functions on this hook are invoked immediately after new mail is + incorporated." + :value nil) + +(defun incorporate-new-mail (&optional stream) + "Incorporates new mail, passing INC's output to stream. When stream is + nil, output is flushed." + (unless (new-mail-p) (editor-error "No new mail.")) + (let ((args `(,(coerce-folder-name (value new-mail-folder)) + ,@(if stream nil '("-silent")) + "-form" ,(namestring (truename (value mh-scan-line-form))) + "-width" ,(number-string (value fill-column))))) + (message "Incorporating new mail ...") + (mh "inc" args)) + (when (value incorporate-new-mail-hook) + (message "Invoking new mail hooks ...")) + (invoke-hook incorporate-new-mail-hook)) + + + + +;;;; Deletion. + +(defhvar "Virtual Message Deletion" + "When set, \"Delete Message\" merely MARK's a message into the + \"hemlockdeleted\" sequence; otherwise, RMM is invoked." + :value t) + +(defcommand "Delete Message and Show Next" (p) + "Delete message and show next undeleted message. + This command is only valid in a headers buffer or a message buffer + associated with some headers buffer. The current message is deleted, and + the next undeleted one is shown." + "Delete the current message and show the next undeleted one." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (delete-message (headers-info-folder hinfo) cur-msg))) + (minfo + (delete-message (message-info-folder minfo) + (message-info-msgs minfo))) + (t + (editor-error "Not in a headers or message buffer.")))) + (show-message-offset 1 :undeleted)) + +(defcommand "Delete Message and Down Line" (p) + "Deletes the current message, moving point to the next line. + When in a headers buffer, deletes the message on the current line. Then it + moves point to the next non-blank line." + "Deletes current message and moves point down a line." + (declare (ignore p)) + (let ((hinfo (value headers-information))) + (unless hinfo (editor-error "Not in a headers buffer.")) + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-message (headers-info-folder hinfo) cur-msg) + (when (line-offset cur-mark 1) + (unless (blank-line-p (mark-line cur-mark)) + (move-mark (current-point) cur-mark))) + (delete-mark cur-mark)))) + +;;; "Delete Message" unlike "Headers Delete Message" cannot know for sure +;;; which message id's have been deleted, so when virtual message deletion +;;; is not used, we cannot use DELETE-HEADERS-BUFFER-LINE to keep headers +;;; buffers consistent. However, the message id's in the buffer (if deleted) +;;; will generate MH errors if operations are attempted with them, and +;;; if the user ever packs the folder with "Expunge Messages", the headers +;;; buffer will be updated. +;;; +(defcommand "Delete Message" (p) + "Prompts for a folder, messages to delete, and pick expression. When in + a headers buffer into the same folder specified, the messages prompt + defaults to those messages in the buffer; \"all\" may be entered if this is + not what is desired. When \"Virtual Message Deletion\" is set, messages are + only MARK'ed for deletion. See \"Expunge Messages\". When this feature is + not used, headers and message buffers message id's my not be consistent + with MH." + "Prompts for a folder and message to delete. When \"Virtual Message + Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge + Messages\"." + (declare (ignore p)) + (let* ((folder (prompt-for-folder)) + (hinfo (value headers-information)) + (temp-msgs (prompt-for-message + :folder folder + :messages + (if (and hinfo + (string= folder + (the simple-string + (headers-info-folder hinfo)))) + (headers-info-msg-strings hinfo)) + :prompt "MH messages to pick from: ")) + (pick-exp (prompt-for-pick-expression)) + (msgs (pick-messages folder temp-msgs pick-exp)) + (virtually (value virtual-message-deletion))) + (declare (simple-string folder)) + (if virtually + (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-add")) + (mh "rmm" `(,folder ,@msgs))) + (if virtually + (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + (when deleted-seq + (do-headers-buffers (hbuf folder) + (with-writable-buffer (hbuf) + (note-deleted-headers hbuf deleted-seq))))) + (do-headers-buffers (hbuf folder hinfo) + (do-headers-lines (hbuf :line-var line :mark-var hmark) + (when (member (line-message-id line) msgs :test #'string=) + (delete-headers-buffer-line hinfo hmark))))))) + +(defcommand "Headers Delete Message" (p) + "Delete current message. + When in a headers buffer, deletes the message on the current line. When + in a message buffer, deletes that message. When \"Virtual Message + Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge + Messages\"." + "When in a headers buffer, deletes the message on the current line. When + in a message buffer, deletes that message. When \"Virtual Message + Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge + Messages\"." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (delete-message (headers-info-folder hinfo) cur-msg))) + (minfo + (let ((msgs (message-info-msgs minfo))) + (delete-message (message-info-folder minfo) + (if (consp msgs) (car msgs) msgs))) + (message "Message deleted.")) + (t (editor-error "Not in a headers or message buffer."))))) + +;;; DELETE-MESSAGE takes a folder and message id and either flags this message +;;; for deletion or deletes it. All headers buffers into folder are updated, +;;; either by flagging a headers line or deleting it. +;;; +(defun delete-message (folder msg) + (cond ((value virtual-message-deletion) + (mark-one-message folder msg "hemlockdeleted" :add) + (do-headers-buffers (hbuf folder) + (with-headers-mark (hmark hbuf msg) + (with-writable-buffer (hbuf) + (note-deleted-message-at-mark hmark))))) + (t (mh "rmm" (list folder msg)) + (do-headers-buffers (hbuf folder hinfo) + (with-headers-mark (hmark hbuf msg) + (delete-headers-buffer-line hinfo hmark))))) + (dolist (b *buffer-list*) + (when (and (hemlock-bound-p 'message-information :buffer b) + (buffer-modeline-field-p b :deleted-message)) + (dolist (w (buffer-windows b)) + (update-modeline-field b w :deleted-message))))) + +;;; NOTE-DELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid +;;; headers line, sticks a "D" on the line, and frobs the line's deleted +;;; property. This assumes the headers buffer is modifiable. +;;; +(defun note-deleted-message-at-mark (mark) + (find-attribute mark :digit) + (find-attribute mark :digit #'zerop) + (character-offset mark 2) + (setf (next-character mark) #\D) + (setf (line-message-deleted (mark-line mark)) t)) + +;;; DELETE-HEADERS-BUFFER-LINE takes a headers information and a mark on the +;;; line to be deleted. Before deleting the line, we check to see if any +;;; message or draft buffers refer to the buffer because of the line. Due +;;; to how regions are deleted, line plists get messed up, so they have to +;;; be regenerated. We regenerate them for the whole buffer, so we don't have +;;; to hack the code to know which lines got messed up. +;;; +(defun delete-headers-buffer-line (hinfo hmark) + (delete-headers-line-references hinfo hmark) + (let ((id (line-message-id (mark-line hmark))) + (hbuf (headers-info-buffer hinfo))) + (with-writable-buffer (hbuf) + (with-mark ((end (line-start hmark) :left-inserting)) + (unless (line-offset end 1 0) (buffer-end end)) + (delete-region (region hmark end)))) + (let ((seq (mh-sequence-delete id (headers-info-msg-seq hinfo)))) + (setf (headers-info-msg-seq hinfo) seq) + (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq))) + (set-message-headers-ids hbuf) + (when (value virtual-message-deletion) + (let ((deleted-seq (mh-sequence-list (headers-info-folder hinfo) + "hemlockdeleted"))) + (do-headers-lines (hbuf :line-var line) + (setf (line-message-deleted line) + (mh-sequence-member-p (line-message-id line) deleted-seq))))))) + + +;;; DELETE-HEADERS-LINE-REFERENCES removes any message buffer or draft buffer +;;; pointers to a headers buffer or marks into the headers buffer. Currently +;;; message buffers and draft buffers are identified differently for no good +;;; reason; probably message buffers should be located in the same way draft +;;; buffers are. Also, we currently assume only one of other-msg-bufs could +;;; refer to the line (similarly for draft-bufs), but this might be bug +;;; prone. The message buffer case couldn't happen since the buffer name +;;; would cause MAYBE-MAKE-MH-BUFFER to re-use the buffer, but you could reply +;;; to the same message twice simultaneously. +;;; +(defun delete-headers-line-references (hinfo hmark) + (let ((msg-id (line-message-id (mark-line hmark))) + (main-msg-buf (headers-info-msg-buffer hinfo))) + (declare (simple-string msg-id)) + (when main-msg-buf + (let ((minfo (variable-value 'message-information :buffer main-msg-buf))) + (when (string= (the simple-string (message-info-msgs minfo)) + msg-id) + (cond ((message-info-draft-buf minfo) + (cleanup-headers-reference main-msg-buf minfo) + (setf (headers-info-msg-buffer hinfo) nil)) + (t (delete-buffer-if-possible main-msg-buf)))))) + (dolist (mbuf (headers-info-other-msg-bufs hinfo)) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (string= (the simple-string (message-info-msgs minfo)) + msg-id) + (cond ((message-info-draft-buf minfo) + (cleanup-headers-reference mbuf minfo) + (setf (headers-info-other-msg-bufs hinfo) + (delete mbuf (headers-info-other-msg-bufs hinfo) + :test #'eq))) + (t (delete-buffer-if-possible mbuf))) + (return))))) + (dolist (dbuf (headers-info-draft-bufs hinfo)) + (let ((dinfo (variable-value 'draft-information :buffer dbuf))) + (when (same-line-p (draft-info-headers-mark dinfo) hmark) + (cleanup-headers-reference dbuf dinfo) + (setf (headers-info-draft-bufs hinfo) + (delete dbuf (headers-info-draft-bufs hinfo) :test #'eq)) + (return))))) + + +(defcommand "Undelete Message" (p) + "Prompts for a folder, messages to undelete, and pick expression. When in + a headers buffer into the same folder specified, the messages prompt + defaults to those messages in the buffer; \"all\" may be entered if this is + not what is desired. This command is only meaningful if you have + \"Virtual Message Deletion\" set." + "Prompts for a folder, messages to undelete, and pick expression. When in + a headers buffer into the same folder specified, the messages prompt + defaults to those messages in the buffer; \"all\" may be entered if this is + not what is desired. This command is only meaningful if you have + \"Virtual Message Deletion\" set." + (declare (ignore p)) + (unless (value virtual-message-deletion) + (editor-error "You don't use virtual message deletion.")) + (let* ((folder (prompt-for-folder)) + (hinfo (value headers-information)) + (temp-msgs (prompt-for-message + :folder folder + :messages + (if (and hinfo + (string= folder + (the simple-string + (headers-info-folder hinfo)))) + (headers-info-msg-strings hinfo)) + :prompt "MH messages to pick from: ")) + (pick-exp (prompt-for-pick-expression)) + (msgs (if pick-exp + (or (pick-messages folder temp-msgs pick-exp) temp-msgs) + temp-msgs))) + (declare (simple-string folder)) + (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-delete")) + (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + (do-headers-buffers (hbuf folder) + (with-writable-buffer (hbuf) + (do-headers-lines (hbuf :line-var line :mark-var hmark) + (when (and (line-message-deleted line) + (not (mh-sequence-member-p (line-message-id line) + deleted-seq))) + (note-undeleted-message-at-mark hmark)))))))) + +(defcommand "Headers Undelete Message" (p) + "Undelete the current message. + When in a headers buffer, undeletes the message on the current line. When + in a message buffer, undeletes that message. This command is only + meaningful if you have \"Virtual Message Deletion\" set." + "When in a headers buffer, undeletes the message on the current line. When + in a message buffer, undeletes that message. This command is only + meaningful if you have \"Virtual Message Deletion\" set." + (declare (ignore p)) + (unless (value virtual-message-deletion) + (editor-error "You don't use virtual message deletion.")) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (undelete-message (headers-info-folder hinfo) cur-msg))) + (minfo + (undelete-message (message-info-folder minfo) + (message-info-msgs minfo)) + (message "Message undeleted.")) + (t (editor-error "Not in a headers or message buffer."))))) + +;;; UNDELETE-MESSAGE takes a folder and a message id. All headers buffers into +;;; folder are updated. +;;; +(defun undelete-message (folder msg) + (mark-one-message folder msg "hemlockdeleted" :delete) + (do-headers-buffers (hbuf folder) + (with-headers-mark (hmark hbuf msg) + (with-writable-buffer (hbuf) + (note-undeleted-message-at-mark hmark)))) + (dolist (b *buffer-list*) + (when (and (hemlock-bound-p 'message-information :buffer b) + (buffer-modeline-field-p b :deleted-message)) + (dolist (w (buffer-windows b)) + (update-modeline-field b w :deleted-message))))) + +;;; NOTE-UNDELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid +;;; headers line, sticks a space on the line in place of a "D", and frobs the +;;; line's deleted property. This assumes the headers buffer is modifiable. +;;; +(defun note-undeleted-message-at-mark (hmark) + (find-attribute hmark :digit) + (find-attribute hmark :digit #'zerop) + (character-offset hmark 2) + (setf (next-character hmark) #\space) + (setf (line-message-deleted (mark-line hmark)) nil)) + + +(defcommand "Expunge Messages" (p) + "Expunges messages marked for deletion. + This command prompts for a folder, invoking RMM on the \"hemlockdeleted\" + sequence after asking the user for confirmation. Setting \"Quit Headers + Confirm\" to nil inhibits prompting. The folder's message id's are packed + with FOLDER -pack. When in a headers buffer, uses that folder. When in a + message buffer, uses its folder, updating any associated headers buffer. + When \"Temporary Draft Folder\" is bound, this folder's messages are deleted + and expunged." + "Prompts for a folder, invoking RMM on the \"hemlockdeleted\" sequence and + packing the message id's with FOLDER -pack. When in a headers buffer, + uses that folder." + (declare (ignore p)) + (let* ((hinfo (value headers-information)) + (minfo (value message-information)) + (folder (cond (hinfo (headers-info-folder hinfo)) + (minfo (message-info-folder minfo)) + (t (prompt-for-folder)))) + (deleted-seq (mh-sequence-list folder "hemlockdeleted"))) + ;; + ;; Delete the messages if there are any. + ;; This deletes "hemlockdeleted" from sequence file; we don't have to. + (when (and deleted-seq + (or (not (value expunge-messages-confirm)) + (prompt-for-y-or-n + :prompt (list "Expunge messages and pack folder ~A? " + folder) + :default t + :default-string "Y"))) + (message "Deleting messages ...") + (mh "rmm" (list folder "hemlockdeleted")) + ;; + ;; Compact the message id's after deletion. + (let ((*standard-output* *mh-utility-bit-bucket*)) + (message "Compacting folder ...") + (mh "folder" (list folder "-fast" "-pack"))) + ;; + ;; Do a bunch of consistency maintenance. + (let ((new-buf-p (eq (current-buffer) *new-mail-buffer*))) + (message "Maintaining consistency ...") + (expunge-messages-fold-headers-buffers folder) + (expunge-messages-fix-draft-buffers folder) + (expunge-messages-fix-unseen-headers folder) + (when new-buf-p (change-to-buffer *new-mail-buffer*))) + (delete-and-expunge-temp-drafts)))) + +;;; EXPUNGE-MESSAGES-FOLD-HEADERS-BUFFERS deletes all headers buffers into the +;;; compacted folder. We can only update the headers buffers by installing all +;;; headers, so there may as well be only one such buffer. First we get a list +;;; of the buffers since DO-HEADERS-BUFFERS is trying to iterate over a list +;;; being destructively modified by buffer deletions. +;;; +(defun expunge-messages-fold-headers-buffers (folder) + (let (hbufs) + (declare (list hbufs)) + (do-headers-buffers (b folder) + (unless (eq b *new-mail-buffer*) + (push b hbufs))) + (unless (zerop (length hbufs)) + (dolist (b hbufs) + (delete-headers-buffer-and-message-buffers-command nil b)) + (new-message-headers folder (list "all"))))) + +;;; EXPUNGE-MESSAGES-FIX-DRAFT-BUFFERS finds any draft buffer that was set up +;;; as a reply to some message in folder, removing this relationship in case +;;; that message id does not exist after expunge folder compaction. +;;; +(defun expunge-messages-fix-draft-buffers (folder) + (declare (simple-string folder)) + (dolist (b *buffer-list*) + (when (hemlock-bound-p 'draft-information :buffer b) + (let* ((dinfo (variable-value 'draft-information :buffer b)) + (reply-folder (draft-info-replied-to-folder dinfo))) + (when (and reply-folder + (string= (the simple-string reply-folder) folder)) + (setf (draft-info-replied-to-folder dinfo) nil) + (setf (draft-info-replied-to-msg dinfo) nil)))))) + +;;; EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS specially handles the unseen headers +;;; buffer apart from the other headers buffers into the same folder when +;;; messages have been expunged. We must delete the associated message buffers +;;; since REVAMP-HEADERS-BUFFER does not, and these potentially reference bad +;;; message id's. When doing this we must copy the other-msg-bufs list since +;;; the delete buffer cleanup hook for them is destructive. Then we check for +;;; more unseen messages. +;;; +(defun expunge-messages-fix-unseen-headers (folder) + (declare (simple-string folder)) + (when *new-mail-buffer* + (let ((hinfo (variable-value 'headers-information + :buffer *new-mail-buffer*))) + (when (string= (the simple-string (headers-info-folder hinfo)) + folder) + (let ((other-bufs (copy-list (headers-info-other-msg-bufs hinfo)))) + (dolist (b other-bufs) (delete-buffer-if-possible b))) + (with-writable-buffer (*new-mail-buffer*) + (revamp-headers-buffer *new-mail-buffer* hinfo) + ;; Restore the name in case someone used "Pick Headers". + (setf (buffer-name *new-mail-buffer*) + (format nil "Unseen Headers ~A" folder)) + (let ((region (maybe-get-new-mail-msg-hdrs folder))) + (when region + (insert-message-headers *new-mail-buffer* hinfo region)))))))) + +;;; MAYBE-GET-NEW-MAIL-MSG-HDRS returns a region suitable for a new mail buffer +;;; or nil. Folder is probed for unseen headers, and if there are some, then +;;; we call GET-NEW-MAIL-MSG-HDRS which also uses "Unseen Headers Message Spec". +;;; If there are no unseen headers, we only look for "Unseen Headers Message +;;; Spec" messages. We go through these contortions to keep MH from outputting +;;; errors. +;;; +(defun maybe-get-new-mail-msg-hdrs (folder) + (let ((unseen-seq-name (mh-profile-component "unseen-sequence"))) + (multiple-value-bind (unseen-seq foundp) + (mh-sequence-list folder unseen-seq-name) + (if (and foundp unseen-seq) + (get-new-mail-msg-hdrs folder unseen-seq-name) + (let ((spec (value unseen-headers-message-spec))) + (when spec + (message-headers-to-region + folder + (breakup-message-spec (string-trim '(#\space #\tab) spec))))))))) + + + + +;;;; Folders. + +(defvar *folder-name-table* nil) + +(defun check-folder-name-table () + (unless *folder-name-table* + (message "Finding folder names ...") + (setf *folder-name-table* (make-string-table)) + (let* ((output (with-output-to-string (*standard-output*) + (mh "folders" '("-fast")))) + (length (length output)) + (start 0)) + (declare (simple-string output)) + (loop + (when (> start length) (return)) + (let ((nl (position #\newline output :start start))) + (unless nl (return)) + (unless (= start nl) + (setf (getstring (subseq output start nl) *folder-name-table*) t)) + (setf start (1+ nl))))))) + +(defcommand "List Folders" (p) + "Pop up a list of folders at top-level." + "Pop up a list of folders at top-level." + (declare (ignore p)) + (check-folder-name-table) + (with-pop-up-display (s) + (do-strings (f ignore *folder-name-table*) + (declare (ignore ignore)) + (write-line f s)))) + +(defcommand "Create Folder" (p) + "Creates a folder. If the folder already exists, an error is signaled." + "Creates a folder. If the folder already exists, an error is signaled." + (declare (ignore p)) + (let ((folder (prompt-for-folder :must-exist nil))) + (when (folder-existsp folder) + (editor-error "Folder already exists -- ~S!" folder)) + (create-folder folder))) + +(defcommand "Delete Folder" (p) + "Prompts for a folder and uses RMF to delete it." + "Prompts for a folder and uses RMF to delete it." + (declare (ignore p)) + (let* ((folder (prompt-for-folder)) + (*standard-output* *mh-utility-bit-bucket*)) + (mh "rmf" (list folder)) + ;; RMF doesn't recognize this documented switch. + ;; "-nointeractive")))) + (check-folder-name-table) + (delete-string (strip-folder-name folder) *folder-name-table*))) + + +(defvar *refile-default-destination* nil) + +(defcommand "Refile Message" (p) + "Prompts for a source folder, messages, pick expression, and a destination + folder to refile the messages." + "Prompts for a source folder, messages, pick expression, and a destination + folder to refile the messages." + (declare (ignore p)) + (let* ((src-folder (prompt-for-folder :prompt "Source folder: ")) + (hinfo (value headers-information)) + (temp-msgs (prompt-for-message + :folder src-folder + :messages + (if (and hinfo + (string= src-folder + (the simple-string + (headers-info-folder hinfo)))) + (headers-info-msg-strings hinfo)) + :prompt "MH messages to pick from: ")) + (pick-exp (prompt-for-pick-expression)) + ;; Return pick result or temp-msgs individually specified in a list. + (msgs (pick-messages src-folder temp-msgs pick-exp))) + (declare (simple-string src-folder)) + (refile-message src-folder msgs + (prompt-for-folder :must-exist nil + :prompt "Destination folder: " + :default *refile-default-destination*)))) + +(defcommand "Headers Refile Message" (p) + "Refile the current message. + When in a headers buffer, refiles the message on the current line, and when + in a message buffer, refiles that message, prompting for a destination + folder." + "When in a headers buffer, refiles the message on the current line, and when + in a message buffer, refiles that message, prompting for a destination + folder." + (declare (ignore p)) + (let ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (refile-message (headers-info-folder hinfo) cur-msg + (prompt-for-folder + :must-exist nil + :prompt "Destination folder: " + :default *refile-default-destination*)))) + (minfo + (refile-message + (message-info-folder minfo) (message-info-msgs minfo) + (prompt-for-folder :must-exist nil + :prompt "Destination folder: " + :default *refile-default-destination*)) + (message "Message refiled.")) + (t + (editor-error "Not in a headers or message buffer."))))) + +;;; REFILE-MESSAGE refiles msg from src-folder to dst-folder. If dst-buffer +;;; doesn't exist, the user is prompted for creating it. All headers buffers +;;; concerning src-folder are updated. When msg is a list, we did a general +;;; message prompt, and we cannot know which headers lines to delete. +;;; +(defun refile-message (src-folder msg dst-folder) + (unless (folder-existsp dst-folder) + (cond ((prompt-for-y-or-n + :prompt "Destination folder doesn't exist. Create it? " + :default t :default-string "Y") + (create-folder dst-folder)) + (t (editor-error "Not refiling message.")))) + (mh "refile" `(,@(if (listp msg) msg (list msg)) + "-src" ,src-folder ,dst-folder)) + (setf *refile-default-destination* (strip-folder-name dst-folder)) + (if (listp msg) + (do-headers-buffers (hbuf src-folder hinfo) + (do-headers-lines (hbuf :line-var line :mark-var hmark) + (when (member (line-message-id line) msg :test #'string=) + (delete-headers-buffer-line hinfo hmark)))) + (do-headers-buffers (hbuf src-folder hinfo) + (with-headers-mark (hmark hbuf msg) + (delete-headers-buffer-line hinfo hmark))))) + + + + +;;;; Miscellaneous commands. + +(defcommand "Mark Message" (p) + "Prompts for a folder, message, and sequence. By default the message is + added, but if an argument is supplied, the message is deleted. When in + a headers buffer or message buffer, only a sequence is prompted for." + "Prompts for a folder, message, and sequence. By default the message is + added, but if an argument is supplied, the message is deleted. When in + a headers buffer or message buffer, only a sequence is prompted for." + (let* ((hinfo (value headers-information)) + (minfo (value message-information))) + (cond (hinfo + (multiple-value-bind (cur-msg cur-mark) + (headers-current-message hinfo) + (unless cur-msg (editor-error "Not on a header line.")) + (delete-mark cur-mark) + (let ((seq-name (prompt-for-string :prompt "Sequence name: " + :trim t))) + (declare (simple-string seq-name)) + (when (string= "" seq-name) + (editor-error "Sequence name cannot be empty.")) + (mark-one-message (headers-info-folder hinfo) + cur-msg seq-name (if p :delete :add))))) + (minfo + (let ((msgs (message-info-msgs minfo)) + (seq-name (prompt-for-string :prompt "Sequence name: " + :trim t))) + (declare (simple-string seq-name)) + (when (string= "" seq-name) + (editor-error "Sequence name cannot be empty.")) + (mark-one-message (message-info-folder minfo) + (if (consp msgs) (car msgs) msgs) + seq-name (if p :delete :add)))) + (t + (let ((folder (prompt-for-folder)) + (seq-name (prompt-for-string :prompt "Sequence name: " + :trim t))) + (declare (simple-string seq-name)) + (when (string= "" seq-name) + (editor-error "Sequence name cannot be empty.")) + (mh "mark" `(,folder ,@(prompt-for-message :folder folder) + "-sequence" ,seq-name + ,(if p "-delete" "-add")))))))) + + +(defcommand "List Mail Buffers" (p) + "Show a list of all mail associated buffers. + If the buffer has an associated message buffer, it is displayed to the right + of the buffer name. If there is no message buffer, but the buffer is + associated with a headers buffer, then it is displayed. If the buffer is + modified then a * is displayed before the name." + "Display the names of all buffers in a with-random-typeout window." + (declare (ignore p)) + (let ((buffers nil)) + (declare (list buffers)) + (do-strings (n b *buffer-names*) + (declare (ignore n)) + (unless (eq b *echo-area-buffer*) + (cond ((hemlock-bound-p 'message-buffer :buffer b) + ;; Catches draft buffers associated with message buffers first. + (push (cons b (variable-value 'message-buffer :buffer b)) + buffers)) + ((hemlock-bound-p 'headers-buffer :buffer b) + ;; Then draft or message buffers associated with headers buffers. + (push (cons b (variable-value 'headers-buffer :buffer b)) + buffers)) + ((or (hemlock-bound-p 'draft-information :buffer b) + (hemlock-bound-p 'message-information :buffer b) + (hemlock-bound-p 'headers-information :buffer b)) + (push b buffers))))) + (with-pop-up-display (s :height (length buffers)) + (dolist (ele (nreverse buffers)) + (let* ((association (if (consp ele) (cdr ele))) + (b (if association (car ele) ele)) + (buffer-pathname (buffer-pathname b)) + (buffer-name (buffer-name b))) + (write-char (if (buffer-modified b) #\* #\space) s) + (if buffer-pathname + (format s "~A ~A~:[~;~50T~:*~A~]~%" + (file-namestring buffer-pathname) + (directory-namestring buffer-pathname) + (if association (buffer-name association))) + (format s "~A~:[~;~50T~:*~A~]~%" + buffer-name + (if association (buffer-name association))))))))) + + +(defcommand "Message Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Message")) + +(defcommand "Headers Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Headers")) + +(defcommand "Draft Help" (p) + "Show this help." + "Show this help." + (declare (ignore p)) + (describe-mode-command nil "Draft")) + + + + +;;;; Prompting. + +;;; Folder prompting. +;;; + +(defun prompt-for-folder (&key (must-exist t) (prompt "MH Folder: ") + (default (mh-current-folder))) + "Prompts for a folder, using MH's idea of the current folder as a default. + The result will have a leading + in the name." + (check-folder-name-table) + (let ((folder (prompt-for-keyword (list *folder-name-table*) + :must-exist must-exist :prompt prompt + :default default :default-string default + :help "Enter folder name."))) + (declare (simple-string folder)) + (when (string= folder "") (editor-error "Must supply folder!")) + (let ((name (coerce-folder-name folder))) + (when (and must-exist (not (folder-existsp name))) + (editor-error "Folder does not exist -- ~S." name)) + name))) + +(defun coerce-folder-name (folder) + (if (char= (schar folder 0) #\+) + folder + (concatenate 'simple-string "+" folder))) + +(defun strip-folder-name (folder) + (if (char= (schar folder 0) #\+) + (subseq folder 1) + folder)) + + +;;; Message prompting. +;;; + +(defun prompt-for-message (&key (folder (mh-current-folder)) + (prompt "MH messages: ") + messages) + "Prompts for a message spec, using messages as a default. If messages is + not supplied, then the current message for folder is used. The result is + a list of strings which are the message ids, intervals, and/or sequence + names the user entered." + (let* ((cur-msg (cond ((not messages) (mh-current-message folder)) + ((stringp messages) messages) + ((consp messages) + (if (= (length (the list messages)) 1) + (car messages) + (format nil "~{~A~^ ~}" messages)))))) + (breakup-message-spec (prompt-for-string :prompt prompt + :default cur-msg + :default-string cur-msg + :trim t + :help "Enter MH message id(s).")))) + +(defun breakup-message-spec (msgs) + (declare (simple-string msgs)) + (let ((start 0) + (result nil)) + (loop + (let ((end (position #\space msgs :start start :test #'char=))) + (unless end + (return (if (zerop start) + (list msgs) + (nreverse (cons (subseq msgs start) result))))) + (push (subseq msgs start end) result) + (setf start (1+ end)))))) + + +;;; PICK expression prompting. +;;; + +(defhvar "MH Lisp Expression" + "When this is set (the default), MH expression prompts are read in a Lisp + syntax. Otherwise, the input is as if it had been entered on a shell + command line." + :value t) + +;;; This is dynamically bound to nil for argument processing routines. +;;; +(defvar *pick-expression-strings* nil) + +(defun prompt-for-pick-expression () + "Prompts for an MH PICK-like expression that is converted to a list of + strings suitable for EXT:RUN-PROGRAM. As a second value, the user's + expression is as typed in is returned." + (let ((exp (prompt-for-string :prompt "MH expression: " + :help "Expression to PICK over mail messages." + :trim t)) + (*pick-expression-strings* nil)) + (if (value mh-lisp-expression) + (let ((exp (let ((*package* *keyword-package*)) + (read-from-string exp)))) + (if exp + (if (consp exp) + (lisp-to-pick-expression exp) + (editor-error "Lisp PICK expressions cannot be atomic.")))) + (expand-mh-pick-spec exp)) + (values (nreverse *pick-expression-strings*) + exp))) + +(defun lisp-to-pick-expression (exp) + (ecase (car exp) + (:and (lpe-and/or exp "-and")) + (:or (lpe-and/or exp "-or")) + (:not (push "-not" *pick-expression-strings*) + (let ((nexp (cadr exp))) + (unless (consp nexp) (editor-error "Bad expression -- ~S" nexp)) + (lisp-to-pick-expression nexp))) + + (:cc (lpe-output-and-go exp "-cc")) + (:date (lpe-output-and-go exp "-date")) + (:from (lpe-output-and-go exp "-from")) + (:search (lpe-output-and-go exp "-search")) + (:subject (lpe-output-and-go exp "-subject")) + (:to (lpe-output-and-go exp "-to")) + (:-- (lpe-output-and-go (cdr exp) + (concatenate 'simple-string + "--" (string (cadr exp))))) + + (:before (lpe-after-and-before exp "-before")) + (:after (lpe-after-and-before exp "-after")) + (:datefield (lpe-output-and-go exp "-datefield")))) + +(defun lpe-after-and-before (exp op) + (let ((operand (cadr exp))) + (when (numberp operand) + (setf (cadr exp) + (if (plusp operand) + (number-string (- operand)) + (number-string operand))))) + (lpe-output-and-go exp op)) + +(defun lpe-output-and-go (exp op) + (push op *pick-expression-strings*) + (let ((operand (cadr exp))) + (etypecase operand + (string (push operand *pick-expression-strings*)) + (symbol (push (symbol-name operand) + *pick-expression-strings*))))) + +(defun lpe-and/or (exp op) + (push "-lbrace" *pick-expression-strings*) + (dolist (ele (cdr exp)) + (lisp-to-pick-expression ele) + (push op *pick-expression-strings*)) + (pop *pick-expression-strings*) ;Clear the extra "-op" arg. + (push "-rbrace" *pick-expression-strings*)) + +;;; EXPAND-MH-PICK-SPEC takes a string of "words" assumed to be separated +;;; by single spaces. If a "word" starts with a quotation mark, then +;;; everything is grabbed up to the next one and used as a single word. +;;; Currently, this does not worry about extra spaces (or tabs) between +;;; "words". +;;; +(defun expand-mh-pick-spec (spec) + (declare (simple-string spec)) + (let ((start 0)) + (loop + (let ((end (position #\space spec :start start :test #'char=))) + (unless end + (if (zerop start) + (setf *pick-expression-strings* (list spec)) + (push (subseq spec start) *pick-expression-strings*)) + (return)) + (cond ((char= #\" (schar spec start)) + (setf end (position #\" spec :start (1+ start) :test #'char=)) + (unless end (editor-error "Bad quoting syntax.")) + (push (subseq spec (1+ start) end) *pick-expression-strings*) + (setf start (+ end 2))) + (t (push (subseq spec start end) *pick-expression-strings*) + (setf start (1+ end)))))))) + + +;;; Password prompting. +;;; + +(defun prompt-for-password (&optional (prompt "Password: ")) + "Prompts for password with prompt." + (let ((hi::*parse-verification-function* #'(lambda (string) (list string)))) + (let ((hi::*parse-prompt* prompt)) + (hi::display-prompt-nicely)) + (let ((start-window (current-window))) + (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*)) + (setf (current-window) *echo-area-window*) + (unwind-protect + (use-buffer *echo-area-buffer* + (let ((result ())) + (declare (list result)) + (loop + (let ((key-event (get-key-event *editor-input*))) + (ring-pop hi::*key-event-history*) + (cond ((eq key-event #k"return") + (return (prog1 (coerce (nreverse result) + 'simple-string) + (fill result nil)))) + ((or (eq key-event #k"control-u") + (eq key-event #k"control-U")) + (setf result nil)) + (t (push (ext:key-event-char key-event) result))))))) + (setf (current-window) start-window))))) + + + + + +;;;; Making mail buffers. + +;;; MAYBE-MAKE-MH-BUFFER looks up buffer with name, returning it if it exists +;;; after cleaning it up to a state "good as new". Currently, we don't +;;; believe it is possible to try to make two draft buffers with the same name +;;; since that would mean that composition, draft folder interaction, and +;;; draft folder current message didn't do what we expected -- or some user +;;; was modifying the draft folder in some evil way. +;;; +(defun maybe-make-mh-buffer (name use) + (let ((buf (getstring name *buffer-names*))) + (cond ((not buf) + (ecase use + (:headers (make-buffer name + :modes '("Headers") + :delete-hook '(cleanup-headers-buffer))) + + (:message + (make-buffer name :modes '("Message") + :modeline-fields + (value default-message-modeline-fields) + :delete-hook '(cleanup-message-buffer))) + + (:draft + (let ((buf (make-buffer + name :delete-hook '(cleanup-draft-buffer)))) + (setf (buffer-minor-mode buf "Draft") t) + buf)))) + ((hemlock-bound-p 'headers-information :buffer buf) + (setf (buffer-writable buf) t) + (delete-region (buffer-region buf)) + (cleanup-headers-buffer buf) + (delete-variable 'headers-information :buffer buf) + buf) + ((hemlock-bound-p 'message-information :buffer buf) + (setf (buffer-writable buf) t) + (delete-region (buffer-region buf)) + (cleanup-message-buffer buf) + (delete-variable 'message-information :buffer buf) + buf) + ((hemlock-bound-p 'draft-information :buffer buf) + (error "Attempt to create multiple draft buffers to same draft ~ + folder message -- ~S" + name))))) + + + +;;;; Message buffer modeline fields. + +(make-modeline-field + :name :deleted-message :width 2 + :function + #'(lambda (buffer window) + "Returns \"D \" when message in buffer is deleted." + (declare (ignore window)) + (let* ((minfo (variable-value 'message-information :buffer buffer)) + (hmark (message-info-headers-mark minfo))) + (cond ((not hmark) + (let ((msgs (message-info-msgs minfo))) + (if (and (value virtual-message-deletion) + (mh-sequence-member-p + (if (consp msgs) (car msgs) msgs) + (mh-sequence-list (message-info-folder minfo) + "hemlockdeleted"))) + "D " + ""))) + ((line-message-deleted (mark-line hmark)) + "D ") + (t ""))))) + +(make-modeline-field + :name :replied-to-message :width 1 + :function + #'(lambda (buffer window) + "Returns \"A\" when message in buffer is deleted." + (declare (ignore window)) + (let* ((minfo (variable-value 'message-information :buffer buffer)) + (hmark (message-info-headers-mark minfo))) + (cond ((not hmark) + ;; Could do something nasty here to figure out the right value. + "") + (t + (mark-to-note-replied-msg hmark) + (if (char= (next-character hmark) #\A) + "A" + "")))))) + +;;; MARK-TO-NOTE-REPLIED-MSG moves the headers-buffer mark to a line position +;;; suitable for checking or setting the next character with respect to noting +;;; that a message has been replied to. +;;; +(defun mark-to-note-replied-msg (hmark) + (line-start hmark) + (find-attribute hmark :digit) + (find-attribute hmark :digit #'zerop) + (character-offset hmark 1)) + + +(defhvar "Default Message Modeline Fields" + "This is the default list of modeline-field objects for message buffers." + :value + (list (modeline-field :hemlock-literal) (modeline-field :package) + (modeline-field :modes) (modeline-field :buffer-name) + (modeline-field :replied-to-message) (modeline-field :deleted-message) + (modeline-field :buffer-pathname) (modeline-field :modifiedp))) + + + + +;;;; MH interface. + +;;; Running an MH utility. +;;; + +(defhvar "MH Utility Pathname" + "MH utility names are merged with this. The default is + \"/usr/misc/.mh/bin/\"." + :value (pathname "/usr/misc/.mh/bin/")) + +(defvar *signal-mh-errors* t + "This is the default value for whether MH signals errors. It is useful to + bind this to nil when using PICK-MESSAGES with the \"Incorporate New Mail + Hook\".") + +(defvar *mh-error-output* (make-string-output-stream)) + +(defun mh (utility args &key (errorp *signal-mh-errors*) environment) + "Runs the MH utility with the list of args (suitable for EXT:RUN-PROGRAM), + outputting to *standard-output*. Environment is a list of strings + appended with ext:*environment-list*. This returns t, unless there is + an error. When errorp, this reports any MH errors in the echo area as + an editor error, and this does not return; otherwise, nil and the error + output from the MH utility are returned." + (fresh-line) + (let* ((utility + (namestring + (or (probe-file (merge-pathnames utility + (value mh-utility-pathname))) + utility))) + (proc (ext:run-program + utility args + :output *standard-output* + :error *mh-error-output* + :env (append environment ext:*environment-list*)))) + (fresh-line) + (ext:process-close proc) + (cond ((zerop (ext:process-exit-code proc)) + (values t nil)) + (errorp + (editor-error "MH Error -- ~A" + (get-output-stream-string *mh-error-output*))) + (t (values nil (get-output-stream-string *mh-error-output*)))))) + + + +;;; Draft folder name and pathname. +;;; + +(defun mh-draft-folder () + (let ((drafts (mh-profile-component "draft-folder"))) + (unless drafts + (error "There must be a draft-folder component in your profile.")) + drafts)) + +(defun mh-draft-folder-pathname () + "Returns the pathname of the MH draft folder directory." + (let ((drafts (mh-profile-component "draft-folder"))) + (unless drafts + (error "There must be a draft-folder component in your profile.")) + (merge-relative-pathnames drafts (mh-directory-pathname)))) + + +;;; Current folder name. +;;; + +(defun mh-current-folder () + "Returns the current MH folder from the context file." + (mh-profile-component "current-folder" (mh-context-pathname))) + + +;;; Current message name. +;;; + +(defun mh-current-message (folder) + "Returns the current MH message from the folder's sequence file." + (declare (simple-string folder)) + (let ((folder (strip-folder-name folder))) + (mh-profile-component + "cur" + (merge-pathnames ".mh_sequences" + (merge-relative-pathnames folder + (mh-directory-pathname)))))) + + +;;; Context pathname. +;;; + +(defvar *mh-context-pathname* nil) + +(defun mh-context-pathname () + "Returns the pathname of the MH context file." + (or *mh-context-pathname* + (setf *mh-context-pathname* + (merge-pathnames (or (mh-profile-component "context") "context") + (mh-directory-pathname))))) + + +;;; MH directory pathname. +;;; + +(defvar *mh-directory-pathname* nil) + +;;; MH-DIRECTORY-PATHNAME fetches the "path" MH component and bashes it +;;; appropriately to get an absolute directory pathname. +;;; +(defun mh-directory-pathname () + "Returns the pathname of the MH directory." + (if *mh-directory-pathname* + *mh-directory-pathname* + (let ((path (mh-profile-component "path"))) + (unless path (error "MH profile does not contain a Path component.")) + (setf *mh-directory-pathname* + (truename (merge-relative-pathnames path + (user-homedir-pathname))))))) + +;;; Profile components. +;;; + +(defun mh-profile-component (name &optional (pathname (mh-profile-pathname)) + (error-on-open t)) + "Returns the trimmed string value for the MH profile component name. If + the component is not present, nil is returned. This may be used on MH + context and sequence files as well due to their having the same format. + Error-on-open indicates that errors generated by OPEN should not be ignored, + which is the default. When opening a sequence file, it is better to supply + this as nil since the file may not exist or be readable in another user's + MH folder, and returning nil meaning the sequence could not be found is just + as useful." + (with-open-stream (s (if error-on-open + (open pathname) + (ignore-errors (open pathname)))) + (if s + (loop + (multiple-value-bind (line eofp) (read-line s nil :eof) + (when (eq line :eof) (return nil)) + (let ((colon (position #\: (the simple-string line) :test #'char=))) + (unless colon + (error "Bad record ~S in file ~S." line (namestring pathname))) + (when (string-equal name line :end2 colon) + (return (string-trim '(#\space #\tab) + (subseq line (1+ colon)))))) + (when eofp (return nil))))))) + + +;;; Profile pathname. +;;; + +(defvar *mh-profile-pathname* nil) + +(defun mh-profile-pathname () + "Returns the pathname of the MH profile." + (or *mh-profile-pathname* + (setf *mh-profile-pathname* + (merge-pathnames (or (cdr (assoc :mh ext:*environment-list*)) + ".mh_profile") + (truename (user-homedir-pathname)))))) + + + + +;;;; Sequence handling. + +(declaim (optimize (speed 2))); byte compile off + +(defun mark-one-message (folder msg sequence add-or-delete) + "Msg is added or deleted to the sequence named sequence in the folder's + \".mh_sequence\" file. Add-or-delete is either :add or :delete." + (let ((seq-list (mh-sequence-list folder sequence))) + (ecase add-or-delete + (:add + (write-mh-sequence folder sequence (mh-sequence-insert msg seq-list))) + (:delete + (when (mh-sequence-member-p msg seq-list) + (write-mh-sequence folder sequence + (mh-sequence-delete msg seq-list))))))) + + +(defun mh-sequence-list (folder name) + "Returns a list representing the messages and ranges of id's for the + sequence name in folder from the \".mh_sequences\" file. A second value + is returned indicating whether the sequence was found or not." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (seq-string (mh-profile-component + name + (merge-pathnames ".mh_sequences" + (merge-relative-pathnames + folder (mh-directory-pathname))) + nil))) + (if (not seq-string) + (values nil nil) + (let ((length (length (the simple-string seq-string))) + (result ()) + (intervalp nil) + (start 0)) + (declare (fixnum length start)) + (loop + (multiple-value-bind (msg index) + (parse-integer seq-string + :start start :end length + :junk-allowed t) + (unless msg (return)) + (cond ((or (= index length) + (char/= (schar seq-string index) #\-)) + (if intervalp + (setf (cdar result) msg) + (push (cons msg msg) result)) + (setf intervalp nil) + (setf start index)) + (t + (push (cons msg nil) result) + (setf intervalp t) + (setf start (1+ index))))) + (when (>= start length) (return))) + (values (nreverse result) t))))) + +(defun write-mh-sequence (folder name seq-list) + "Writes seq-list to folder's \".mh_sequences\" file. If seq-list is nil, + the sequence is removed from the file." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (input (merge-pathnames ".mh_sequences" + (merge-relative-pathnames + folder (mh-directory-pathname)))) + (input-dir (pathname (directory-namestring input))) + (output (loop (let* ((sym (gensym)) + (f (merge-pathnames + (format nil "sequence-file-~A.tmp" sym) + input-dir))) + (unless (probe-file f) (return f))))) + (found nil)) + (cond ((not (hemlock-ext:file-writable output)) + (loud-message "Cannot write sequence temp file ~A.~%~ + Aborting output of ~S sequence." + name (namestring output))) + (t + (with-open-file (in input) + (with-open-file (out output :direction :output) + (loop + (multiple-value-bind (line eofp) (read-line in nil :eof) + (when (eq line :eof) + (return nil)) + (let ((colon (position #\: (the simple-string line) + :test #'char=))) + (unless colon + (error "Bad record ~S in file ~S." + line (namestring input))) + (cond ((and (not found) (string-equal name line + :end2 colon)) + (sub-write-mh-sequence + out (subseq line 0 colon) seq-list) + (setf found t)) + (t (write-line line out)))) + (when eofp (return)))) + (unless found + (fresh-line out) + (sub-write-mh-sequence out name seq-list)))) + (hacking-rename-file output input))))) + +(defun sub-write-mh-sequence (stream name seq-list) + (when seq-list + (write-string name stream) + (write-char #\: stream) + (let ((*print-base* 10)) + (dolist (range seq-list) + (write-char #\space stream) + (let ((low (car range)) + (high (cdr range))) + (declare (fixnum low high)) + (cond ((= low high) + (prin1 low stream)) + (t (prin1 low stream) + (write-char #\- stream) + (prin1 high stream)))))) + (terpri stream))) + + +;;; MH-SEQUENCE-< keeps SORT from consing rest args when FUNCALL'ing #'<. +;;; +(defun mh-sequence-< (x y) + (< x y)) + +(defun mh-sequence-insert (item seq-list) + "Inserts item into an mh sequence list. Item can be a string (\"23\"), + number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." + (let ((range (typecase item + (string (let ((id (parse-integer item))) + (cons id id))) + (cons item) + (number (cons item item))))) + (cond (seq-list + (setf seq-list (sort (cons range seq-list) + #'mh-sequence-< :key #'car)) + (coelesce-mh-sequence-ranges seq-list)) + (t (list range))))) + +(defun coelesce-mh-sequence-ranges (seq-list) + (when seq-list + (let* ((current seq-list) + (next (cdr seq-list)) + (current-range (car current)) + (current-end (cdr current-range))) + (declare (fixnum current-end)) + (loop + (unless next + (setf (cdr current-range) current-end) + (setf (cdr current) nil) + (return)) + (let* ((next-range (car next)) + (next-start (car next-range)) + (next-end (cdr next-range))) + (declare (fixnum next-start next-end)) + (cond ((<= (1- next-start) current-end) + ;; + ;; Extend the current range since the next one overlaps. + (when (> next-end current-end) + (setf current-end next-end))) + (t + ;; + ;; Update the current range since the next one doesn't overlap. + (setf (cdr current-range) current-end) + ;; + ;; Make the next range succeed current. Then make it current. + (setf (cdr current) next) + (setf current next) + (setf current-range next-range) + (setf current-end next-end)))) + (setf next (cdr next)))) + seq-list)) + + +(defun mh-sequence-delete (item seq-list) + "Inserts item into an mh sequence list. Item can be a string (\"23\"), + number (23), or a cons of two numbers ((23 . 23) or (3 . 5))." + (let ((range (typecase item + (string (let ((id (parse-integer item))) + (cons id id))) + (cons item) + (number (cons item item))))) + (when seq-list + (do ((id (car range) (1+ id)) + (end (cdr range))) + ((> id end)) + (setf seq-list (sub-mh-sequence-delete id seq-list))) + seq-list))) + +(defun sub-mh-sequence-delete (id seq-list) + (do ((prev nil seq) + (seq seq-list (cdr seq))) + ((null seq)) + (let* ((range (car seq)) + (low (car range)) + (high (cdr range))) + (cond ((> id high)) + ((< id low) + (return)) + ((= id low) + (cond ((/= low high) + (setf (car range) (1+ id))) + (prev + (setf (cdr prev) (cdr seq))) + (t (setf seq-list (cdr seq-list)))) + (return)) + ((= id high) + (setf (cdr range) (1- id)) + (return)) + ((< low id high) + (setf (cdr range) (1- id)) + (setf (cdr seq) (cons (cons (1+ id) high) (cdr seq))) + (return))))) + seq-list) + + +(defun mh-sequence-member-p (item seq-list) + "Returns to or nil whether item is in the mh sequence list. Item can be a + string (\"23\") or a number (23)." + (let ((id (typecase item + (string (parse-integer item)) + (number item)))) + (dolist (range seq-list nil) + (let ((low (car range)) + (high (cdr range))) + (when (<= low id high) (return t)))))) + + +(defun mh-sequence-strings (seq-list) + "Returns a list of strings representing the ranges and messages id's in + seq-list." + (let ((result nil)) + (dolist (range seq-list) + (let ((low (car range)) + (high (cdr range))) + (if (= low high) + (push (number-string low) result) + (push (format nil "~D-~D" low high) result)))) + (nreverse result))) + +(declaim (optimize (speed 0))); byte compile again. + + +;;;; CMU Common Lisp support. + +;;; HACKING-RENAME-FILE renames old to new. This is used instead of Common +;;; Lisp's RENAME-FILE because it merges new pathname with old pathname, +;;; which loses when old has a name and type, and new has only a type (a +;;; Unix-oid "dot" file). +;;; +(defun hacking-rename-file (old new) + (let ((ses-name1 (namestring old)) + (ses-name2 (namestring new))) + (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) + (unless res + (error "Failed to rename ~A to ~A: ~A." + ses-name1 ses-name2 (unix:get-unix-error-msg err)))))) + + +;;; Folder existence and creation. +;;; + +(defun folder-existsp (folder) + "Returns t if the directory for folder exists. Folder is a simple-string + specifying a folder name relative to the MH mail directoy." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (pathname (merge-relative-pathnames folder (mh-directory-pathname))) + (pf (probe-file pathname))) + (and pf + (null (pathname-name pf)) + (null (pathname-type pf))))) + +(defun create-folder (folder) + "Creates folder directory with default protection #o711 but considers the + MH profile for the \"Folder-Protect\" component. Folder is a simple-string + specifying a folder name relative to the MH mail directory." + (declare (simple-string folder)) + (let* ((folder (strip-folder-name folder)) + (pathname (merge-relative-pathnames folder (mh-directory-pathname))) + (ses-name (namestring pathname)) + (length-1 (1- (length ses-name))) + (name (if (= (position #\/ ses-name :test #'char= :from-end t) + length-1) + (subseq ses-name 0 (1- (length ses-name))) + ses-name)) + (protection (mh-profile-component "folder-protect"))) + (when protection + (setf protection + (parse-integer protection :radix 8 :junk-allowed t))) + (multiple-value-bind (winp err) + (unix:unix-mkdir name (or protection #o711)) + (unless winp + (error "Couldn't make directory ~S: ~A" + name + (unix:get-unix-error-msg err))) + (check-folder-name-table) + (setf (getstring folder *folder-name-table*) t)))) + + +;;; Checking for mail. +;;; + +(defvar *mailbox* nil) + +(defun new-mail-p () + (unless *mailbox* + (setf *mailbox* + (probe-file (or (cdr (assoc :mail ext:*environment-list*)) + (cdr (assoc :maildrop ext:*environment-list*)) + (mh-profile-component "MailDrop") + (merge-pathnames + (cdr (assoc :user ext:*environment-list*)) + "/usr/spool/mail/"))))) + (when *mailbox* + (multiple-value-bind (success dev ino mode nlink uid gid rdev size + atime) + (unix:unix-stat (namestring *mailbox*)) + (declare (ignore dev ino nlink uid gid rdev atime)) + (and success + (plusp (logand unix:s-ifreg mode)) + (not (zerop size)))))) + + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/netnews.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/netnews.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/netnews.lisp (revision 8058) @@ -0,0 +1,2407 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Blaine Burks +;;; +;;; This file implements the reading of bulletin boards from within Hemlock +;;; via a known NNTP server. Something should probably be done so that +;;; when the server is down Hemlock doesn't hang as I suspect it will. +;;; +;;; Warning: Throughout this file, it may appear I should have bound +;;; the nn-info-stream and nn-info-header-stream slots instead +;;; of making multiple structure accesses. This was done on +;;; purpose because we don't find out if NNTP timed us out until +;;; we make an attempt to execute another command. This code +;;; recovers by resetting the header-stream and stream slots in +;;; the nn-info structure to new streams. If the structure +;;; access were not made again and NNTP had timed us out, we +;;; would be making requests on a defunct stream. +;;; + +(in-package :hemlock) + + + + +;;;; Netnews data structures. + +(defparameter default-netnews-headers-length 1000 + "How long the header-cache and message-ids arrays should be made on startup.") + +(defstruct (netnews-info + (:conc-name nn-info-) + (:print-function + (lambda (nn s d) + (declare (ignore nn d)) + (write-string "#" s)))) + (updatep (ext:required-argument) :type (or null t)) + (from-end-p nil :type (or null t)) + ;; + ;; The string name of the current group. + (current (ext:required-argument) :type simple-string) + ;; + ;; The number of the latest message read in the current group. + (latest nil :type (or null fixnum)) + ;; + ;; The cache of header info for the current group. Each element contains + ;; an association list of header fields to contents of those fields. Indexed + ;; by id offset by the first message in the group. + (header-cache nil :type (or null simple-vector)) + ;; + ;; The number of HEAD requests currently waiting on the header stream. + (batch-count nil :type (or null fixnum)) + ;; + ;; The list of newsgroups to read. + (groups (ext:required-argument) :type cons) + ;; + ;; A vector of message ids indexed by buffer-line for this headers buffer. + (message-ids nil :type (or null vector)) + ;; + ;; Where to insert the next batch of headers. + mark + ;; + ;; The message buffer used to view article bodies. + buffer + ;; + ;; A list of message buffers that have been marked as undeletable by the user. + (other-buffers nil :type (or null cons)) + ;; + ;; The window used to display buffer when \"Netnews Read Style\" is :multiple. + message-window + ;; + ;; The window used to display headers when \"Netnews Read Style\" is + ;; :multiple. + headers-window + ;; + ;; How long the message-ids and header-cache arrays are. Reuse this array, + ;; but don't break if there are more messages than we can handle. + (array-length default-netnews-headers-length :type fixnum) + ;; + ;; The id of the first message in the current group. + (first nil :type (or null fixnum)) + ;; + ;; The id of the last message in the current-group. + (last nil :type (or null fixnum)) + ;; + ;; Article number of the first visible header. + (first-visible nil :type (or null fixnum)) + ;; + ;; Article number of the last visible header. + (last-visible nil :type (or null fixnum)) + ;; + ;; Number of the message that is currently displayed in buffer. Initialize + ;; to -1 so I don't have to constantly check for the nullness of it. + (current-displayed-message -1 :type (or null fixnum)) + ;; + ;; T if the last batch of headers is waiting on the header stream. + ;; This is needed so NN-WRITE-HEADERS-TO-MARK can set the messages-waiting + ;; slot to nil. + (last-batch-p nil :type (or null t)) + ;; + ;; T if there are more headers in the current group. Nil otherwise. + (messages-waiting nil :type (or null t)) + ;; + ;; The stream on which we request headers from NNTP. + header-stream + ;; + ;; The stream on which we request everything but headers from NNTP. + stream) + +(defmode "News-Headers" :major-p t) + + + + +;;;; The netnews-message-info and post-info structures. + +(defstruct (netnews-message-info + (:conc-name nm-info-) + (:print-function + (lambda (nn s d) + (declare (ignore nn d)) + (write-string "#" s)))) + ;; The headers buffer (if there is one) associated with this message buffer. + headers-buffer + ;; The draft buffer (if there is one) associated with this message buffer. + draft-buffer + ;; The post buffer (if there is one) associated with this message buffer. + post-buffer + ;; This is need because we want to display what message this is in the + ;; modeline field of a message buffer. + (message-number nil :type (or null fixnum)) + ;; Set to T when we do not want to reuse this buffer. + keep-p) + +(defstruct (post-info + (:print-function + (lambda (nn s d) + (declare (ignore nn d)) + (write-string "#" s)))) + ;; The NNTP stream over which to send this post. + stream + ;; When replying in another window, the reply window. + reply-window + ;; When replying in another window, the message window. + message-window + ;; The message buffer associated with this post. + message-buffer + ;; The Headers buffer associated with this post. + headers-buffer) + + + + +;;;; Command Level Implementation of "News-Headers" mode. + +(defhvar "Netnews Database File" + "This value is merged with your home directory to get a path to your netnews + pointers file." + :value ".hemlock-netnews") + +(defhvar "Netnews Read Style" + "How you like to read netnews. A value of :single will cause netnews + mode to use a single window for headers and messages, and a value of + :multiple will cause the current window to be split so that Headers take + up \"Netnews Headers Proportion\" of what was the current window, and a + message bodies buffer the remaining portion. Changing the value of this + variable dynamically affects netnews reading." + :value :multiple) + +(unless (modeline-field :netnews-message) + (make-modeline-field + :name :netnews-message + :width 14 + :function #'(lambda (buffer window) + (declare (ignore window)) + (let* ((nm-info (variable-value 'netnews-message-info + :buffer buffer)) + (nn-info (variable-value 'netnews-info + :buffer (nm-info-headers-buffer + nm-info)))) + (format nil "~D of ~D" + (nm-info-message-number nm-info) + (1+ (- (nn-info-last nn-info) + (nn-info-first nn-info)))))))) + +(unless (modeline-field :netnews-header-info) + (make-modeline-field + :name :netnews-header-info + :width 24 + :function + #'(lambda (buffer window) + (declare (ignore window)) + (let ((nn-info (variable-value 'netnews-info :buffer buffer))) + (format nil "~D before, ~D after" + (- (nn-info-first-visible nn-info) (nn-info-first nn-info)) + (- (nn-info-last nn-info) (nn-info-last-visible nn-info))))))) + +(defvar *nn-headers-buffer* nil + "If \"Netnews\" was invoked without an argument an not exited, this + holds the headers buffer for reading netnews.") + +(defvar *netnews-kill-strings* nil) + +(defhvar "Netnews Kill File" + "This value is merged with your home directory to get the pathname of + your netnews kill file. If any of the strings in this file (one per + line) appear in a subject header while reading netnews, they will have a + \"K\" in front of them, and \"Netnews Next Line\" and \"Netnews Previous + Line\" will never land you on one. Use \"Next Line\" and \"Previous + Line\" to read Killed messages. Defaults to \".hemlock-kill\"." + :value ".hemlock-kill") + +(defhvar "Netnews New Group Style" + "Determines what happend when you read a group that you have never read + before. When :from-start, \"Netnews\" will read from the beginning of a + new group forward. When :from-end, the default, \"Netnews\" will read + from the end backward group. Otherwise this variable is a number + indicating that \"Netnews\" should start that many messages from the end + of the group and read forward from there." + :value :from-end) + +(defhvar "Netnews Start Over Threshold" + "If you have read a group before, and the number of new messages exceeds + this number, Hemlock asks whether you want to start reading from the end + of this group. The default is 300." + :value 300) + +(defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t)) + "Enter a headers buffer and read groups from \"Netnews Group File\". + With an argument prompts for a group and reads it." + "Enter a headers buffer and read groups from \"Netnews Group File\". + With an argument prompts for a group and reads it." + (cond + ((and *nn-headers-buffer* (not p) (not group-name)) + (change-to-buffer *nn-headers-buffer*)) + (t + (let* ((single-group (if p (prompt-for-string :prompt "Group to read: " + :help "Type the name of ~ + the group you want ~ + to scan." + :trim t))) + (groups (cond + (group-name (list group-name)) + (single-group (list single-group)) + (t + (let ((group-file (merge-pathnames + (value netnews-group-file) + (user-homedir-pathname)))) + (when (probe-file group-file) + (let ((res nil)) + (with-open-file (s group-file :direction :input) + (loop + (let ((group (read-line s nil nil))) + (unless group (return (nreverse res))) + (pushnew group res))))))))))) + (unless (or p groups) + (editor-error "No groups to read. See \"Netnews Group File\" and ~ + \"Netnews Browse\".")) + (when updatep (nn-assure-database-exists)) + (nn-parse-kill-file) + (multiple-value-bind (stream header-stream) (streams-for-nntp) + (multiple-value-bind + (buffer-name clashp) + (nn-unique-headers-name (car groups)) + (if (and (or p group-name) clashp) + (change-to-buffer (getstring clashp *buffer-names*)) + (let* ((buffer (make-buffer + buffer-name + :modes '("News-Headers") + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field + :netnews-header-info))) + :delete-hook + (list #'netnews-headers-delete-hook))) + (nn-info (make-netnews-info + :current (car groups) + :groups groups + :updatep updatep + :headers-window (current-window) + :mark (copy-mark (buffer-point buffer)) + :header-stream header-stream + :stream stream))) + (unless (or p group-name) (setf *nn-headers-buffer* buffer)) + (when (and clashp (not (or p group-name))) + (message "Buffer ~S also contains headers for ~A" + clashp (car groups))) + (defhvar "Netnews Info" + "A structure containing the current group, a list of + groups, a book-keeping mark, a stream we get headers on, + and the stream on which we request articles." + :buffer buffer + :value nn-info) + (setf (buffer-writable buffer) nil) + (defhvar "Netnews Browse Buffer" + "This variable is the associated \"News-Browse\" buffer + in a \"News-Headers\" buffer created from + \"News-Browse\" mode." + :buffer buffer + :value browse-buf) + (setup-group (car groups) nn-info buffer from-end-p))))))))) + + +(defun nn-parse-kill-file () + (let ((filename (merge-pathnames (value netnews-kill-file) + (user-homedir-pathname)))) + (when (probe-file filename) + (with-open-file (s filename :direction :input) + (loop + (let ((kill-string (read-line s nil nil))) + (unless kill-string (return)) + (pushnew kill-string *netnews-kill-strings*))))))) + +;;; NETNEWS-HEADERS-DELETE-HOOK closes the stream slots in netnews-info, +;;; deletes the bookkeeping mark into buffer, sets the headers slots of any +;;; associated post-info or netnews-message-info structures to nil so +;;; "Netnews Go To Headers Buffer" will not land you in a buffer that does +;;; not exist, and sets *nn-headers-buffer* to nil so next time we invoke +;;; "Netnews" it will start over. +;;; +(defun netnews-headers-delete-hook (buffer) + (let ((nn-info (variable-value 'netnews-info :buffer buffer))) + ;; Disassociate all message buffers. + ;; + (dolist (buf (nn-info-other-buffers nn-info)) + (setf (nm-info-headers-buffer (variable-value 'netnews-message-info + :buffer buf)) + nil)) + (let ((message-buffer (nn-info-buffer nn-info))) + (when message-buffer + (setf (nm-info-headers-buffer (variable-value 'netnews-message-info + :buffer message-buffer)) + nil))) + (close (nn-info-stream nn-info)) + (close (nn-info-header-stream nn-info)) + (delete-mark (nn-info-mark nn-info)) + (when (eq *nn-headers-buffer* buffer) + (setf *nn-headers-buffer* nil)))) + +(defun nn-unique-headers-name (group-name) + (let ((original-name (concatenate 'simple-string "Netnews " group-name))) + (if (getstring original-name *buffer-names*) + (let ((name nil) + (number 0)) + (loop + (setf name (format nil "Netnews ~A ~D" group-name (incf number))) + (unless (getstring name *buffer-names*) + (return (values name original-name))))) + (values original-name nil)))) + +;;; NN-ASSURE-DATABASE-EXISTS does just that. If the file determined by the +;;; value of "Netnews Database Filename" does not exist, then it gets +;;; created. +;;; +(defun nn-assure-database-exists () + (let ((filename (merge-pathnames (value netnews-database-file) + (user-homedir-pathname)))) + (unless (probe-file filename) + (message "Creating netnews database file.") + (close (open filename :direction :output :if-does-not-exist :create))))) + +(defhvar "Netnews Fetch All Headers" + "When NIL, all netnews reading commands will fetch headers in batches for + increased efficiency. Any other value will cause these commands to fetch + all the headers. This will take a long time if there are a lot." + :value nil) + +(defcommand "Netnews Look at Newsgroup" (p) + "Prompts for the name of a newsgroup and reads it, regardless of what is + in and not modifying the \"Netnews Database File\"." + "Prompts for the name of a newsgroup and reads it, regardless of what is + in and not modifying the \"Netnews Database File\"." + (declare (ignore p)) + (netnews-command nil (prompt-for-string :prompt "Group to look at: " + :help "Type the name of ~ + the group you want ~ + to look at." + :trim t) + nil nil nil)) + +;;; SETUP-GROUP is the guts of this group reader. It sets up a headers +;;; buffer in buffer for group group-name. This consists of sending a group +;;; command to both the header-stream and normal stream and then getting the +;;; last message read in group-name from the database file and setting the +;;; appropriate slots in the nn-info structure. The first batch of messages +;;; is then requested and inserted, and room for message-ids is allocated. +;;; +(defun setup-group (group-name nn-info buffer &optional from-end-p) + ;; Do not bind stream or header-stream because if a timeout has occurred + ;; before these calls are invoked, they would be bogus. + ;; + (nntp-group group-name (nn-info-stream nn-info) + (nn-info-header-stream nn-info)) + (process-status-response (nn-info-stream nn-info) nn-info) + (let ((response (process-status-response (nn-info-header-stream nn-info) + nn-info))) + (cond ((not response) + (message "~A is not the name of a netnews group.~%" + (nn-info-current nn-info)) + (change-to-next-group nn-info buffer)) + (t + (multiple-value-bind (number first last) + (group-response-args response) + (declare (ignore first)) + (message "Setting up ~A" group-name) + ;; If nn-info-updatep is nil, then we fool ourselves into + ;; thinking we've never read this group before by making + ;; last-read nil. We determine first here because the first + ;; that NNTP gives us is way way out of line. + ;; + (let ((last-read (if (nn-info-updatep nn-info) + (nn-last-read-message-number group-name))) + (first (1+ (- last number)))) + ;; Make sure there is at least one new message in this group. + (cond + ((and last-read (= last-read last)) + (message "No new messages in ~A" group-name) + (setf (nn-info-latest nn-info) last) + (change-to-next-group nn-info buffer)) + ((zerop number) + (message "No messages AVAILABLE in ~A" group-name) + (setf (nn-info-latest nn-info) last) + (change-to-next-group nn-info buffer)) + (t + (let ((latest (if (and last-read (> last-read first)) + last-read + first))) + (if (or (and (eq (value netnews-new-group-style) :from-end) + (or (= latest first) + (and (> (- last latest) + (value + netnews-start-over-threshold)) + (prompt-for-y-or-n + :prompt + `("There are ~D new messages. ~ + Read from the end of this ~ + group? " ,(- last latest)) + :default "Y" + :default-string "Y" + :help "Y starts reading from the ~ + end. N starts reading where ~ + you left off many messages ~ + back.")))) + from-end-p) + (setf (nn-info-from-end-p nn-info) t)) + + (cond ((nn-info-from-end-p nn-info) + (setf (nn-info-first-visible nn-info) nil) + (setf (nn-info-last-visible nn-info) last)) + (t + ; (setf (nn-info-first-visible nn-info) latest) + (setf (nn-info-first-visible nn-info) (1+ latest)) + (setf (nn-info-last-visible nn-info) nil))) + (setf (nn-info-first nn-info) first) + (setf (nn-info-last nn-info) last) + (setf (nn-info-latest nn-info) latest)) + ;; + ;; Request the batch before setting message-ids so they start + ;; coming before we need them. + (nn-request-next-batch nn-info + (value netnews-fetch-all-headers)) + (let ((message-ids (nn-info-message-ids nn-info)) + (header-cache (nn-info-header-cache nn-info)) + (length (1+ (- last first)))) + (multiple-value-setq + (message-ids header-cache) + (cond ((> length (nn-info-array-length nn-info)) + (setf (nn-info-array-length nn-info) length) + (values (make-array length :fill-pointer 0) + (make-array length + :initial-element nil))) + (message-ids + (setf (fill-pointer message-ids) 0) + (values message-ids header-cache)) + (t + (values (make-array (nn-info-array-length nn-info) + :fill-pointer 0) + (make-array (nn-info-array-length nn-info) + :initial-element nil))))) + (setf (nn-info-message-ids nn-info) message-ids) + (setf (nn-info-header-cache nn-info) header-cache)) + (nn-write-headers-to-mark nn-info buffer) + (change-to-buffer buffer))))))))) + +;;; NN-LAST-READ-MESSAGE-NUMBER reads the last read message in group-name +;;; from the value of "Netnews Database File". It is SETF'able and the +;;; SETF method is %SET-LAST-READ-MESSAGE-NUMBER. +;;; +(defun nn-last-read-message-number (group-name) + (with-open-file (s (merge-pathnames (value netnews-database-file) + (user-homedir-pathname)) + :direction :input :if-does-not-exist :error) + (loop + (let ((read-group-name (read-line s nil nil))) + (unless read-group-name (return nil)) + (when (string-equal read-group-name group-name) + (let ((last-read (read-line s nil nil))) + (if last-read + (return (parse-integer last-read)) + (error "Should have been a message number ~ + following ~S in database file." + group-name)))))))) + +(defun %set-nn-last-read-message-number (group-name new-value) + (with-open-file (s (merge-pathnames (value netnews-database-file) + (user-homedir-pathname)) + :direction :io :if-does-not-exist :error + :if-exists :overwrite) + (unless (loop + (let ((read-group-name (read-line s nil nil))) + (unless read-group-name (return nil)) + (when (string-equal read-group-name group-name) + ;; File descriptor streams do not do the right thing with + ;; :io/:overwrite streams, so work around it by setting it + ;; explicitly. + ;; + (file-position s (file-position s)) + ;; Justify the number so that if the number of digits in it + ;; changes, we won't overwrite the next group name. + ;; + (format s "~14D~%" new-value) + (return t)))) + (write-line group-name s) + (format s "~14D~%" new-value)))) + +(defsetf nn-last-read-message-number %set-nn-last-read-message-number) + +(defconstant nntp-eof ". +" + "NNTP marks the end of a textual response with this. NNTP also recognizes + this as the end of a post.") + +;;; This macro binds a variable to each successive line of input from NNTP +;;; and exits when it sees the NNTP end-of-file-marker, a period by itself on +;;; a line. +;;; +(defmacro with-input-from-nntp ((var stream) &body body) + "Body is executed with var bound to successive lines of input from nntp. + Exits at the end of a response, returning whatever the last execution of + Body returns, or nil if there was no input. + Take note: this is only to be used for textual responses. Status responses + are of an entirely different nature." + (let ((return-value (gensym))) + `(let ((,return-value nil) + (,var "")) + (declare (simple-string ,var)) + (loop + (setf ,var (read-line ,stream)) + (when (string= ,var nntp-eof) (return ,return-value)) + (setf ,return-value (progn ,@body)))))) + + +;;; Writing the date, from, and subject fields to a mark. + +(defhvar "Netnews Before Date Field Pad" + "How many spaces should be inserted before the date in Netnews. The default + is 1." + :value 1) + +(defhvar "Netnews Date Field Length" + "How long the date field should be in \"News-Headers\" buffers. The + default is 6" + :value 6) + +(defhvar "Netnews Line Field Length" + "How long the line field should be in \"News-Headers\" buffers. The + default is 3" + :value 3) + +(defhvar "Netnews From Field Length" + "How long the from field should be in \"News-Headers\" buffers. The + default is 20." + :value 20) + +(defhvar "Netnews Subject Field Length" + "How long the subject field should be in \"News-Headers\" buffers. The + default is 43." + :value 43) + +(defhvar "Netnews Field Padding" + "How many spaces should be left between the netnews date, from, lines, and + subject fields. The default is 2." + :value 2) + +;;; +(defconstant netnews-space-string + (make-string 70 :initial-element #\space)) +;;; +(defconstant missing-message (cons nil nil) + "Use this as a marker so nn-write-headers-to-mark doesn't try to insert + a message that is not really there.") + +;;; NN-CACHE-HEADER-INFO stashes all header information into an array for +;;; later use. +;;; +(defun nn-cache-header-info (nn-info howmany use-header-stream-p) + (let* ((cache (nn-info-header-cache nn-info)) + (message-ids (nn-info-message-ids nn-info)) + (stream (if use-header-stream-p + (nn-info-header-stream nn-info) + (nn-info-stream nn-info))) + (from-end-p (nn-info-from-end-p nn-info)) + (old-count 0)) + (declare (fixnum old-count)) + (when from-end-p + (setf old-count (length message-ids)) + (do ((i (length message-ids) (1- i))) + ((minusp i) nil) + (setf (aref message-ids (+ i howmany)) (aref message-ids i))) + (setf (fill-pointer message-ids) 0)) + (let ((missing-message-count 0) + (offset (nn-info-first nn-info))) + (dotimes (i howmany) + (let ((response (process-status-response stream))) + (if response + (let* ((id (head-response-args response)) + (index (- id offset))) + (vector-push id message-ids) + (setf (svref cache index) nil) + (with-input-from-nntp (string stream) + (let ((colonpos (position #\: string))) + (when colonpos + (push (cons (subseq string 0 colonpos) + (subseq string + (+ colonpos 2))) + (svref cache index)))))) + (incf missing-message-count)))) + (when from-end-p + (when (plusp missing-message-count) + (dotimes (i old-count) + (setf (aref message-ids (- (+ i howmany) missing-message-count)) + (aref message-ids (+ i howmany))))) + (setf (fill-pointer message-ids) + (- (+ old-count howmany) missing-message-count)))))) + +(defconstant netnews-field-na "NA" + "This string gets inserted when NNTP doesn't find a field.") + +(defconstant netnews-field-na-length (length netnews-field-na) + "The length of netnews-field-na") + +(defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p + out-of-order-p) + (let* ((howmany (nn-info-batch-count nn-info)) + (from-end-p (nn-info-from-end-p nn-info)) + (cache (nn-info-header-cache nn-info)) + (old-point (copy-mark (buffer-point buffer) (if from-end-p + :left-inserting + :right-inserting))) + (messages-waiting (nn-info-messages-waiting nn-info)) + (mark (nn-info-mark nn-info))) + (unless messages-waiting + (return-from nn-write-headers-to-mark nil)) + (if from-end-p + (buffer-start mark) + (buffer-end mark)) + (nn-cache-header-info nn-info howmany (not out-of-order-p)) + (with-writable-buffer (buffer) + (with-mark ((check-point mark :right-inserting)) + (macrolet ((mark-to-pos (mark pos) + `(insert-string ,mark netnews-space-string + 0 (- ,pos (mark-column ,mark)))) + (insert-field (mark field-string field-length) + `(if ,field-string + (insert-string ,mark ,field-string + 0 (min ,field-length + (1- (length ,field-string)))) + (insert-string ,mark netnews-field-na + 0 (min ,field-length + netnews-field-na-length))))) + (let* ((line-start (+ (value netnews-before-date-field-pad) + (value netnews-date-field-length) + (value netnews-field-padding))) + (from-start (+ line-start + (value netnews-line-field-length) + (value netnews-field-padding))) + (subject-start (+ from-start + (value netnews-from-field-length) + (value netnews-field-padding))) + (start (- messages-waiting (nn-info-first nn-info))) + (end (1- (+ start howmany)))) + (do ((i start (1+ i))) + ((> i end)) + (let ((assoc-list (svref cache i))) + (unless (null assoc-list) + (insert-string mark netnews-space-string + 0 (value netnews-before-date-field-pad)) + (let* ((date-field (cdr (assoc "date" assoc-list + :test #'string-equal))) + (universal-date (if date-field + (ext:parse-time date-field + :end (1- (length date-field)))))) + (insert-field + mark + (if universal-date + (string-capitalize + (format-universal-time nil universal-date + :style :government + :print-weekday nil)) + date-field) + (value netnews-date-field-length))) + (mark-to-pos mark line-start) + (insert-field mark (cdr (assoc "lines" assoc-list + :test #'string-equal)) + (value netnews-line-field-length)) + (mark-to-pos mark from-start) + (insert-field mark (cdr (assoc "from" assoc-list + :test #'string-equal)) + (value netnews-from-field-length)) + (mark-to-pos mark subject-start) + (insert-field mark (cdr (assoc "subject" assoc-list + :test #'string-equal)) + (value netnews-subject-field-length)) + (insert-character mark #\newline)))))) + (cond (out-of-order-p + (setf (nn-info-first-visible nn-info) messages-waiting)) + (t + (if (nn-info-from-end-p nn-info) + (setf (nn-info-first-visible nn-info) messages-waiting) + (setf (nn-info-last-visible nn-info) + (1- (+ messages-waiting howmany)))) + (if (nn-info-last-batch-p nn-info) + (setf (nn-info-messages-waiting nn-info) nil) + (nn-request-next-batch nn-info fetch-rest-p)))) + (when (mark= mark check-point) + (message "All messages in last batch were missing, getting more.")) + (move-mark (buffer-point buffer) old-point) + (delete-mark old-point))))) + +;;; NN-MAYBE-GET-MORE-HEADERS gets more headers if the point of the headers +;;; buffer is on an empty line and there are some. Returns whether it got more +;;; headers, i.e., if it is time to go on to the next group. +;;; +(defun nn-maybe-get-more-headers (nn-info) + (let ((headers-buffer (line-buffer (mark-line (nn-info-mark nn-info))))) + (when (empty-line-p (buffer-point headers-buffer)) + (cond ((and (nn-info-messages-waiting nn-info) + (not (nn-info-from-end-p nn-info))) + (nn-write-headers-to-mark nn-info headers-buffer) + t) + (t :go-on))))) + +(defhvar "Netnews Batch Count" + "Determines how many headers the Netnews facility will fetch at a time. + The default is 50." + :value 50) + +;;; NN-REQUEST-NEXT-BATCH requests the next batch of messages in a group. +;;; For safety, don't do anything if there is no next-batch start. +;;; +(defun nn-request-next-batch (nn-info &optional fetch-rest-p) + (if (nn-info-from-end-p nn-info) + (nn-request-backward nn-info fetch-rest-p) + (nn-request-forward nn-info fetch-rest-p))) + +(defun nn-request-forward (nn-info fetch-rest-p) + (let* ((last-visible (nn-info-last-visible nn-info)) + (last (nn-info-last nn-info)) + (batch-start (if last-visible + (1+ (nn-info-last-visible nn-info)) + (1+ (nn-info-latest nn-info)))) + (header-stream (nn-info-header-stream nn-info)) + (batch-end (if fetch-rest-p + last + (1- (+ batch-start (value netnews-batch-count)))))) + ;; If this is the last batch, adjust batch-end appropriately. + ;; + (when (>= batch-end last) + (setf batch-end last) + (setf (nn-info-last-batch-p nn-info) t)) + (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start))) + (setf (nn-info-messages-waiting nn-info) batch-start) + (nn-send-many-head-requests header-stream batch-start batch-end nil))) + +(defun nn-request-backward (nn-info fetch-rest-p + &optional (use-header-stream-p t)) + (let* ((first-visible (nn-info-first-visible nn-info)) + (batch-end (if first-visible + (1- (nn-info-first-visible nn-info)) + (nn-info-last nn-info))) + (stream (if use-header-stream-p + (nn-info-header-stream nn-info) + (nn-info-stream nn-info))) + (first (nn-info-first nn-info)) + (batch-start (if fetch-rest-p + first + (1+ (- batch-end (value netnews-batch-count)))))) + ;; If this is the last batch, adjust batch-end appropriately. + ;; + (when (<= batch-start first) + (setf batch-start first) + (setf (nn-info-last-batch-p nn-info) t)) + (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start))) + (setf (nn-info-messages-waiting nn-info) batch-start) + (nn-send-many-head-requests stream batch-start batch-end + (not use-header-stream-p)))) + +;;; NN-REQUEST-OUT-OF-ORDER is called when the user is reading a group normally +;;; and decides he wants to see some messages before the first one visible. +;;; To accomplish this without disrupting the normal flow of things, we fool +;;; ourselves into thinking we are reading the group from the end, remembering +;;; several slots that could be modified in requesting thesse messages. +;;; When we are done, return state to what it was for reading a group forward. +;;; +(defun nn-request-out-of-order (nn-info headers-buffer) + (let ((messages-waiting (nn-info-messages-waiting nn-info)) + (batch-count (nn-info-batch-count nn-info)) + (last-batch-p (nn-info-last-batch-p nn-info))) + (nn-request-backward nn-info nil nil) + (setf (nn-info-from-end-p nn-info) t) + (nn-write-headers-to-mark nn-info headers-buffer nil t) + (setf (nn-info-messages-waiting nn-info) messages-waiting) + (setf (nn-info-batch-count nn-info) batch-count) + (setf (nn-info-last-batch-p nn-info) last-batch-p) + (setf (nn-info-from-end-p nn-info) nil))) + +(declaim (special *nn-last-command-issued*)) + +(defun nn-send-many-head-requests (stream first last out-of-order-p) + (do ((i first (1+ i))) + ((> i last)) + (nntp-head i stream)) + (setf *nn-last-command-issued* + (list (if out-of-order-p :out-of-order :header) + first last out-of-order-p))) + +(defvar nn-minimum-header-batch-count 30 + "The minimum number of headers to fetch at any given time.") + + + + +;;;; "News-Message" mode. + +(defmode "News-Message" :major-p t) + + + + +;;;; Commands for viewing articles. + +(defcommand "Netnews Show Article" (p) + "Show the message the point is on. If it is the same message that is + already in the message buffer and \"Netnews Read Style\" is :multiple, + then just scroll the window down prefix argument lines" + "Show the message the point is on. If it is the same message that is + already in the message buffer and \"Netnews Read Style\" is :multiple, + then just scroll the window down prefix argument lines" + (nn-show-article (value netnews-info) p)) + +(defcommand "Netnews Next Article" (p) + "Show the next article in the current newsgroup." + "Shows the article on the line preceeding the point in the headers buffer." + (declare (ignore p)) + (let* ((what-next (netnews-next-line-command nil (nn-get-headers-buffer)))) + (when (and (not (eq what-next :done)) + (or (eq what-next t) + (eq (value netnews-last-header-style) :next-article))) + ;; Reget the headers buffer because the call to netnews-next-line-command + ;; might have moved us into a different buffer. + ;; + (nn-show-article (variable-value 'netnews-info + :buffer (nn-get-headers-buffer)) + t)))) + +(defcommand "Netnews Previous Article" (p) + "Show the previous article in the current newsgroup." + "Shows the article on the line after the point in the headers buffer." + (declare (ignore p)) + (let ((buffer (nn-get-headers-buffer))) + (netnews-previous-line-command nil buffer) + (nn-show-article (variable-value 'netnews-info :buffer buffer) t))) + +;;; NN-SHOW-ARTICLE checks first to see if we need to get more headers. If +;;; NN-MAYBE-GET-MORE-HEADERS returns nil then don't do anything because we +;;; changed to the next group. Then see if the message the user has +;;; requested is already in the message buffer. If the it isn't, put it +;;; there. If it is, and maybe-scroll-down is t, then scroll the window +;;; down p lines in :multiple mode, or just change to the buffer in :single +;;; mode. I use scroll-window down becuase this function is called by +;;; "Netnews Show Article", "Netnews Next Article", and "Netnews Previous +;;; Article". It doesn't make sense to scroll the window down if the guy +;;; just read a message, moved the point up one line and invoked "Netnews +;;; Next Article". He expects to see the article again, not the second +;;; page of it. Also check to make sure there is a message under the +;;; point. If there is not, then get some more headers. If there are no +;;; more headers, then go on to the next group. I can read and write. Hi +;;; Bill. Are you having fun grokking my code? Hope so -- Dude. Nothing +;;; like stream of consciousness is there? Come to think of it, this is +;;; kind of like recursive stream of conscious because I'm writing down my +;;; stream of conscious which is about my stream of conscious. I think I'm +;;; insane. In fact I know I am. +;;; +(defun nn-show-article (nn-info dont-scroll-down &optional p) + (let ((headers-buffer (nn-get-headers-buffer)) + (message-buffer (nn-info-buffer nn-info))) + (cond + ((eq (nn-maybe-get-more-headers nn-info) :go-on) + (case (value netnews-last-header-style) + (:this-headers (change-to-buffer headers-buffer) + (buffer-start (buffer-point headers-buffer)) + (editor-error "Last header.")) + (:next-headers (change-to-next-group nn-info headers-buffer)) + (:next-article (change-to-next-group nn-info headers-buffer) + (netnews-show-article-command nil)))) + (t + (cond ((and (not dont-scroll-down) + (= (nn-info-current-displayed-message nn-info) + (array-element-from-mark (buffer-point headers-buffer) + (nn-info-message-ids nn-info)))) + (ecase (value netnews-read-style) + (:single (buffer-start (buffer-point message-buffer)) + (change-to-buffer message-buffer)) + (:multiple + (multiple-value-bind + (headers-window message-window newp) + (nn-assure-multi-windows nn-info) + (nn-put-buffers-in-windows headers-buffer message-buffer + headers-window message-window + :headers) + ;; If both windows were visible to start with, just scroll + ;; down. If they weren't, then show the message over + ;; again. + ;; + (cond (newp (buffer-start (buffer-point message-buffer)) + (buffer-start (window-point message-window))) + (t (netnews-message-scroll-down-command + p message-buffer message-window))))))) + (t + (nn-put-article-in-buffer nn-info headers-buffer) + (setf message-buffer (nn-info-buffer nn-info)) + (multiple-value-bind + (headers-window message-window) + (ecase (value netnews-read-style) ; Only need windows in + (:single (values nil nil)) ; :multiple mode. + (:multiple (nn-assure-multi-windows nn-info))) + (ecase (value netnews-read-style) + (:multiple + ;; When there is only one window displaying the headers + ;; buffer, move the window point of that buffer to the + ;; buffer-point. + (when (= (length (buffer-windows headers-buffer)) 1) + (move-mark (window-point headers-window) + (buffer-point headers-buffer))) + (buffer-start (window-point message-window)) + (nn-put-buffers-in-windows headers-buffer message-buffer + headers-window message-window + :headers)) + (:single (change-to-buffer message-buffer)))))))))) + +(defcommand "Netnews Message Quit" (p) + "Destroy this message buffer, and pop back to the associated headers buffer." + "Destroy this message buffer, and pop back to the associated headers buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message Buffer")) + (let ((message-buffer (current-buffer))) + (change-to-buffer (nn-get-headers-buffer)) + (delete-buffer-if-possible message-buffer))) + +(defhvar "Netnews Message Header Fields" + "When NIL, the default, all available fields are displayed in the header + of a message. Otherwise, this variable should containt a list of fields + that should be included in the message header when a message is + displayed. Any string name is acceptable. Fields that do not exist are + ignored. If an element of this list is an atom, then it should be the + string name of a field. If it is a cons, then the car should be the + string name of a field, and the cdr should be the length to which this + field should be limited." + :value nil) + + +(defcommand "Netnews Show Whole Header" (p) + "This command will display the entire header of the message currently + being read." + "This command will display the entire header of the message currently + being read." + (declare (ignore p)) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (buffer (nn-get-message-buffer nn-info))) + (with-writable-buffer (buffer) + (delete-region (buffer-region buffer)) + (nn-put-article-in-buffer nn-info headers-buffer t)))) + +;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the +;;; associated message buffer if it is not there already. Uses value of +;;; "Netnews Message Header Fields" to determine what fields should appear +;;; in the message header. Returns the number of the article under the +;;; point. +;;; +(defun nn-put-article-in-buffer (nn-info headers-buffer &optional override) + (let ((stream (nn-info-stream nn-info)) + (article-number (array-element-from-mark + (buffer-point headers-buffer) + (nn-info-message-ids nn-info))) + (message-buffer (nn-get-message-buffer nn-info))) + (setf (nm-info-message-number (variable-value 'netnews-message-info + :buffer message-buffer)) + (1+ (- article-number (nn-info-first nn-info)))) + (cond ((and (= (nn-info-current-displayed-message nn-info) article-number) + (not override)) + (buffer-start (buffer-point message-buffer))) + (t + ;; Request article as soon as possible to avoid waiting for reply. + ;; + (nntp-body article-number stream) + (setf (nn-info-current-displayed-message nn-info) article-number) + (process-status-response stream nn-info) + (with-writable-buffer (message-buffer) + (let ((point (buffer-point message-buffer)) + (info (svref (nn-info-header-cache nn-info) + (- article-number (nn-info-first nn-info)))) + (message-fields (value netnews-message-header-fields)) + key field-length) + (cond ((and message-fields + (not override)) + (dolist (ele message-fields) + (etypecase ele + (atom (setf key ele field-length nil)) + (cons (setf key (car ele) field-length (cdr ele)))) + (let ((field-string (cdr (assoc key info + :test #'string-equal)))) + (when field-string + (insert-string point (string-capitalize key)) + (insert-string point ": ") + (insert-string point field-string + 0 + (max + (if field-length + (min field-length + (1- (length field-string))) + (1- (length field-string))) + 0)) + (insert-character point #\newline))))) + (t + (dolist (ele info) + (insert-string point (string-capitalize (car ele))) + (insert-string point ": ") + (insert-string point (cdr ele) + 0 (max 0 (1- (length (cdr ele))))) + (insert-character point #\newline)))) + (insert-character point #\newline) + (nntp-insert-textual-response point (nn-info-stream nn-info)))) + (buffer-start (buffer-point message-buffer)) + (when (> article-number (nn-info-latest nn-info)) + (setf (nn-info-latest nn-info) article-number)))) + article-number)) + +;;; NN-PUT-BUFFERS-IN-WINDOWS makes sure the message buffer goes in the message +;;; window and the headers buffer in the headers window. If which-current +;;; is :headers, the headers buffer/window will be made current, if it is +;;; :message, the message buffer/window will be made current. +;;; +(defun nn-put-buffers-in-windows (headers-buffer message-buffer headers-window + message-window which-current) + (setf (window-buffer message-window) message-buffer + (window-buffer headers-window) headers-buffer) + (setf (current-window) (ecase which-current + (:headers headers-window) + (:message message-window)) + (current-buffer) (case which-current + (:headers headers-buffer) + (:message message-buffer)))) + +(defhvar "Netnews Headers Proportion" + "Determines how much of the current window will display headers when + \"Netnews Read Style\" is :multiple. Defaults to .25" + :value .25) + +(defun nn-assure-multi-windows (nn-info) + (let ((newp nil)) + (unless (and (member (nn-info-message-window nn-info) *window-list*) + (member (nn-info-headers-window nn-info) *window-list*)) + (setf newp t) + (setf (nn-info-message-window nn-info) (current-window) + (nn-info-headers-window nn-info) + (make-window (buffer-start-mark (nn-get-headers-buffer)) + :proportion (value netnews-headers-proportion)))) + (values (nn-info-headers-window nn-info) + (nn-info-message-window nn-info) + newp))) + +;;; NN-GET-MESSAGE-BUFFER returns the message buffer for an nn-info structure. +;;; If there is not one, this function makes it and sets the slot in nn-info. +;;; +(defun nn-get-message-buffer (nn-info) + (let* ((message-buffer (nn-info-buffer nn-info)) + (nm-info (if message-buffer + (variable-value 'netnews-message-info + :buffer message-buffer)))) + (cond ((and message-buffer (not (nm-info-keep-p nm-info))) + (with-writable-buffer (message-buffer) + (delete-region (buffer-region message-buffer))) + message-buffer) + (t + (let ((buf (make-buffer (nn-unique-message-buffer-name + (nn-info-current nn-info)) + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field + :netnews-message))) + :modes '("News-Message") + :delete-hook + (list #'nn-message-buffer-delete-hook)))) + (setf (nn-info-buffer nn-info) buf) + (defhvar "Netnews Message Info" + "Structure that keeps track of buffers in \"News-Message\" + mode." + :value (make-netnews-message-info + :headers-buffer (current-buffer)) + :buffer buf) + buf))))) + +;;; The usual. Clean everything up. +;;; +(defun nn-message-buffer-delete-hook (buffer) + (let* ((headers-buffer (nm-info-headers-buffer + (variable-value 'netnews-message-info + :buffer buffer))) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (nm-info (variable-value 'netnews-message-info :buffer buffer))) + (setf (nn-info-buffer nn-info) nil) + (setf (nn-info-current-displayed-message nn-info) -1) + (let ((post-buffer (nm-info-post-buffer nm-info))) + (when post-buffer + (setf (post-info-message-buffer (variable-value + 'post-info :buffer post-buffer)) + nil))))) + + +;;; NN-UNIQUE-MESSAGE-BUFFER-NAME likes to have a simple name, i.e. +;;; "Netnews Message for rec.music.synth". When there is already a buffer +;;; by this name, however, we start counting until the name is unique. +;;; +(defun nn-unique-message-buffer-name (group) + (let ((name (concatenate 'simple-string "Netnews Message for " group)) + (number 0)) + (loop + (unless (getstring name *buffer-names*) (return name)) + (setf name (format nil "Netnews Message ~D" number)) + (incf number)))) + +;;; INSERT-TEXTUAL-RESPONSE inserts a textual response from nntp at mark. +;;; +(defun nntp-insert-textual-response (mark stream) + (with-input-from-nntp (string stream) + (insert-string mark string 0 (1- (length string))) + (insert-character mark #\newline))) + +;;; NN-GET-HEADERS-BUFFER returns the headers buffer if we are in a message or +;;; headers buffer. +;;; +(defun nn-get-headers-buffer () + (cond ((hemlock-bound-p 'netnews-info) + (current-buffer)) + ((hemlock-bound-p 'netnews-message-info) + (nm-info-headers-buffer (value netnews-message-info))) + ((hemlock-bound-p 'post-info) + (post-info-headers-buffer (value post-info))) + (t nil))) + + +(defcommand "Netnews Previous Line" (p &optional + (headers-buffer (current-buffer))) + "Moves the point to the last header before the point that is not in your + kill file. If you move off the end of the buffer and there are more + headers, then get them. Otherwise go on to the next group in \"Netnews + Groups\"." + "Moves the point to the last header before the point that is not in your + kill file. If you move off the end of the buffer and there are more + headers, then get them. Otherwise go on to the next group in \"Netnews + Groups\"." + (declare (ignore p)) + (let ((point (buffer-point headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer))) + (with-mark ((original-position point) + (start point) + (end point)) + (loop + (unless (line-offset point -1) + (cond ((and (nn-info-from-end-p nn-info) + (nn-info-messages-waiting nn-info)) + (nn-write-headers-to-mark nn-info headers-buffer) + (netnews-previous-line-command nil headers-buffer)) + (t + (cond ((= (nn-info-first-visible nn-info) + (nn-info-first nn-info)) + (move-mark point original-position) + (editor-error "No previous unKilled headers.")) + (t + (message "Requesting backward...") + (nn-request-out-of-order nn-info headers-buffer) + (netnews-previous-line-command nil headers-buffer)))))) + (line-start (move-mark start point)) + (character-offset (move-mark end start) 1) + (unless (string= (region-to-string (region start end)) "K") + (return)))))) + +(defhvar "Netnews Last Header Style" + "When you read the last message in a newsgroup, this variable determines + what will happen next. Takes one of three values: :this-headers, + :next-headers, or :next-article. :this-headers, the default means put me + in the headers buffer for this newsgroup. :next-headers means go to the + next newsgroup and put me in that headers buffer. :next-article means go + on to the next newsgroup and show me the first unread article." + :value :next-headers) + +(defcommand "Netnews Next Line" + (p &optional (headers-buffer (current-buffer))) + "Moves the point to the next header that is not in your kill file. If you + move off the end of the buffer and there are more headers, then get them. + Otherwise go on to the next group in \"Netnews Groups\"." + "Moves the point to the next header that is not in your kill file. If you + move off the end of the buffer and there are more headers, then get them. + Otherwise go on to the next group in \"Netnews Groups\". + Returns nil if we have gone on to the next group, :done if there are no + more groups to read, or T if everything is normal." + (declare (ignore p)) + (let* ((nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (point (buffer-point headers-buffer))) + (with-mark ((start point) + (end point)) + (loop + (line-offset point 1) + (cond ((eq (nn-maybe-get-more-headers nn-info) :go-on) + (cond ((eq (value netnews-last-header-style) :this-headers) + (let ((headers-buffer (nn-get-headers-buffer))) + (change-to-buffer headers-buffer)) + (editor-error "Last header.")) + (t + (return (change-to-next-group nn-info headers-buffer))))) + (t + (line-start (move-mark start point)) + (character-offset (move-mark end start) 1) + (unless (string= (region-to-string (region start end)) "K") + (return t)))))))) + +(defcommand "Netnews Headers Scroll Window Up" (p) + "Does what \"Scroll Window Up\" does, but fetches backward when the point + reaches the start of the headers buffer." + "Does what \"Scroll Window Up\" does, but fetches backward when the point + reaches the start of the headers buffer." + (scroll-window-up-command p) + (let ((headers-buffer (current-buffer)) + (nn-info (value netnews-info))) + (when (and (displayed-p (buffer-start-mark headers-buffer) + (current-window)) + (not (= (nn-info-first nn-info) + (nn-info-first-visible nn-info)))) + (buffer-start (current-point)) + (netnews-previous-line-command nil)))) + +(defcommand "Netnews Headers Scroll Window Down" (p) + "Does what \"Scroll Window Down\" does, but when the point reaches the end of + the headers buffer, pending headers are inserted." + "Does what \"Scroll Window Down\" does, but when the point reaches the end of + the headers buffer, pending headers are inserted." + (scroll-window-down-command p) + (let ((headers-buffer (current-buffer)) + (nn-info (value netnews-info))) + (when (and (displayed-p (buffer-end-mark headers-buffer) (current-window)) + (not (= (nn-info-last nn-info) (nn-info-last-visible nn-info)))) + (buffer-end (current-point)) + (netnews-next-line-command nil)))) + +(defcommand "Netnews Message Keep Buffer" (p) + "Specifies that you don't want Hemlock to reuse the current message buffer." + "Specifies that you don't want Hemlock to reuse the current message buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message buffer.")) + (setf (nm-info-keep-p (value netnews-message-info)) t)) + +(defcommand "Netnews Goto Headers Buffer" (p) + "From \"Message Mode\", switch to the associated headers buffer." + "From \"Message Mode\", switch to the associated headers buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a message buffer.")) + (let ((headers-buffer (nm-info-headers-buffer (value netnews-message-info)))) + (unless headers-buffer (editor-error "Headers buffer has been deleted")) + (change-to-buffer headers-buffer))) + +(defcommand "Netnews Goto Post Buffer" (p) + "Change to the associated \"Post\" buffer (if there is one) from a + \"News-Message\" buffer." + "Change to the associated \"Post\" buffer (if there is one) from a + \"News-Message\" buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message buffer.")) + (let ((post-buffer (nm-info-post-buffer (value netnews-message-info)))) + (unless post-buffer (editor-error "No associated post buffer.")) + (change-to-buffer post-buffer))) + +(defcommand "Netnews Goto Draft Buffer" (p) + "Change to the associated \"Draft\" buffer (if there is one) from a + \"News-Message\" buffer." + "Change to the associated \"Draft\" buffer (if there is one) from a + \"News-Message\" buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'netnews-message-info) + (editor-error "Not in a News-Message buffer.")) + (let ((draft-buffer (nm-info-draft-buffer (value netnews-message-info)))) + (unless draft-buffer (editor-error "No associated post buffer.")) + (change-to-buffer draft-buffer))) + +(defcommand "Netnews Select Message Buffer" (p) + "Change to the associated message buffer (if there is one) in \"Post\" or + \"News-Headers\" modes." + "Change to the associated message buffer (if there is one) in \"Post\" or + \"News-Headers\" modes." + (declare (ignore p)) + (let* ((cbuf (current-buffer)) + (mbuf (cond ((hemlock-bound-p 'post-info :buffer cbuf) + (post-info-message-buffer (value post-info))) + ((hemlock-bound-p 'netnews-info :buffer cbuf) + (nn-info-buffer (value netnews-info))) + (t + (editor-error "Not in a \"Post\" or \"News-Headers\" ~ + buffer."))))) + (unless mbuf (editor-error "No assocated message buffer.")) + (change-to-buffer mbuf))) + +;;; CHANGE-TO-NEXT-GROUP deletes nn-info's headers buffer region and sets +;;; up the next group in that buffer. If there are no more groups to read, +;;; exits gracefully. +;;; +(defun change-to-next-group (nn-info headers-buffer) + (when (nn-info-updatep nn-info) + (nn-update-database-file (nn-info-latest nn-info) + (nn-info-current nn-info))) + (let ((next-group (cadr (member (nn-info-current nn-info) + (nn-info-groups nn-info) :test #'string=)))) + (cond (next-group + (message "Going on to ~A" next-group) + (force-output *echo-area-stream*) + (let ((message-buffer (nn-info-buffer nn-info))) + (when message-buffer + (setf (buffer-name message-buffer) + (nn-unique-message-buffer-name next-group)))) + (setf (buffer-name headers-buffer) + (nn-unique-headers-name next-group)) + (setf (nn-info-current nn-info) next-group) + (with-writable-buffer (headers-buffer) + (delete-region (buffer-region headers-buffer))) + (setup-group next-group nn-info headers-buffer) + nil) + (t + (if (eq headers-buffer *nn-headers-buffer*) + (message "This was your last group. Exiting Netnews.") + (message "Done with ~A. Exiting Netnews." + (nn-info-current nn-info))) + (netnews-exit-command nil t headers-buffer) + :done)))) + +(defun nn-update-database-file (latest group-name) + (when latest (setf (nn-last-read-message-number group-name) latest))) + + + + +;;;; More commands. + +(defhvar "Netnews Scroll Show Next Message" + "When non-nil, the default, Hemlock will show the next message in a group + when you scroll off the end of one. Otherwise Hemlock will editor error + that you are at the end of the buffer." + :value T) + +(defcommand "Netnews Message Scroll Down" (p &optional (buffer (current-buffer)) + (window (current-window))) + "Scrolls the current window down one screenful, checking to see if we need + to get the next message." + "Scrolls the current window down one screenful, checking to see if we need + to get the next message." + (if (displayed-p (buffer-end-mark buffer) window) + (if (value netnews-scroll-show-next-message) + (netnews-next-article-command nil) + (editor-error "At end of buffer.")) + (scroll-window-down-command p window))) + +(defcommand "Netnews Go to Next Group" (p) + "Goes on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the the latest message read. With an argument + does not modify the group pointer." + "Goes on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the the latest message read. With an argument + does not modify the group pointer." + (nn-punt-headers (if p :none :latest))) + +(defcommand "Netnews Group Punt Messages" (p) + "Go on to the next group in \"Netnews Group File\" setting the netnews + pointer for this group to the last message. With an argument, set the + pointer to the last visible message in this group." + "Go on to the next group in \"Netnews Group File\" setting the netnews + pointer for this group to the last message. With an argument, set the + pointer to the last visible message in this group." + (nn-punt-headers (if p :last-visible :punt))) + +(defcommand "Netnews Quit Starting Here" (p) + "Go on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the message before the currently displayed one + or the message under the point if none is currently displayed." + "Go on to the next group in \"Netnews Group File\", setting the group + pointer for this group to the message before the currently displayed one + or the message under the point if none is currently displayed." + (declare (ignore p)) + (nn-punt-headers :this-one)) + +(defun nn-punt-headers (pointer-type) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (stream (nn-info-header-stream nn-info))) + (message "Exiting ~A" (nn-info-current nn-info)) + (setf (nn-info-latest nn-info) + (ecase pointer-type + (:latest (nn-info-latest nn-info)) + (:punt (nn-info-last nn-info)) + (:last-visible (nn-info-last-visible nn-info)) + (:this-one + (1- (if (minusp (nn-info-current-displayed-message nn-info)) + (array-element-from-mark (buffer-point headers-buffer) + (nn-info-message-ids nn-info)) + (nn-info-current-displayed-message nn-info)))) + (:none nil))) + ;; This clears out all headers that waiting on header-stream. + ;; Must process each response in case a message is not really there. + ;; If it isn't, then the call to WITH-INPUT-FROM-NNTP will gobble up + ;; the error message and the next real article. + ;; + (when (nn-info-messages-waiting nn-info) + (dotimes (i (nn-info-batch-count nn-info)) + (let ((response (process-status-response stream))) + (when response (with-input-from-nntp (string stream)))))) + (change-to-next-group nn-info headers-buffer))) + +(defcommand "Fetch All Headers" (p) + "Fetches the rest of the headers in the current group. + Warning: This will take a while if there are a lot." + "Fetches the rest of the headers in the current group. + Warning: This will take a while if there are a lot." + (declare (ignore p)) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer))) + (if (nn-info-messages-waiting nn-info) + (message "Fetching the rest of the headers for ~A" + (nn-info-current nn-info)) + (editor-error "All headers are in buffer.")) + ;; The first of these calls writes the headers that are waiting on the + ;; headers stream and requests the rest. The second inserts the rest, if + ;; there are any. + ;; + (nn-write-headers-to-mark nn-info headers-buffer t) + (nn-write-headers-to-mark nn-info headers-buffer))) + + +(defcommand "List All Groups" (p &optional buffer) + "Shows all available newsgroups in a buffer." + "Shows all available newsgroups in a buffer." + (declare (ignore p)) + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (if headers-buffer + (variable-value 'netnews-info :buffer headers-buffer))) + (stream (if headers-buffer + (nn-info-stream nn-info) + (connect-to-nntp)))) + (nntp-list stream) + (message "Fetching group list...") + (process-status-response stream) + (let* ((buffer (or buffer (make-buffer (nn-new-list-newsgroups-name)))) + (point (buffer-point buffer)) + (groups (make-array 1500 :fill-pointer 0 :adjustable t))) + (with-input-from-nntp (string (if headers-buffer + (nn-info-stream nn-info) + stream)) + (vector-push-extend string groups)) + (sort groups #'string<) + (dotimes (i (length groups)) + (let ((group (aref groups i))) + (multiple-value-bind (last first) (list-response-args group) + (declare (ignore first)) + (insert-string point group 0 (position #\space group)) + (insert-string point (format nil ": ~D~%" last))))) + (setf (buffer-modified buffer) nil) + (buffer-start point) + (change-to-buffer buffer)) + (unless headers-buffer (close stream)))) + +(defun nn-new-list-newsgroups-name () + (let ((name "Newsgroups List") + (number 0)) + (declare (simple-string name) + (fixnum number)) + (loop + (unless (getstring name *buffer-names*) (return name)) + (setf name (format nil "Newsgroups List ~D" number)) + (incf number)))) + +(defhvar "Netnews Message File" + "This value is merged with your home directory to get the pathname of the + file to which Hemlock will append messages." + :value "hemlock.messages") + +(defhvar "Netnews Exit Confirm" + "When non-nil, the default, \"Netnews Exit\" will ask you if you really + want to. If this variable is NIL, you will not be prompted." + :value T) + +(defcommand "Netnews Exit" (p &optional no-prompt-p + (headers-buf (nn-get-headers-buffer))) + "Exit Netnews from a netnews headers or netnews message buffer." + "Exit Netnews from a netnews headers or netnews message buffer." + (declare (ignore p)) + (let ((browse-buffer (variable-value 'netnews-browse-buffer + :buffer headers-buf))) + (when (or browse-buffer + no-prompt-p + (not (value netnews-exit-confirm)) + (prompt-for-y-or-n :prompt "Exit Netnews? " + :default "Y" + :default-string "Y" + :help "Yes exits netnews mode.")) + (let* ((nn-info (variable-value 'netnews-info :buffer headers-buf)) + (message-buffer (nn-info-buffer nn-info)) + (headers-window (nn-info-headers-window nn-info)) + (message-window (nn-info-message-window nn-info))) + (when (nn-info-updatep nn-info) + (nn-update-database-file (nn-info-latest nn-info) + (nn-info-current nn-info))) + (when (and (eq (value netnews-read-style) :multiple) + (member headers-window *window-list*) + (member message-window *window-list*)) + (delete-window message-window)) + (when message-buffer (delete-buffer-if-possible message-buffer)) + (delete-buffer-if-possible headers-buf) + (when browse-buffer (change-to-buffer browse-buffer)))))) + + + + +;;;; Commands to append messages to a file or file messages into mail folders. + +(defcommand "Netnews Append to File" (p) + "In a \"News-Headers\" buffer, appends the message under the point onto + the file named by \"Netnews Message File\". In a \"News-Message\" buffer, + appends the message in the current buffer to the same file." + "In a \"News-Headers\" buffer, appends the message under the point onto + the file named by \"Netnews Message File\". In a \"News-Message\" buffer, + appends the message in the current buffer to the same file." + (let* ((filename (merge-pathnames (value netnews-message-file) + (user-homedir-pathname))) + (file (prompt-for-file :prompt "Append to what file: " + :must-exist nil + :default filename + :default-string (namestring filename)))) + (when (and p (probe-file file)) + (delete-file file)) + (message "Appending message to ~S" (namestring file)) + (cond ((hemlock-bound-p 'netnews-info) + (let* ((nn-info (value netnews-info)) + (stream (nn-info-stream nn-info)) + (article-number (array-element-from-mark + (current-point) + (nn-info-message-ids nn-info) + "No header under point."))) + (with-open-file (file file :direction :output + :if-exists :append + :if-does-not-exist :create) + (nntp-article article-number stream) + (process-status-response stream) + (with-input-from-nntp (string (nn-info-stream nn-info)) + (write-line string file :end (1- (length string))))))) + (t + (write-file (buffer-region (current-buffer)) file))) + ;; Put a page separator and some whitespace between messages for + ;; readability when printing or scanning. + ;; + (with-open-file (f file :direction :output :if-exists :append) + (terpri f) + (terpri f) + (write-line " +" f) + (terpri f)))) + +(defcommand "Netnews Headers File Message" (p) + "Files the message under the point into a folder of your choice. If the + folder you select does not exist, it is created." + "Files the message under the point into a folder of your choice. If the + folder you select does not exist, it is created." + (declare (ignore p)) + (nn-file-message (value netnews-info) :headers)) + +(defcommand "Netnews Message File Message" (p) + "Files the message in the current buffer into a folder of your choice. If + folder you select does not exist, it is created." + "Files the message in the current buffer into a folder of your choice. If + folder you select does not exist, it is created." + (declare (ignore p)) + (nn-file-message (variable-value 'netnews-info + :buffer (nn-get-headers-buffer)) + :message)) + +(defun nn-file-message (nn-info kind) + (let ((article-number (array-element-from-mark (current-point) + (nn-info-message-ids nn-info) + "No header under point.")) + (folder (prompt-for-folder :prompt "MH Folder: " + :must-exist nil))) + (unless (folder-existsp folder) + (if (prompt-for-y-or-n + :prompt "Destination folder doesn't exist. Create it? " + :default t :default-string "Y") + (create-folder folder) + (editor-error "Not filing message."))) + (message "Filing message into ~A" folder) + (ecase kind + (:headers (nntp-article article-number (nn-info-stream nn-info)) + (process-status-response (nn-info-stream nn-info)) + (with-open-file (s "/tmp/temp.msg" :direction :output + :if-exists :rename-and-delete + :if-does-not-exist :create) + (with-input-from-nntp (string (nn-info-stream nn-info)) + (write-line string s :end (1- (length string)))))) + (:message (write-file (buffer-region (current-buffer)) "/tmp/temp.msg" + :keep-backup nil))) + (mh "inc" `(,folder "-silent" "-file" "/tmp/temp.msg")) + (message "Done."))) + + + + +;;;; "Post" Mode and supporting commands. + +(defmode "Post" :major-p nil) + +(defun nn-unique-post-buffer-name () + (let ((name "Post") + (number 0)) + (loop + (unless (getstring name *buffer-names*) (return name)) + (setf name (format nil "Post ~D" number)) + (incf number)))) + +;;; We usually know what the subject and newsgroups are, so keep these patterns +;;; around to make finding where to insert the information easy. +;;; +(defvar *draft-subject-pattern* + (new-search-pattern :string-insensitive :forward "Subject:")) + +(defvar *draft-newsgroups-pattern* + (new-search-pattern :string-insensitive :forward "Newsgroups:")) + +(defcommand "Netnews Post Message" (p) + "Set up a buffer for posting to netnews." + "Set up a buffer for posting to netnews." + (declare (ignore p)) + (let ((headers-buf (nn-get-headers-buffer)) + (post-buf (nn-make-post-buffer))) + ;; If we're in a "News-Headers" or "News-Message" buffer, fill in the + ;; newsgroups: slot in the header. + (when headers-buf + (insert-string-after-pattern (buffer-point post-buf) + *draft-newsgroups-pattern* + (nn-info-current + (variable-value + 'netnews-info :buffer headers-buf)))) + (nn-post-message nil post-buf))) + +(defcommand "Netnews Abort Post" (p) + "Abort the current post." + "Abort the current post." + (declare (ignore p)) + (delete-buffer-if-possible (current-buffer))) + +(defun foobie-frob (post-info buffer) + (declare (ignore post-info)) + (change-to-buffer buffer)) +#| + #'(lambda (post-info buffer) + (declare (ignore post-info)) + (print :changing) (force-output) + (change-to-buffer buffer) + (print :changed) (force-output)) +|# +(defvar *netnews-post-frob-windows-hook* #'foobie-frob + "This hook is FUNCALled in NN-POST-MESSAGE with a post-info structure and + the corresponding \"POST\" buffer before a post is done.") + +;;; NN-POST-MESSAGE sets up a buffer for posting. If message buffer is +;;; supplied, it is associated with the post-info structure for the post +;;; buffer. +;;; +(defun nn-post-message (message-buffer &optional (buffer (nn-make-post-buffer))) + (setf (buffer-modified buffer) nil) + (when message-buffer + (setf (nm-info-post-buffer (variable-value 'netnews-message-info + :buffer message-buffer)) + buffer)) + (let ((post-info (make-post-info :stream (connect-to-nntp) + :headers-buffer (nn-get-headers-buffer) + :message-buffer message-buffer))) + (defhvar "Post Info" + "Information needed to manipulate post buffers." + :buffer buffer + :value post-info) + (funcall *netnews-post-frob-windows-hook* post-info buffer))) + +(defun nn-make-post-buffer () + (let* ((buffer (make-buffer (nn-unique-post-buffer-name) + :delete-hook (list #'nn-post-buffer-delete-hook))) + (stream (make-hemlock-output-stream (buffer-point buffer)))) + (setf (buffer-minor-mode buffer "Post") t) + (write-line "Newsgroups: " stream) + (write-line "Subject: " stream) +; (write-string "Date: " stream) +; (format stream "~A~%" (string-capitalize +; (format-universal-time nil (get-universal-time) +; :style :government +; :print-weekday nil))) + (write-char #\newline stream) + (write-char #\newline stream) + buffer)) + +;;; The usual again. NULLify the appropriate stream slots in associated +;;; structures. Also call NN-REPLY-CLEANUP-SPLIT-WINDOWS to see if we +;;; need to delete one of the current windows. +;;; +(defun nn-post-buffer-delete-hook (buffer) + (when (hemlock-bound-p 'post-info) + (nn-reply-cleanup-split-windows buffer) + (let* ((post-info (variable-value 'post-info :buffer buffer)) + (message-buffer (post-info-message-buffer post-info))) + (close (post-info-stream post-info)) + (when message-buffer + (setf (nm-info-post-buffer (variable-value 'netnews-message-info + :buffer message-buffer)) + nil))))) + +;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a +;;; normal reply. *netnews-post-frob-windows-hook* is bound to this when +;;; "Netnews Reply to Group" is invoked." +;;; +(defun nn-reply-using-current-window (post-info buffer) + (declare (ignore post-info)) + ;; Make sure there is only one window in :multiple mode. + ;; + (let* ((nn-info (variable-value 'netnews-info + :buffer (nn-get-headers-buffer))) + (headers-window (nn-info-headers-window nn-info)) + (message-window (nn-info-message-window nn-info))) + (when (and (eq (value netnews-read-style) :multiple) + (member message-window *window-list*) + (member headers-window *window-list*)) + (setf (current-window) message-window) + (delete-window headers-window)) + (change-to-buffer buffer))) + +;;; NN-REPLY-IN-OTHER-WINDOW-HOOK does what NN-REPLY-USING-CURRENT-WINDOW +;;; does, but in addition splits the current window in half, displaying the +;;; message buffer on top, and the reply buffer on the bottom. Also set some +;;; slots in the post info structure so the cleanup function knowd to delete +;;; one of the two windows we've created. +;;; +(defun nn-reply-in-other-window-hook (post-info buffer) + (nn-reply-using-current-window post-info buffer) + (let* ((message-window (current-window)) + (reply-window (make-window (buffer-start-mark buffer)))) + (setf (window-buffer message-window) (post-info-message-buffer post-info) + (current-window) reply-window + (post-info-message-window post-info) message-window + (post-info-reply-window post-info) reply-window))) + +;;; NN-REPLY-CLEANUP-SPLIT-WINDOWS just deletes one of the windows that +;;; "Netnews Reply to Group in Other Window" created, if they still exist. +;;; +(defun nn-reply-cleanup-split-windows (post-buffer) + (let* ((post-info (variable-value 'post-info :buffer post-buffer)) + (message-window (post-info-message-window post-info))) + (when (and (member (post-info-reply-window post-info) *window-list*) + (member message-window *window-list*)) + (delete-window message-window)))) + +(defcommand "Netnews Reply to Group" (p) + "Set up a POST buffer and insert the proper newgroups: and subject: fields. + Should be invoked from a \"News-Message\" or \"News-Headers\" buffer. + In a message buffer, reply to the message in that buffer, in a headers + buffer, reply to the message under the point." + "Set up a POST buffer and insert the proper newgroups: and subject: fields. + Should be invoked from a \"News-Message\" or \"News-Headers\" buffer. + In a message buffer, reply to the message in that buffer, in a headers + buffer, reply to the message under the point." + (declare (ignore p)) + (let ((*netnews-post-frob-windows-hook* #'nn-reply-using-current-window)) + (nn-reply-to-message))) + +(defcommand "Netnews Reply to Group in Other Window" (p) + "Does exactly what \"Netnews Reply to Group\" does, but makes two windows. + One of the windows displays the message being replied to, and the other + displays the reply." + "Does exactly what \"Netnews Reply to Group\" does, but makes two windows. + One of the windows displays the message being replied to, and the other + displays the reply." + (declare (ignore p)) + (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook)) + (nn-reply-to-message))) + + +(defun nn-setup-for-reply-by-mail () + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (message-buffer (nn-info-buffer nn-info)) + (nm-info (variable-value 'netnews-message-info :buffer message-buffer)) + (draft-buffer (sub-setup-message-draft "comp" :to-field)) + (dinfo (variable-value 'draft-information :buffer draft-buffer))) + (setf (buffer-delete-hook draft-buffer) + (list #'cleanup-netnews-draft-buffer)) + (when (nm-info-draft-buffer nm-info) + (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info))) + (setf (nm-info-draft-buffer nm-info) draft-buffer) + (when headers-buffer + (defhvar "Headers Buffer" + "This is bound in message and draft buffers to their associated + headers-buffer" + :value headers-buffer :buffer draft-buffer)) + (setf (draft-info-headers-mark dinfo) + (copy-mark (buffer-point headers-buffer))) + (defhvar "Message Buffer" + "This is bound in draft buffers to their associated message buffer." + :value message-buffer :buffer draft-buffer) + (values draft-buffer message-buffer))) + + +(defcommand "Netnews Forward Message" (p) + "Creates a Draft buffer and places a copy of the current message in + it, delimited by forwarded message markers." + "Creates a Draft buffer and places a copy of the current message in + it, delimited by forwarded message markers." + (declare (ignore p)) + (multiple-value-bind (draft-buffer message-buffer) + (nn-setup-for-reply-by-mail) + (with-mark ((mark (buffer-point draft-buffer) :left-inserting)) + (buffer-end mark) + (insert-string mark (format nil "~%------- Forwarded Message~%~%")) + (insert-string mark (format nil "~%------- End of Forwarded Message~%")) + (line-offset mark -2 0) + (insert-region mark (buffer-region message-buffer))) + (nn-reply-using-current-window nil draft-buffer))) + + +(defun nn-reply-to-sender () + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (article (if (and (hemlock-bound-p 'netnews-info) + (minusp (nn-info-current-displayed-message + nn-info))) + (nn-put-article-in-buffer nn-info headers-buffer) + (nn-info-current-displayed-message nn-info)))) + (multiple-value-bind (draft-buffer message-buffer) + (nn-setup-for-reply-by-mail) + (let ((point (buffer-point draft-buffer)) + (to-field (or (nn-get-one-field nn-info "Reply-To" article) + (nn-get-one-field nn-info "From" article)))) + (insert-string-after-pattern point + *draft-to-pattern* + to-field + :end (1- (length to-field))) + (let ((subject-field (nn-subject-replyify + (nn-get-one-field nn-info "Subject" article)))) + (insert-string-after-pattern point + *draft-subject-pattern* + subject-field + :end (1- (length subject-field))))) + (nn-reply-using-current-window nil draft-buffer) + (values draft-buffer message-buffer)))) + +(defcommand "Netnews Reply to Sender" (p) + "Reply to the sender of a message via mail using the Hemlock mailer." + "Reply to the sender of a message via mail using the Hemlock mailer." + (declare (ignore p)) + (nn-reply-to-sender)) + +(defcommand "Netnews Reply to Sender in Other Window" (p) + "Reply to the sender of a message via mail using the Hemlock mailer. The + screen will be split in half, displaying the post and the draft being + composed." + "Reply to the sender of a message via mail using the Hemlock mailer. The + screen will be split in half, displaying the post and the draft being + composed." + (declare (ignore p)) + (multiple-value-bind (draft-buffer message-buffer) + (nn-reply-to-sender) + (let* ((message-window (current-window)) + (reply-window (make-window (buffer-start-mark draft-buffer)))) + (defhvar "Split Window Draft" + "Indicates window needs to be cleaned up for draft." + :value t :buffer draft-buffer) + (setf (window-buffer message-window) message-buffer + (current-window) reply-window)))) + +;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook +;;; because the generic one tries to set some slots in the related message-info +;;; structure which doesn't exist. This function just sets the draft buffer +;;; slot of netnews-message-info to nil so it won't screw you when you try +;;; to change to the associated draft buffer. +;;; +(defun cleanup-netnews-draft-buffer (buffer) + (when (hemlock-bound-p 'message-buffer :buffer buffer) + (setf (nm-info-draft-buffer + (variable-value 'netnews-message-info + :buffer (variable-value 'message-buffer + :buffer buffer))) + nil))) + +;;; NN-REPLYIFY-SUBJECT simply adds "Re: " to the front of a string if it is +;;; not already there. +;;; +(defun nn-subject-replyify (subject) + (if (>= (length subject) 3) + (if (not (string= subject "Re:" :end1 3 :end2 3)) + (concatenate 'simple-string "Re: " subject) + subject) + (concatenate 'simple-string "Re: " subject))) + +(defun insert-string-after-pattern (mark search-pattern string + &key (start 0) (end (length string))) + (buffer-start mark) + (when (and (plusp end) + (find-pattern mark search-pattern)) + (insert-string (line-end mark) string start end)) + (buffer-end mark)) + +(defun nn-reply-to-message () + (let* ((headers-buffer (nn-get-headers-buffer)) + (nn-info (variable-value 'netnews-info :buffer headers-buffer)) + (article (if (and (hemlock-bound-p 'netnews-info) + (minusp (nn-info-current-displayed-message nn-info))) + (nn-put-article-in-buffer nn-info headers-buffer) + (nn-info-current-displayed-message nn-info))) + (post-buffer (nn-make-post-buffer)) + (point (buffer-point post-buffer))) + + (let ((groups-field (nn-get-one-field nn-info "Newsgroups" article))) + (insert-string-after-pattern point + *draft-newsgroups-pattern* + groups-field + :end (1- (length groups-field)))) + (let ((subject-field (nn-subject-replyify + (nn-get-one-field nn-info "Subject" article)))) + (insert-string-after-pattern point + *draft-subject-pattern* + subject-field + :end (1- (length subject-field)))) + (nn-post-message (nn-info-buffer nn-info) post-buffer))) + +(defun nn-get-one-field (nn-info field article) + (cdr (assoc field (svref (nn-info-header-cache nn-info) + (- article (nn-info-first nn-info))) + :test #'string-equal))) + +(defvar *nntp-timeout-handler* 'nn-recover-from-timeout + "This function gets FUNCALled when NNTP times out on us with the note passed + to PROCESS-STATUS-RESPONSE. The default assumes the note is an NN-INFO + structure and tries to recover from the timeout.") + +(defvar *nn-last-command-issued* nil + "The last string issued to one of the NNTP streams. Used to recover from + a nntp timeout.") + +;;; NN-RECOVER-FROM-POSTING-TIMEOUT is the recover method used when posting. +;;; It just resets the value of \"NNTP Stream\" and issues the last command +;;; again. +;;; +(defun nn-recover-from-posting-timeout (ignore) + (declare (ignore ignore)) + (let ((stream (connect-to-nntp))) + (setf (post-info-stream (value post-info)) stream) + (write-nntp-command *nn-last-command-issued* stream :recover) + (process-status-response stream))) + +(defhvar "Netnews Reply Address" + "What the From: field will be when you post messages. If this is nil, + the From: field will be determined using the association of :USER + in *environment-list* and your machine name." + :value NIL) + +(defhvar "Netnews Signature Filename" + "This value is merged with your home directory to get the pathname your + signature, which is appended to every post you make." + :value ".hemlock-sig") + +(defhvar "Netnews Deliver Post Confirm" + "This determines whether Netnews Deliver Post will ask for confirmation + before posting the current message." + :value t) + +(defcommand "Netnews Deliver Post" (p) + "Deliver the current Post buffer to the NNTP server. If the file named by + the value of \"Netnews Signature Filename\" exists, it is appended to the + end of the message after adding a newline." + "Deliver the current Post buffer to the NNTP server, cleaning up any windows + we need and landing us in the headers buffer if this was a reply." + (declare (ignore p)) + (when (or (not (value netnews-deliver-post-confirm)) + (prompt-for-y-or-n :prompt "Post message? " :default t)) + (let* ((*nntp-timeout-handler* #'nn-recover-from-posting-timeout) + (stream (post-info-stream (value post-info)))) + (nntp-post stream) + (let ((winp (process-status-response stream)) + ;; Rebind stream here because the stream may have been pulled out + ;; from under us by an NNTP timeout. The recover method for posting + ;; resets the Hemlock Variable. + (stream (post-info-stream (value post-info)))) + (unless winp (editor-error "Posting prohibited in this group.")) + (let ((buffer (current-buffer)) + (username (value netnews-reply-address))) + (nn-write-line (format nil "From: ~A" + (if username + username + (string-downcase + (format nil "~A@~A" + (cdr (assoc :user + ext:*environment-list*)) + (machine-instance))))) + stream) + (filter-region #'(lambda (string) + (when (string= string ".") + (write-char #\. stream)) + (nn-write-line string stream)) + (buffer-region buffer)) + ;; Append signature + ;; + (let ((filename (merge-pathnames (value netnews-signature-filename) + (user-homedir-pathname)))) + (when (probe-file filename) + (with-open-file (istream filename :direction :input) + (loop + (let ((line (read-line istream nil nil))) + (unless line (return)) + (nn-write-line line stream)))))) + (write-line nntp-eof stream) + (delete-buffer-if-possible buffer) + (let ((headers-buffer (nn-get-headers-buffer))) + (when headers-buffer (change-to-buffer headers-buffer))) + (message "Message Posted.")))))) + +(defun nn-write-line (line stream) + (write-string line stream) + (write-char #\return stream) + (write-char #\newline stream) + line) + + + + +;;;; News-Browse mode. + +(defmode "News-Browse" :major-p t) + +(defhvar "Netnews Group File" + "If the value of \"Netnews Groups\" is nil, \"Netnews\" merges this + variable with your home directory and looks there for a list of newsgroups + (one per line) to read. Groups may be added using \"Netnews Browse\ and + related commands, or by editing this file." + :value ".hemlock-groups") + +(defcommand "Netnews Browse" (p) + "Puts all netnews groups in a buffer and provides commands for reading them + and adding them to the file specified by the merge of \"Netnews Group File\" + and your home directory." + "Puts all netnews groups in a buffer and provides commands for reading them + and adding them to the file specified by the merge of \"Netnews Group File\" + and your home directory." + (declare (ignore p)) + (let ((buffer (make-buffer "Netnews Browse"))) + (cond (buffer + (list-all-groups-command nil buffer) + (setf (buffer-major-mode buffer) "News-Browse") + (setf (buffer-writable buffer) nil)) + (t (change-to-buffer (getstring "Netnews Browse" *buffer-names*)))))) + +(defcommand "Netnews Quit Browse" (p) + "Exit News-Browse Mode." + "Exit News-Browse Mode." + (declare (ignore p)) + (delete-buffer-if-possible (current-buffer))) + +(defcommand "Netnews Browse Read Group" (p &optional (mark (current-point))) + "Read the group on the line under the current point paying no attention to + the \"Hemlock Database File\" entry for this group. With an argument, use + and modify the database file." + "Read the group on the line under the current point paying no attention to + the \"Hemlock Database File\" entry for this group. With an argument, use + and modify the database file." + (let ((group-info-string (line-string (mark-line mark)))) + (netnews-command nil (subseq group-info-string + 0 (position #\: group-info-string)) + nil (current-buffer) p))) + +(defcommand "Netnews Browse Pointer Read Group" (p) + "Read the group on the line where you just clicked paying no attention to the + \"Hemlock Databse File\" entry for this group. With an argument, use and + modify the databse file." + "Read the group on the line where you just clicked paying no attention to the + \"Hemlock Databse File\" entry for this group. With an argument, use and + modify the databse file." + (multiple-value-bind (x y window) (last-key-event-cursorpos) + (unless window (editor-error "Couldn't figure out where last click was.")) + (unless y (editor-error "There is no group in the modeline.")) + (netnews-browse-read-group-command p (cursorpos-to-mark x y window)))) + +(defcommand "Netnews Browse Add Group to File" (p &optional + (mark (current-point))) + "Append the newsgroup on the line under the point to the file specified by + \"Netnews Group File\". With an argument, delete all groups that were + there to start with." + "Append the newsgroup on the line under the point to the file specified by + \"Netnews Group File\". With an argument, delete all groups that were + there to start with." + (declare (ignore p)) + (let* ((group-info-string (line-string (mark-line mark))) + (group (subseq group-info-string 0 (position #\: group-info-string)))) + (with-open-file (s (merge-pathnames (value netnews-group-file) + (user-homedir-pathname)) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (write-line group s)) + (message "Adding ~S to newsgroup file." group))) + +(defcommand "Netnews Browse Pointer Add Group to File" (p) + "Append the newsgroup you just clicked on to the file specified by + \"Netnews Group File\"." + "Append the newsgroup you just clicked on to the file specified by + \"Netnews Group File\"." + (declare (ignore p)) + (multiple-value-bind (x y window) (last-key-event-cursorpos) + (unless window (editor-error "Couldn't figure out where last click was.")) + (unless y (editor-error "There is no group in the modeline.")) + (netnews-browse-add-group-to-file-command + nil (cursorpos-to-mark x y window)))) + + + + +;;;; Low-level stream operations. + +(defun streams-for-nntp () + (clear-echo-area) + (format *echo-area-stream* "Connecting to NNTP...~%") + (force-output *echo-area-stream*) + (values (connect-to-nntp) (connect-to-nntp))) + + +(defparameter *nntp-port* 119 + "The nntp port number for NNTP as specified in RFC977.") + +(defhvar "Netnews NNTP Server" + "The hostname of the NNTP server to use for reading Netnews." + :value "netnews.srv.cs.cmu.edu") + +(defhvar "Netnews NNTP Timeout Period" + "The number of seconds to wait before timing out when trying to connect + to the NNTP server." + :value 30) + +(defun raw-connect-to-nntp () + (let ((stream (system:make-fd-stream + (ext:connect-to-inet-socket (value netnews-nntp-server) + *nntp-port*) + :input t :output t :buffering :line :name "NNTP" + :timeout (value netnews-nntp-timeout-period)))) + (process-status-response stream) + stream)) + +(defun connect-to-nntp () + (handler-case + (raw-connect-to-nntp) + (io-timeout () + (editor-error "Connection to NNTP timed out. Try again later.")))) + +(defvar *nn-last-command-type* nil + "Used to recover from a nntp timeout.") + +(defun write-nntp-command (command stream type) + (setf *nn-last-command-type* type) + (setf *nn-last-command-issued* command) + (write-string command stream) + (write-char #\return stream) + (write-char #\newline stream) + (force-output stream)) + + + + +;;;; PROCESS-STATUS-RESPONSE and NNTP error handling. + +(defconstant nntp-error-codes '(#\4 #\5) + "These codes signal that NNTP could not complete the request you asked for.") + +(defvar *nntp-error-handlers* nil) + +;;; PROCESS-STATUS-RESPONSE makes sure a response waiting at the server is +;;; valid. If the response code starts with a 4 or 5, then look it up in +;;; *nntp-error-handlers*. If an error handler is defined, then FUNCALL it +;;; on note. Otherwise editor error. If the response is not an error code, +;;; then just return what NNTP returned to us for parsing later. +;;; +(defun process-status-response (stream &optional note) + (let ((str (read-line stream))) + (if (member (schar str 0) nntp-error-codes :test #'char=) + (let ((error-handler (cdr (assoc str *nntp-error-handlers* + :test #'(lambda (string1 string2) + (string= string1 string2 + :end1 3 + :end2 3)))))) + (unless error-handler + (error "NNTP error -- ~A" (subseq str 4 (1- (length str))))) + (funcall error-handler note)) + str))) + +(defun nn-recover-from-timeout (nn-info) + (message "NNTP timed out, attempting to reconnect and continue...") + (let ((stream (nn-info-stream nn-info)) + (header-stream (nn-info-header-stream nn-info))) + ;; If some messages are waiting on the header stream, insert them. + ;; + (when (listen header-stream) + (nn-write-headers-to-mark nn-info (nn-get-headers-buffer))) + (close stream) + (close header-stream) + (setf stream (connect-to-nntp) + header-stream (connect-to-nntp) + (nn-info-stream nn-info) stream + (nn-info-header-stream nn-info) header-stream) + (let ((last-command *nn-last-command-issued*) + (last-command-type *nn-last-command-type*) + (current (nn-info-current nn-info))) + (nntp-group current stream header-stream) + (process-status-response stream) + (process-status-response header-stream) + (if (consp last-command) + (let ((stream-type (car last-command))) + (apply #'nn-send-many-head-requests + (cons (if (eq stream-type :header) header-stream stream) + (cdr last-command)))) + (ecase last-command-type + ((:list :article :body) + (write-nntp-command last-command stream :recover) + (process-status-response stream)) + ((:header-group :normal-group) + (write-nntp-command last-command stream :recover) + (write-nntp-command last-command header-stream :recover))))))) + +;;; DEF-NNTP-ERROR-HANDLER takes a code and a function and associates the two +;;; in *nntp-error-handlers*. If while PROCESSING a STATUS RESPONSE we come +;;; across one of these error codes, then FUNCALL the appropriate handler. +;;; +(defun def-nntp-error-handler (code function) + (pushnew (cons (format nil "~D" code) function) *nntp-error-handlers*)) + +;;; 503 is an NNTP timeout. The code I wrote reconnects and recovers +;;; completely. +;;; +(def-nntp-error-handler 503 #'(lambda (note) + (funcall *nntp-timeout-handler* note))) + +;;; 400 means NNTP is cutting us of for some reason. There is really nothing +;;; we can do. +;;; +(def-nntp-error-handler 400 #'(lambda (ignore) + (declare (ignore ignore)) + (editor-error "NNTP discontinued service. ~ + You should probably quit netnews and try ~ + again later."))) + +;;; Some functions just need to know that something went wrong so they can +;;; do something about it, so let them know by returning nil. +;;; +;;; 411 - The group you tried to read is not a netnews group. +;;; 423 - You requested a message that wasn't really there. +;;; 440 - Posting is not allowed. +;;; 441 - Posting is allowed, but the attempt failed for some other reason. +;;; +(flet ((nil-function (ignore) + (declare (ignore ignore)) + nil)) + (def-nntp-error-handler 423 #'nil-function) + (def-nntp-error-handler 411 #'nil-function) + (def-nntp-error-handler 440 #'nil-function) + (def-nntp-error-handler 441 #'nil-function)) + + + + +;;;; Implementation of NNTP response argument parsing. + +;;; DEF-NNTP-ARG-PARSER returns a form that parses a string for arguments +;;; corresponding to each element of types. For instance, if types is +;;; (:integer :string :integer :integer), this function returns a form that +;;; parses an integer, a string, and two more integers out of an nntp status +;;; response. +;;; +(defmacro def-nntp-arg-parser (types) + (let ((form (gensym)) + (start (gensym)) + (res nil)) + (do ((type types (cdr type))) + ((endp type) form) + (ecase (car type) + (:integer + (push `(parse-integer string :start ,start + :end (setf ,start + (position #\space string + :start (1+ ,start))) + :junk-allowed t) + res)) + (:string + (push `(subseq string (1+ ,start) + (position #\space string + :start (setf ,start (1+ ,start)))) + res)))) + `(let ((,start (position #\space string))) + (values ,@(nreverse res))))) + +(defun def-nntp-xhdr-arg-parser (string) + (let ((position (position #\space string))) + (values (subseq string (1+ position)) + (parse-integer string :start 0 :end position)))) + +(defun xhdr-response-args (string) + (def-nntp-xhdr-arg-parser string)) + +;;; GROUP-RESPONSE-ARGS, ARTICLER-RESPONSE-ARGS, HEAD-RESPONSE-ARGS, +;;; BODY-RESPONSE-ARGS, and STAT-RESPONSE-ARGS define NNTP argument parsers +;;; for the types of arguments each command will return. +;;; +(defun group-response-args (string) + "Group response args are an estimate of how many messages there are, the + number of the first message, the number of the last message, and \"y\" + or \"n\", indicating whether the user has rights to post in this group." + (def-nntp-arg-parser (:integer :integer :integer))) + +(defun list-response-args (string) + (def-nntp-arg-parser (:integer :integer))) + +(defun article-response-args (string) + "Article response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + +(defun head-response-args (string) + "Head response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + +(defun body-response-args (string) + "Body response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + +(defun stat-response-args (string) + "Stat response args are the message number and the message ID." + (def-nntp-arg-parser (:integer :string))) + + + + +;;;; Functions that send standard NNTP commands. + +;;; NNTP-XHDR sends an XHDR command to the NNTP server. We think this is a +;;; local extension, but not using it is not pragmatic. It takes over three +;;; minutes to HEAD every message in a newsgroup. +;;; +(defun nntp-xhdr (field start end stream) + (write-nntp-command (format nil "xhdr ~A ~D-~D" + field + (if (numberp start) start (parse-integer start)) + (if (numberp end) end (parse-integer end))) + stream + :xhdr)) + +(defun nntp-group (group-name stream header-stream) + (let ((command (concatenate 'simple-string "group " group-name))) + (write-nntp-command command stream :normal-group) + (write-nntp-command command header-stream :header-group))) + +(defun nntp-list (stream) + (write-nntp-command "list" stream :list)) + +(defun nntp-head (article stream) + (write-nntp-command (format nil "head ~D" article) stream :head)) + +(defun nntp-article (number stream) + (write-nntp-command (format nil "article ~D" number) stream :article)) + +(defun nntp-body (number stream) + (write-nntp-command (format nil "body ~D" number) stream :body)) + +(defun nntp-post (stream) + (write-nntp-command "post" stream :post)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/overwrite.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/overwrite.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/overwrite.lisp (revision 8058) @@ -0,0 +1,65 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock) + + +(defmode "Overwrite") + + +(defcommand "Overwrite Mode" (p) + "Printing characters overwrite characters instead of pushing them to the right. + A positive argument turns Overwrite mode on, while zero or a negative + argument turns it off. With no arguments, it is toggled. Use C-Q to + insert characters normally." + "Determine if in Overwrite mode or not and set the mode accordingly." + (setf (buffer-minor-mode (current-buffer) "Overwrite") + (if p + (plusp p) + (not (buffer-minor-mode (current-buffer) "Overwrite"))))) + + +(defcommand "Self Overwrite" (p) + "Replace the next character with the last character typed, + but insert at end of line. With prefix argument, do it that many times." + "Implements ``Self Overwrite'', calling this function is not meaningful." + (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)) + (point (current-point))) + (unless char (editor-error "Can't insert that character.")) + (do ((n (or p 1) (1- n))) + ((zerop n)) + (case (next-character point) + (#\tab + (let ((col1 (mark-column point)) + (col2 (mark-column (mark-after point)))) + (if (= (- col2 col1) 1) + (setf (previous-character point) char) + (insert-character (mark-before point) char)))) + ((#\newline nil) (insert-character point char)) + (t (setf (next-character point) char) + (mark-after point)))))) + + +(defcommand "Overwrite Delete Previous Character" (p) + "Replaces previous character with space, but tabs and newlines are deleted. + With prefix argument, do it that many times." + "Replaces previous character with space, but tabs and newlines are deleted." + (do ((point (current-point)) + (n (or p 1) (1- n))) + ((zerop n)) + (case (previous-character point) + ((#\newline #\tab) (delete-characters point -1)) + ((nil) (editor-error)) + (t (setf (previous-character point) #\space) + (mark-before point))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/pascal.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/pascal.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/pascal.lisp (revision 8058) @@ -0,0 +1,46 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Just barely enough to be a Pascal/C mode. Maybe more some day. +;;; +(in-package :hemlock) + +(defmode "Pascal" :major-p t) +(defcommand "Pascal Mode" (p) + "Put the current buffer into \"Pascal\" mode." + "Put the current buffer into \"Pascal\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Pascal")) + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It must take one argument that is the prefix argument." + :value #'generic-indent + :mode "Pascal") + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\"." + :mode "Pascal" :value t) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :mode "Pascal" :value "(*") + +(defhvar "Comment End" + "String that ends comments. Nil indicates #\newline termination." + :mode "Pascal" :value " *)") + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :mode "Pascal" :value "(* ") + +(shadow-attribute :scribe-syntax #\< nil "Pascal") Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/rcs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/rcs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/rcs.lisp (revision 8058) @@ -0,0 +1,526 @@ +;;; -*- Package: HEMLOCK; Mode: Lisp -*- +;;; +;;; $Header$ +;;; +;;; Various commands for dealing with RCS under Hemlock. +;;; +;;; Written by William Lott and Christopher Hoover. +;;; +(in-package :hemlock) + + + +;;;; + +(defun current-buffer-pathname () + (let ((pathname (buffer-pathname (current-buffer)))) + (unless pathname + (editor-error "The buffer has no pathname.")) + pathname)) + + +(defmacro in-directory (directory &body forms) + (let ((cwd (gensym))) + `(let ((,cwd (ext:default-directory))) + (unwind-protect + (progn + (setf (ext:default-directory) (directory-namestring ,directory)) + ,@forms) + (setf (ext:default-directory) ,cwd))))) + + +(defvar *last-rcs-command-name* nil) +(defvar *last-rcs-command-output-string* nil) +(defvar *rcs-output-stream* (make-string-output-stream)) + +(defmacro do-command (command &rest args) + `(progn + (setf *last-rcs-command-name* ',command) + (get-output-stream-string *rcs-output-stream*) + (let ((process (ext:run-program ',command ,@args + :error *rcs-output-stream*))) + (setf *last-rcs-command-output-string* + (get-output-stream-string *rcs-output-stream*)) + (case (ext:process-status process) + (:exited + (unless (zerop (ext:process-exit-code process)) + (editor-error "~A aborted with an error; ~ + use the ``RCS Last Command Output'' command for ~ + more information" ',command))) + (:signaled + (editor-error "~A killed with signal ~A~@[ (core dumped)]." + ',command + (ext:process-exit-code process) + (ext:process-core-dumped process))) + (t + (editor-error "~S still alive?" process)))))) + +(defun buffer-different-from-file (buffer filename) + (with-open-file (file filename) + (do ((buffer-line (mark-line (buffer-start-mark buffer)) + (line-next buffer-line)) + (file-line (read-line file nil nil) + (read-line file nil nil))) + ((and (or (null buffer-line) + (zerop (line-length buffer-line))) + (null file-line)) + nil) + (when (or (null buffer-line) + (null file-line) + (string/= (line-string buffer-line) file-line)) + (return t))))) + +(defun turn-auto-save-off (buffer) + (setf (buffer-minor-mode buffer "Save") nil) + ;; + ;; William's personal hack + (when (getstring "Ckp" *mode-names*) + (setf (buffer-minor-mode buffer "Ckp") nil))) + + +(defhvar "RCS Lock File Hook" + "RCS Lock File Hook" + :value nil) + +(defun rcs-lock-file (buffer pathname) + (message "Locking ~A ..." (namestring pathname)) + (in-directory pathname + (let ((file (file-namestring pathname))) + (do-command "rcs" `("-l" ,file)) + (multiple-value-bind (won dev ino mode) (unix:unix-stat file) + (declare (ignore ino)) + (cond (won + (unix:unix-chmod file (logior mode unix:writeown))) + (t + (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A" + (unix:get-unix-error-msg dev))))))) + (invoke-hook rcs-lock-file-hook buffer pathname)) + + +(defhvar "RCS Unlock File Hook" + "RCS Unlock File Hook" + :value nil) + +(defun rcs-unlock-file (buffer pathname) + (message "Unlocking ~A ..." (namestring pathname)) + (in-directory pathname + (do-command "rcs" `("-u" ,(file-namestring pathname)))) + (invoke-hook rcs-unlock-file-hook buffer pathname)) + + + +;;;; Check In + +(defhvar "RCS Check In File Hook" + "RCS Check In File Hook" + :value nil) + +(defhvar "RCS Keep Around After Unlocking" + "If non-NIL (the default) keep the working file around after unlocking it. + When NIL, the working file and buffer are deleted." + :value t) + +(defun rcs-check-in-file (buffer pathname keep-lock) + (let ((old-buffer (current-buffer)) + (allow-delete nil) + (log-buffer nil)) + (unwind-protect + (when (block in-recursive-edit + (do ((i 0 (1+ i))) + ((not (null log-buffer))) + (setf log-buffer + (make-buffer + (format nil "RCS Log Entry ~D for ~S" i + (file-namestring pathname)) + :modes '("Text") + :delete-hook + (list #'(lambda (buffer) + (declare (ignore buffer)) + (unless allow-delete + (return-from in-recursive-edit t))))))) + (turn-auto-save-off log-buffer) + (change-to-buffer log-buffer) + (do-recursive-edit) + + (message "Checking in ~A~:[~; keeping the lock~] ..." + (namestring pathname) keep-lock) + (let ((log-stream (make-hemlock-region-stream + (buffer-region log-buffer)))) + (sub-check-in-file pathname buffer keep-lock log-stream)) + (invoke-hook rcs-check-in-file-hook buffer pathname) + nil) + (editor-error "Someone deleted the RCS Log Entry buffer.")) + (when (member old-buffer *buffer-list*) + (change-to-buffer old-buffer)) + (setf allow-delete t) + (delete-buffer-if-possible log-buffer)))) + +(defun sub-check-in-file (pathname buffer keep-lock log-stream) + (let* ((filename (file-namestring pathname)) + (rcs-filename (concatenate 'simple-string + "./RCS/" filename ",v")) + (keep-working-copy (or keep-lock + (not (hemlock-bound-p + 'rcs-keep-around-after-unlocking + :buffer buffer)) + (variable-value + 'rcs-keep-around-after-unlocking + :buffer buffer)))) + (in-directory pathname + (do-command "ci" `(,@(if keep-lock '("-l")) + ,@(if keep-working-copy '("-u")) + ,filename) + :input log-stream) + (if keep-working-copy + ;; + ;; Set the times on the user's file to be equivalent to that of + ;; the rcs file. + #-(or hpux svr4) + (multiple-value-bind + (dev ino mode nlink uid gid rdev size atime mtime) + (unix:unix-stat rcs-filename) + (declare (ignore mode nlink uid gid rdev size)) + (cond (dev + (multiple-value-bind + (wonp errno) + (unix:unix-utimes filename atime 0 mtime 0) + (unless wonp + (editor-error "UNIX:UNIX-UTIMES failed: ~A" + (unix:get-unix-error-msg errno))))) + (t + (editor-error "UNIX:UNIX-STAT failed: ~A" + (unix:get-unix-error-msg ino))))) + (delete-buffer-if-possible buffer))))) + + + + +;;;; Check Out + +(defhvar "RCS Check Out File Hook" + "RCS Check Out File Hook" + :value nil) + +(defvar *translate-file-names-before-locking* nil) + +(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p) + (when (and lock *translate-file-names-before-locking*) + (multiple-value-bind (unmatched-dir new-dirs file-name) + (maybe-translate-definition-file pathname) + (when new-dirs + (let ((new-name (translate-definition-file unmatched-dir + (car new-dirs) + file-name))) + (when (probe-file (directory-namestring new-name)) + (setf pathname new-name)))))) + (cond + ((and (not always-overwrite-p) + (let ((pn (probe-file pathname))) + (and pn (hemlock-ext:file-writable pn)))) + ;; File exists and is writable so check and see if the user really + ;; wants to check it out. + (command-case (:prompt + (format nil "The file ~A is writable. Overwrite? " + (file-namestring pathname)) + :help + "Type one of the following single-character commands:") + ((:yes :confirm) + "Overwrite the file." + (rcs-check-out-file buffer pathname lock)) + (:no + "Don't check it out after all.") + ((#\r #\R) + "Rename the file before checking it out." + (let ((new-pathname (prompt-for-file + :prompt "New Filename: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + (rename-file pathname new-pathname) + (rcs-check-out-file buffer pathname lock))))) + (t + (rcs-check-out-file buffer pathname lock))) + pathname) + +(defun rcs-check-out-file (buffer pathname lock) + (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock) + (in-directory pathname + (let* ((file (file-namestring pathname)) + (backup (if (probe-file file) + (lisp::pick-backup-name file)))) + (when backup (rename-file file backup)) + (do-command "co" `(,@(if lock '("-l")) ,file)) + (invoke-hook rcs-check-out-file-hook buffer pathname) + (when backup (delete-file backup))))) + + + +;;;; Last Command Output + +(defcommand "RCS Last Command Output" (p) + "Print the full output of the last RCS command." + "Print the full output of the last RCS command." + (declare (ignore p)) + (unless (and *last-rcs-command-name* *last-rcs-command-output-string*) + (editor-error "No RCS commands have executed!")) + (with-pop-up-display (s :buffer-name "*RCS Command Output*") + (format s "Output from ``~A'':~%~%" *last-rcs-command-name*) + (write-line *last-rcs-command-output-string* s))) + + + +;;;; Commands for Checking In / Checking Out and Locking / Unlocking + +(defun pick-temp-file (defaults) + (let ((index 0)) + (loop + (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults))) + (cond ((probe-file name) + (incf index)) + (t + (return name))))))) + +(defcommand "RCS Lock Buffer File" (p) + "Attempt to lock the file in the current buffer." + "Attempt to lock the file in the current buffer." + (declare (ignore p)) + (let ((file (current-buffer-pathname)) + (buffer (current-buffer)) + (name (pick-temp-file "/tmp/"))) + (rcs-lock-file buffer file) + (unwind-protect + (progn + (in-directory file + (do-command "co" `("-p" ,(file-namestring file)) + :output (namestring name))) + (when (buffer-different-from-file buffer name) + (message + "RCS file is different; be sure to merge in your changes.")) + (setf (buffer-writable buffer) t) + (message "Buffer is now writable.")) + (when (probe-file name) + (delete-file name))))) + +(defcommand "RCS Lock File" (p) + "Prompt for a file, and attempt to lock it." + "Prompt for a file, and attempt to lock it." + (declare (ignore p)) + (rcs-lock-file nil (prompt-for-file :prompt "File to lock: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + +(defcommand "RCS Unlock Buffer File" (p) + "Unlock the file in the current buffer." + "Unlock the file in the current buffer." + (declare (ignore p)) + (rcs-unlock-file (current-buffer) (current-buffer-pathname)) + (setf (buffer-writable (current-buffer)) nil) + (message "Buffer is no longer writable.")) + +(defcommand "RCS Unlock File" (p) + "Prompt for a file, and attempt to unlock it." + "Prompt for a file, and attempt to unlock it." + (declare (ignore p)) + (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + +(defcommand "RCS Check In Buffer File" (p) + "Checkin the file in the current buffer. With an argument, do not + release the lock." + "Checkin the file in the current buffer. With an argument, do not + release the lock." + (let ((buffer (current-buffer)) + (pathname (current-buffer-pathname))) + (when (buffer-modified buffer) + (save-file-command nil)) + (rcs-check-in-file buffer pathname p) + (when (member buffer *buffer-list*) + ;; If the buffer has not been deleted, make sure it is up to date + ;; with respect to the file. + (visit-file-command nil pathname buffer)))) + +(defcommand "RCS Check In File" (p) + "Prompt for a file, and attempt to check it in. With an argument, do + not release the lock." + "Prompt for a file, and attempt to check it in. With an argument, do + not release the lock." + (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: " + :default + (buffer-default-pathname + (current-buffer)) + :must-exist nil) + p)) + +(defcommand "RCS Check Out Buffer File" (p) + "Checkout the file in the current buffer. With an argument, lock the + file." + "Checkout the file in the current buffer. With an argument, lock the + file." + (let* ((buffer (current-buffer)) + (pathname (current-buffer-pathname)) + (point (current-point)) + (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) + (when (buffer-modified buffer) + (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? ")) + (editor-error "Aborted."))) + (setf (buffer-modified buffer) nil) + (setf pathname (maybe-rcs-check-out-file buffer pathname p nil)) + (when p + (setf (buffer-writable buffer) t) + (message "Buffer is now writable.")) + (visit-file-command nil pathname) + (unless (line-offset point lines) + (buffer-end point)))) + +(defcommand "RCS Check Out File" (p) + "Prompt for a file and attempt to check it out. With an argument, + lock the file." + "Prompt for a file and attempt to check it out. With an argument, + lock the file." + (let ((pathname (prompt-for-file :prompt "File to check out: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil))) + (setf pathname (maybe-rcs-check-out-file nil pathname p nil)) + (find-file-command nil pathname))) + + + +;;;; Log File + +(defhvar "RCS Log Entry Buffer" + "Name of the buffer to put RCS log entries into." + :value "RCS Log") + +(defhvar "RCS Log Buffer Hook" + "RCS Log Buffer Hook" + :value nil) + +(defun get-log-buffer () + (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*))) + (unless buffer + (setf buffer (make-buffer (value rcs-log-entry-buffer))) + (turn-auto-save-off buffer) + (invoke-hook rcs-log-buffer-hook buffer)) + buffer)) + +(defcommand "RCS Buffer File Log Entry" (p) + "Get the RCS Log for the file in the current buffer in a buffer." + "Get the RCS Log for the file in the current buffer in a buffer." + (declare (ignore p)) + (let ((buffer (get-log-buffer)) + (pathname (current-buffer-pathname))) + (delete-region (buffer-region buffer)) + (message "Extracting log info ...") + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (in-directory pathname + (do-command "rlog" (list (file-namestring pathname)) + :output (make-hemlock-output-stream mark)))) + (change-to-buffer buffer) + (buffer-start (current-point)) + (setf (buffer-modified buffer) nil))) + +(defcommand "RCS File Log Entry" (p) + "Prompt for a file and get its RCS log entry in a buffer." + "Prompt for a file and get its RCS log entry in a buffer." + (declare (ignore p)) + (let ((file (prompt-for-file :prompt "File to get log of: " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil)) + (buffer (get-log-buffer))) + (delete-region (buffer-region buffer)) + (message "Extracing log info ...") + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (in-directory file + (do-command "rlog" (list (file-namestring file)) + :output (make-hemlock-output-stream mark)))) + (change-to-buffer buffer) + (buffer-start (current-point)) + (setf (buffer-modified buffer) nil))) + + + +;;;; Status and Modeline Frobs. + +(defhvar "RCS Status" + "RCS status of this buffer. Either nil, :locked, :out-of-date, or + :unlocked." + :value nil) + +;;; +;;; Note: This doesn't behave correctly w/r/t to branched files. +;;; +(defun rcs-file-status (pathname) + (let* ((directory (directory-namestring pathname)) + (filename (file-namestring pathname)) + (rcs-file (concatenate 'simple-string directory + "RCS/" filename ",v"))) + (if (probe-file rcs-file) + ;; This is an RCS file + (let ((probe-file (probe-file pathname))) + (cond ((and probe-file (hemlock-ext:file-writable probe-file)) + :locked) + ((or (not probe-file) + (< (file-write-date pathname) + (file-write-date rcs-file))) + :out-of-date) + (t + :unlocked)))))) + +(defun rcs-update-buffer-status (buffer &optional tn) + (unless (hemlock-bound-p 'rcs-status :buffer buffer) + (defhvar "RCS Status" + "RCS Status of this buffer." + :buffer buffer + :value nil)) + (let ((tn (or tn (buffer-pathname buffer)))) + (setf (variable-value 'rcs-status :buffer buffer) + (if tn (rcs-file-status tn)))) + (hi::update-modelines-for-buffer buffer)) +;;; +(add-hook read-file-hook 'rcs-update-buffer-status) +(add-hook write-file-hook 'rcs-update-buffer-status) + +(defcommand "RCS Update All RCS Status Variables" (p) + "Update the ``RCS Status'' variable for all buffers." + "Update the ``RCS Status'' variable for all buffers." + (declare (ignore p)) + (dolist (buffer *buffer-list*) + (rcs-update-buffer-status buffer)) + (dolist (window *window-list*) + (update-modeline-fields (window-buffer window) window))) + +;;; +;;; Action Hooks +(defun rcs-action-hook (buffer pathname) + (cond (buffer + (rcs-update-buffer-status buffer)) + (t + (let ((pathname (probe-file pathname))) + (when pathname + (dolist (buffer *buffer-list*) + (let ((buffer-pathname (buffer-pathname buffer))) + (when (equal pathname buffer-pathname) + (rcs-update-buffer-status buffer))))))))) +;;; +(add-hook rcs-check-in-file-hook 'rcs-action-hook) +(add-hook rcs-check-out-file-hook 'rcs-action-hook) +(add-hook rcs-lock-file-hook 'rcs-action-hook) +(add-hook rcs-unlock-file-hook 'rcs-action-hook) + + +;;; +;;; RCS Modeline Field +(make-modeline-field + :name :rcs-status + :function #'(lambda (buffer window) + (declare (ignore buffer window)) + (ecase (value rcs-status) + (:out-of-date "[OLD] ") + (:locked "[LOCKED] ") + (:unlocked "[RCS] ") + ((nil) "")))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/screen.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/screen.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/screen.lisp (revision 8058) @@ -0,0 +1,204 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; +;;; Device independent screen management functions. +;;; + +(in-package :hemlock-internals) + + + +;;;; Screen management initialization. + +(declaim (special *echo-area-buffer*)) + +;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data +;;; structures used by the screen manager. The "Main" and "Echo Area" buffer +;;; modelines are set here in case the user modified these Hemlock variables in +;;; his init file. Since these buffers don't have windows yet, these sets +;;; won't cause any updates to occur. This is called from %INIT-REDISPLAY. +;;; +(defun %init-screen-manager (display) + (setf (buffer-modeline-fields *current-buffer*) + (value hemlock::default-modeline-fields)) + (setf (buffer-modeline-fields *echo-area-buffer*) + (value hemlock::default-status-line-fields)) + (if (windowed-monitor-p) + (init-bitmap-screen-manager display) + (init-tty-screen-manager (get-terminal-name)))) + + + + +;;;; Window operations. + +(defun make-window (start &key (modelinep t) (device nil) window + (proportion .5) + (font-family *default-font-family*) + (ask-user nil) x y + (width (value hemlock::default-window-width)) + (height (value hemlock::default-window-height))) + "Make a window that displays text starting at the mark start. The default + action is to make the new window a proportion of the current window's height + to make room for the new window. + + Proportion determines what proportion of the current window's height + the new window will use. The current window retains whatever space left + after accommodating the new one. The default is to split the current window + in half. + + Modelinep specifies whether the window should display buffer modelines. + + Device is the Hemlock device to make the window on. If it is nil, then + the window is made on the same device as CURRENT-WINDOW. + + Window is an X window to be used with the Hemlock window. The supplied + window becomes the parent window for a new group of windows that behave + in a stack orientation as windows do on the terminal. + + Font-Family is the font-family used for displaying text in the window. + + If Ask-User is non-nil, Hemlock prompts the user for missing X, Y, Width, + and Height arguments to make a new group of windows that behave in a stack + orientation as windows do on the terminal. This occurs by invoking + hi::*create-window-hook*. X and Y are supplied as pixels, but Width and + Height are supplied in characters." + + (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) + (window (funcall (device-make-window device) + device start modelinep window font-family + ask-user x y width height proportion))) + (unless window (editor-error "Could not make a window.")) + (invoke-hook hemlock::make-window-hook window) + window)) + +(defun delete-window (window) + "Make Window go away, removing it from the screen. This uses + hi::*delete-window-hook* to get rid of parent windows on a bitmap device + when you delete the last Hemlock window in a group." + (when (<= (length *window-list*) 2) + (error "Cannot kill the only window.")) + (invoke-hook hemlock::delete-window-hook window) + (setq *window-list* (delq window *window-list*)) + (funcall (device-delete-window (device-hunk-device (window-hunk window))) + window) + ;; + ;; Since the programmer's interface fails to allow users to determine if + ;; they're commands delete the current window, this primitive needs to + ;; make sure Hemlock doesn't get screwed. This inadequacy comes from the + ;; bitmap window groups and the vague descriptions of PREVIOUS-WINDOW and + ;; NEXT-WINDOW. + (when (eq window *current-window*) + (let ((window (find-if-not #'(lambda (w) (eq w *echo-area-window*)) + *window-list*))) + (setf (current-buffer) (window-buffer window) + (current-window) window)))) + +(defun next-window (window) + "Return the next window after Window, wrapping around if Window is the + bottom window." + (check-type window window) + (funcall (device-next-window (device-hunk-device (window-hunk window))) + window)) + +(defun previous-window (window) + "Return the previous window after Window, wrapping around if Window is the + top window." + (check-type window window) + (funcall (device-previous-window (device-hunk-device (window-hunk window))) + window)) + + + + +;;;; Random typeout support. + +;;; PREPARE-FOR-RANDOM-TYPEOUT -- Internal +;;; +;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output +;;; for the user. This goes to some effor to compute the height of the window +;;; in text lines if it is not supplied. Whether it is supplied or not, we +;;; add one to the height for the modeline, and we subtract one line if the +;;; last line is empty. Just before using the height, make sure it is at +;;; least two -- one for the modeline and one for text, so window making +;;; primitives don't puke. +;;; +(defun prepare-for-random-typeout (stream height) + (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream)))) + (real-height (1+ (or height (rt-count-lines buffer)))) + (device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-random-typeout-setup device) device stream + (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height)) + (1- real-height) + real-height) + 2)))) + +;;; RT-COUNT-LINES computes the correct height for a window. This includes +;;; taking wrapping line characters into account. Take the MARK-COLUMN at +;;; the end of each line. This is how many characters long hemlock thinks +;;; the line is. When it is displayed, however, end of line characters are +;;; added to the end of each line that wraps. The second INCF form adds +;;; these to the current line length. Then INCF the current height by the +;;; CEILING of the width of the random typeout window and the line length +;;; (with added line-end chars). Use CEILING because there is always at +;;; least one line. Finally, jump out of the loop if we're at the end of +;;; the buffer. +;;; +(defun rt-count-lines (buffer) + (with-mark ((mark (buffer-start-mark buffer))) + (let ((width (window-width (current-window))) + (count 0)) + (loop + (let* ((column (mark-column (line-end mark))) + (temp (ceiling (incf column (floor (1- column) width)) + width))) + ;; Lines with no characters yield zero temp. + (incf count (if (zerop temp) 1 temp)) + (unless (line-offset mark 1) (return count))))))) + + +;;; RANDOM-TYPEOUT-CLEANUP -- Internal +;;; +;;; Clean up after random typeout. This clears the area where the +;;; random typeout was and redisplays any affected windows. +;;; +(defun random-typeout-cleanup (stream &optional (degree t)) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (device (device-hunk-device (window-hunk window))) + (*more-prompt-action* :normal)) + (update-modeline-field buffer window :more-prompt) + (random-typeout-redisplay window) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) + (funcall (device-random-typeout-cleanup device) stream degree) + (when (device-force-output device) + (funcall (device-force-output device))))) + +;;; *more-prompt-action* is bound in random typeout streams before +;;; redisplaying. +;;; +(defvar *more-prompt-action* :normal) +(defvar *random-typeout-ml-fields* + (list (make-modeline-field + :name :more-prompt + :function #'(lambda (buffer window) + (declare (ignore window)) + (ecase *more-prompt-action* + (:more "--More--") + (:flush "--Flush--") + (:empty "") + (:normal + (concatenate 'simple-string + "Random Typeout Buffer [" + (buffer-name buffer) + "]"))))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/scribe.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/scribe.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/scribe.lisp (revision 8058) @@ -0,0 +1,501 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; + +(in-package :hemlock) + + + +;;;; Variables. + +(defvar *scribe-para-break-table* (make-hash-table :test #'equal) + "A table of the Scribe commands that should be paragraph delimiters.") +;;; +(dolist (todo '("begin" "newpage" "make" "device" "caption" "tag" "end" + "chapter" "section" "appendix" "subsection" "paragraph" + "unnumbered" "appendixsection" "prefacesection" "heading" + "majorheading" "subheading")) + (setf (gethash todo *scribe-para-break-table*) t)) + +(defhvar "Open Paren Character" + "The open bracket inserted by Scribe commands." + :value #\[) + +(defhvar "Close Paren Character" + "The close bracket inserted by Scribe commands." + :value #\]) + +(defhvar "Escape Character" + "The escape character inserted by Scribe commands." + :value #\@) + +(defhvar "Scribe Bracket Table" + "This table maps a Scribe brackets, open and close, to their opposing + brackets." + :value (make-array char-code-limit)) +;;; +(mapc #'(lambda (x y) + (setf (svref (value scribe-bracket-table) (char-code x)) y) + (setf (svref (value scribe-bracket-table) (char-code y)) x)) + '(#\( #\[ #\{ #\<) '(#\) #\] #\} #\>)) +;;; +(defun opposing-bracket (bracket) + (svref (value scribe-bracket-table) (char-code bracket))) + + + + +;;;; "Scribe Syntax" Attribute. + +(defattribute "Scribe Syntax" + "For Scribe Syntax, Possible types are: + :ESCAPE ; basically #\@. + :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<. + :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>. + :SPACE ; Delimits end of a Scribe command. + :NEWLINE ; Delimits end of a Scribe command." + 'symbol nil) + +(setf (character-attribute :scribe-syntax #\)) :close-paren) +(setf (character-attribute :scribe-syntax #\]) :close-paren) +(setf (character-attribute :scribe-syntax #\}) :close-paren) +(setf (character-attribute :scribe-syntax #\>) :close-paren) + +(setf (character-attribute :scribe-syntax #\() :open-paren) +(setf (character-attribute :scribe-syntax #\[) :open-paren) +(setf (character-attribute :scribe-syntax #\{) :open-paren) +(setf (character-attribute :scribe-syntax #\<) :open-paren) + +(setf (character-attribute :scribe-syntax #\space) :space) +(setf (character-attribute :scribe-syntax #\newline) :newline) +(setf (character-attribute :scribe-syntax #\@) :escape) + + + + +;;;; "Scribe" mode and setup. + +(defmode "Scribe" :major-p t) + +(shadow-attribute :paragraph-delimiter #\@ 1 "Scribe") +(shadow-attribute :word-delimiter #\' 0 "Scribe") ;from Text Mode +(shadow-attribute :word-delimiter #\backspace 0 "Scribe") ;from Text Mode +(shadow-attribute :word-delimiter #\_ 0 "Scribe") ;from Text Mode + +(define-file-type-hook ("mss") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Scribe")) + + + + +;;;; Commands. + +(defcommand "Scribe Mode" (p) + "Puts buffer in Scribe mode. Sets up comment variables and has delimiter + matching. The definition of paragraphs is changed to know about scribe + commands." + "Puts buffer in Scribe mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Scribe")) + +(defcommand "Select Scribe Warnings" (p) + "Goes to the Scribe Warnings buffer if it exists." + "Goes to the Scribe Warnings buffer if it exists." + (declare (ignore p)) + (let ((buffer (getstring "Scribe Warnings" *buffer-names*))) + (if buffer + (change-to-buffer buffer) + (editor-error "There is no Scribe Warnings buffer.")))) + +(defcommand "Add Scribe Paragraph Delimiter" + (p &optional + (word (prompt-for-string + :prompt "Scribe command: " + :help "Name of Scribe command to make delimit paragraphs." + :trim t))) + "Prompts for a name to add to the table of commands that delimit paragraphs + in Scribe mode. If a prefix argument is supplied, then the command name is + removed from the table." + "Add or remove Word in the *scribe-para-break-table*, depending on P." + (setf (gethash word *scribe-para-break-table*) (not p))) + +(defcommand "List Scribe Paragraph Delimiters" (p) + "Pops up a display of the Scribe commands that delimit paragraphs." + "Pops up a display of the Scribe commands that delimit paragraphs." + (declare (ignore p)) + (let (result) + (maphash #'(lambda (k v) + (declare (ignore v)) + (push k result)) + *scribe-para-break-table*) + (setf result (sort result #'string<)) + (with-pop-up-display (s :height (length result)) + (dolist (ele result) (write-line ele s))))) + +(defcommand "Scribe Insert Bracket" (p) + "Inserts a the bracket it is bound to and then shows the matching bracket." + "Inserts a the bracket it is bound to and then shows the matching bracket." + (declare (ignore p)) + (scribe-insert-paren (current-point) + (hemlock-ext:key-event-char *last-key-event-typed*))) + + +(defhvar "Scribe Command Table" + "This is a character dispatching table indicating which Scribe command or + environment to use." + :value (make-hash-table) + :mode "Scribe") + +(defvar *scribe-directive-type-table* + (make-string-table :initial-contents + '(("Command" . :command) + ("Environment" . :environment)))) + +(defcommand "Add Scribe Directive" (p &optional + (command-name nil command-name-p) + type key-event mode) + "Adds a new scribe function to put into \"Scribe Command Table\"." + "Adds a new scribe function to put into \"Scribe Command Table\"." + (declare (ignore p)) + (let ((command-name (if command-name-p + command-name + (or command-name + (prompt-for-string :help "Directive Name" + :prompt "Directive: "))))) + (multiple-value-bind (ignore type) + (if type + (values nil type) + (prompt-for-keyword + (list *scribe-directive-type-table*) + :help "Enter Command or Environment." + :prompt "Command or Environment: ")) + (declare (ignore ignore)) + (let ((key-event (or key-event + (prompt-for-key-event :prompt + "Dispatch Character: ")))) + (setf (gethash key-event + (cond (mode + (variable-value 'scribe-command-table :mode mode)) + ((hemlock-bound-p 'scribe-command-table) + (value scribe-command-table)) + (t (editor-error + "Could not find \"Scribe Command Table\".")))) + (cons type command-name)))))) + +(defcommand "Insert Scribe Directive" (p) + "Prompts for a character to dispatch on. Some indicate \"commands\" versus + \"environments\". Commands are wrapped around the previous or current word. + If there is no previous word, the command is insert, leaving point between + the brackets. Environments are wrapped around the next or current + paragraph, but when the region is active, this wraps the environment around + the region. Each uses \"Open Paren Character\" and \"Close Paren + Character\"." + "Wrap some text with some stuff." + (declare (ignore p)) + (loop + (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: "))) + (if (logical-key-event-p key-event :help) + (directive-help) + (let ((table-entry (gethash key-event (value scribe-command-table)))) + (ecase (car table-entry) + (:command + (insert-scribe-directive (current-point) (cdr table-entry)) + (return)) + (:environment + (enclose-with-environment (current-point) (cdr table-entry)) + (return)) + ((nil) (editor-error "Unknown dispatch character.")))))))) + + + + +;;;; "Insert Scribe Directive" support. + +(defun directive-help () + (let ((commands ()) + (environments ())) + (declare (list commands environments)) + (maphash #'(lambda (k v) + (if (eql (car v) :command) + (push (cons k (cdr v)) commands) + (push (cons k (cdr v)) environments))) + (value scribe-command-table)) + (setf commands (sort commands #'string< :key #'cdr)) + (setf environments (sort environments #'string< :key #'cdr)) + (with-pop-up-display (s :height (1+ (max (length commands) + (length environments)))) + (format s "~2TCommands~47TEnvironments~%") + (do ((commands commands (rest commands)) + (environments environments (rest environments))) + ((and (endp commands) (endp environments))) + (let* ((command (first commands)) + (environment (first environments)) + (cmd-char (first command)) + (cmd-name (rest command)) + (env-char (first environment)) + (env-name (rest environment))) + (write-string " " s) + (when cmd-char + (hemlock-ext:print-pretty-key-event cmd-char s) + (format s "~7T") + (write-string (or cmd-name "") s)) + (when env-char + (format s "~47T") + (hemlock-ext:print-pretty-key-event env-char s) + (format s "~51T") + (write-string (or env-name "") s)) + (terpri s)))))) + +;;; +;;; Inserting and extending :command directives. +;;; + +(defhvar "Insert Scribe Directive Function" + "\"Insert Scribe Directive\" calls this function when the directive type + is :command. The function takes four arguments: a mark pointing to the word + start, the formatting command string, the open-paren character to use, and a + mark pointing to the word end." + :value 'scribe-insert-scribe-directive-fun + :mode "Scribe") + +(defun scribe-insert-scribe-directive-fun (word-start command-string + open-paren-char word-end) + (insert-character word-start (value escape-character)) + (insert-string word-start command-string) + (insert-character word-start open-paren-char) + (insert-character word-end (value close-paren-character))) + +(defhvar "Extend Scribe Directive Function" + "\"Insert Scribe Directive\" calls this function when the directive type is + :command to extend the the commands effect. This function takes a string + and three marks: the first on pointing before the open-paren character for + the directive. The string is the command-string to selected by the user + which this function uses to determine if it is actually extending a command + or inserting a new one. The function must move the first mark before any + command text for the directive and the second mark to the end of any command + text. It moves the third mark to the previous word's start where the + command region should be. If this returns non-nil \"Insert Scribe + Directive\" moves the command region previous one word, and otherwise it + inserts the directive." + :value 'scribe-extend-scribe-directive-fun + :mode "Scribe") + +(defun scribe-extend-scribe-directive-fun (command-string + command-end command-start word-start) + (word-offset (move-mark command-start command-end) -1) + (when (string= (the simple-string (region-to-string + (region command-start command-end))) + command-string) + (mark-before command-start) + (mark-after command-end) + (word-offset (move-mark word-start command-start) -1))) + +;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at +;;; mark. Word-p says if we found one. If mark is immediately before a word, +;;; we use that word instead of the previous. This is because if mark +;;; corresponds to the CURRENT-POINT, the Hemlock cursor is displayed on the +;;; first character of the word making users think the mark is in the word +;;; instead of before it. If we find a word, then we see if it already has +;;; the given command-string, and if it does, we extend the use of the command- +;;; string to the previous word. At the end, if we hadn't found a word, we +;;; backup the mark one character to put it between the command brackets. +;;; +(defun insert-scribe-directive (mark &optional command-string) + (with-mark ((word-start mark :left-inserting) + (word-end mark :left-inserting)) + (let ((open-paren-char (value open-paren-character)) + (word-p (if (and (zerop (character-attribute + :word-delimiter + (next-character word-start))) + (= (character-attribute + :word-delimiter + (previous-character word-start)) + 1)) + word-start + (word-offset word-start -1))) + (command-string (or command-string + (prompt-for-string + :trim t :prompt "Environment: " + :help "Name of environment to enclose with.")))) + (declare (simple-string command-string)) + (cond + (word-p + (word-offset (move-mark word-end word-start) 1) + (if (test-char (next-character word-end) :scribe-syntax + :close-paren) + (with-mark ((command-start word-start :left-inserting) + (command-end word-end :left-inserting)) + ;; Move command-end from word-end to open-paren of command. + (balance-paren (mark-after command-end)) + (if (funcall (value extend-scribe-directive-function) + command-string command-end command-start word-start) + (let ((region (delete-and-save-region + (region command-start command-end)))) + (word-offset (move-mark word-start command-start) -1) + (ninsert-region word-start region)) + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char + word-end))) + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char word-end))) + (t + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char word-end) + (mark-before mark)))))) + +;;; +;;; Inserting :environment directives. +;;; + +(defun enclose-with-environment (mark &optional environment) + (if (region-active-p) + (let ((region (current-region))) + (with-mark ((top (region-start region) :left-inserting) + (bottom (region-end region) :left-inserting)) + (get-and-insert-environment top bottom environment))) + (with-mark ((bottom-mark mark :left-inserting)) + (let ((paragraphp (paragraph-offset bottom-mark 1))) + (unless (or paragraphp + (and (last-line-p bottom-mark) + (end-line-p bottom-mark) + (not (blank-line-p (mark-line bottom-mark))))) + (editor-error "No paragraph to enclose.")) + (with-mark ((top-mark bottom-mark :left-inserting)) + (paragraph-offset top-mark -1) + (cond ((not (blank-line-p (mark-line top-mark))) + (insert-character top-mark #\Newline) + (mark-before top-mark)) + (t + (insert-character top-mark #\Newline))) + (cond ((and (last-line-p bottom-mark) + (not (blank-line-p (mark-line bottom-mark)))) + (insert-character bottom-mark #\Newline)) + (t + (insert-character bottom-mark #\Newline) + (mark-before bottom-mark))) + (get-and-insert-environment top-mark bottom-mark environment)))))) + +(defun get-and-insert-environment (top-mark bottom-mark environment) + (let ((environment (or environment + (prompt-for-string + :trim t :prompt "Environment: " + :help "Name of environment to enclose with.")))) + (insert-environment top-mark "begin" environment) + (insert-environment bottom-mark "end" environment))) + +(defun insert-environment (mark command environment) + (let ((esc-char (value escape-character)) + (open-paren (value open-paren-character)) + (close-paren (value close-paren-character))) + (insert-character mark esc-char) + (insert-string mark command) + (insert-character mark open-paren) + (insert-string mark environment) + (insert-character mark close-paren))) + + +(add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe") +(add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe") +(add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe") +(add-scribe-directive-command nil "End" :Command #k"e" "Scribe") +(add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe") +(add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe") +(add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe") +(add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe") +(add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe") +(add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe") +(add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe") +(add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe") +(add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe") +(add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe") +(add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe") +(add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe") +(add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe") +(add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe") +(add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe") +(add-scribe-directive-command nil "i" :Command #k"i" "Scribe") +(add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe") +(add-scribe-directive-command nil "-" :Command #k"\-" "Scribe") +(add-scribe-directive-command nil "+" :Command #k"+" "Scribe") +(add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe") +(add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe") +(add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe") +(add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe") +(add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe") +(add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe") +(add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe") +(add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe") + + + + +;;;; Scribe paragraph delimiter function. + +(defhvar "Paragraph Delimiter Function" + "Scribe Mode's way of delimiting paragraphs." + :mode "Scribe" + :value 'scribe-delim-para-function) + +(defun scribe-delim-para-function (mark) + "Returns whether there is a paragraph delimiting Scribe command on the + current line. Add or remove commands for this purpose with the command + \"Add Scribe Paragraph Delimiter\"." + (let ((next-char (next-character mark))) + (when (paragraph-delimiter-attribute-p next-char) + (if (eq (character-attribute :scribe-syntax next-char) :escape) + (with-mark ((begin mark) + (end mark)) + (mark-after begin) + (if (scan-char end :scribe-syntax (or :space :newline :open-paren)) + (gethash (nstring-downcase (region-to-string (region begin end))) + *scribe-para-break-table*) + (editor-error "Unable to find Scribe command ending."))) + t)))) + + + + +;;;; Bracket matching. + +(defun scribe-insert-paren (mark bracket-char) + (insert-character mark bracket-char) + (with-mark ((m mark)) + (if (balance-paren m) + (when (value paren-pause-period) + (unless (show-mark m (current-window) (value paren-pause-period)) + (clear-echo-area) + (message "~A" (line-string (mark-line m))))) + (editor-error)))) + +;;; BALANCE-PAREN moves the mark to the matching open paren character, or +;;; returns nil. The mark must be after the closing paren. +;;; +(defun balance-paren (mark) + (with-mark ((m mark)) + (when (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) + (mark-before m) + (let ((paren-count 1) + (first-paren (next-character m))) + (loop + (unless (rev-scan-char m :scribe-syntax (or :open-paren :close-paren)) + (return nil)) + (if (test-char (previous-character m) :scribe-syntax :open-paren) + (setq paren-count (1- paren-count)) + (setq paren-count (1+ paren-count))) + (when (< paren-count 0) (return nil)) + (when (= paren-count 0) + ;; OPPOSING-BRACKET calls VALUE (each time around the loop) + (cond ((char= (opposing-bracket (previous-character m)) first-paren) + (mark-before (move-mark mark m)) + (return t)) + (t (editor-error "Scribe paren mismatch.")))) + (mark-before m)))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/shell.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/shell.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/shell.lisp (revision 8058) @@ -0,0 +1,558 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Hemlock command level support for processes. +;;; +;;; Written by Blaine Burks. +;;; + +(in-package :hemlock) + + +(defun setup-process-buffer (buffer) + (let ((mark (copy-mark (buffer-point buffer) :right-inserting))) + (defhvar "Buffer Input Mark" + "The buffer input mark for this buffer." + :buffer buffer + :value mark) + (defhvar "Process Output Stream" + "The process structure for this buffer." + :buffer buffer + :value (make-hemlock-output-stream mark :full)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (unless (buffer-modeline-field-p buffer :process-status) + (setf (buffer-modeline-fields buffer) + (nconc (buffer-modeline-fields buffer) + (list (modeline-field :process-status))))))) + +(defmode "Process" :major-p nil :setup-function #'setup-process-buffer) + + + + +;;;; Shell-filter streams. + +;;; We use shell-filter-streams to capture text going from the shell process to +;;; a Hemlock output stream. They pass character and misc operations through +;;; to the attached hemlock-output-stream. The string output function scans +;;; the string for ^A_____^B, denoting a change of directory. +;;; +;;; The following aliases in a .cshrc file are required for using filename +;;; completion: +;;; alias cd 'cd \!* ; echo ""`pwd`"/"' +;;; alias popd 'popd \!* ; echo ""`pwd`"/"' +;;; alias pushd 'pushd \!* ; echo ""`pwd`"/"' +;;; + +(defstruct (shell-filter-stream + (:include sys:lisp-stream + (:out #'shell-filter-out) + (:sout #'shell-filter-string-out) + (:misc #'shell-filter-output-misc)) + (:print-function print-shell-filter-stream) + (:constructor + make-shell-filter-stream (buffer hemlock-stream))) + ;; The buffer where output will be going + buffer + ;; The Hemlock stream to which output will be directed + hemlock-stream) + + +;;; PRINT-SHELL-FILTER-STREAM -- Internal +;;; +;;; Function for printing a shell-filter-stream. +;;; +(defun print-shell-filter-stream (s stream d) + (declare (ignore d s)) + (write-string "#" stream)) + + +;;; SHELL-FILTER-OUT -- Internal +;;; +;;; This is the character-out handler for the shell-filter-stream. +;;; It writes the character it is given to the underlying +;;; hemlock-output-stream. +;;; +(defun shell-filter-out (stream character) + (write-char character (shell-filter-stream-hemlock-stream stream))) + + +;;; SHELL-FILTER-OUTPUT-MISC -- Internal +;;; +;;; This will also simply pass the output request on the the +;;; attached hemlock-output-stream. +;;; +(defun shell-filter-output-misc (stream operation &optional arg1 arg2) + (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream))) + (funcall (hi::hemlock-output-stream-misc hemlock-stream) + hemlock-stream operation arg1 arg2))) + + +;;; CATCH-CD-STRING -- Internal +;;; +;;; Scans String for the sequence ^A...^B. Returns as multiple values +;;; the breaks in the string. If the second start/end pair is nil, there +;;; was no cd sequence. +;;; +(defun catch-cd-string (string start end) + (declare (simple-string string)) + (let ((cd-start (position (code-char 1) string :start start :end end))) + (if cd-start + (let ((cd-end (position (code-char 2) string :start cd-start :end end))) + (if cd-end + (values start cd-start cd-end end) + (values start end nil nil))) + (values start end nil nil)))) + +;;; SHELL-FILTER-STRING-OUT -- Internal +;;; +;;; The string output function for shell-filter-stream's. +;;; Any string containing a ^A...^B is caught and assumed to be +;;; the path-name of the new current working directory. This is +;;; removed from the orginal string and the result is passed along +;;; to the Hemlock stream. +;;; +(defun shell-filter-string-out (stream string start end) + (declare (simple-string string)) + (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream)) + (buffer (shell-filter-stream-buffer stream))) + + (multiple-value-bind (start1 end1 start2 end2) + (catch-cd-string string start end) + (write-string string hemlock-stream :start start1 :end end1) + (when start2 + (write-string string hemlock-stream :start (+ 2 start2) :end end2) + (let ((cd-string (subseq string (1+ end1) start2))) + (setf (variable-value 'current-working-directory :buffer buffer) + (pathname cd-string))))))) + + +;;; FILTER-TILDES -- Internal +;;; +;;; Since COMPLETE-FILE does not seem to deal with ~'s in the filename +;;; this function expands them to a full path name. +;;; +(defun filter-tildes (name) + (declare (simple-string name)) + (if (char= (schar name 0) #\~) + (concatenate 'simple-string + (if (or (= (length name) 1) + (char= (schar name 1) #\/)) + (cdr (assoc :home *environment-list*)) + "/usr/") + (subseq name 1)) + name)) + + + + +;;;; Support for handling input before the prompt in process buffers. + +(defun unwedge-process-buffer () + (buffer-end (current-point)) + (deliver-signal-to-process :SIGINT (value process)) + (editor-error "Aborted.")) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-process-buffer + :mode "Process") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Interrupt and throw to end of buffer?" + :mode "Process") + + + + +;;;; Some Global Variables. + +(defhvar "Current Shell" + "The shell to which \"Select Shell\" goes." + :value nil) + +(defhvar "Ask about Old Shells" + "When set (the default), Hemlock prompts for an existing shell buffer in + preference to making a new one when there is no \"Current Shell\"." + :value t) + +(defhvar "Kill Process Confirm" + "When set, Hemlock prompts for confirmation before killing a buffer's process." + :value t) + +(defhvar "Shell Utility" + "The \"Shell\" command uses this as the default command line." + :value "/bin/csh") + +(defhvar "Shell Utility Switches" + "This is a string containing the default command line arguments to the + utility in \"Shell Utility\". This is a string since the utility is + typically \"/bin/csh\", and this string can contain I/O redirection and + other shell directives." + :value "") + + + + +;;;; The Shell, New Shell, and Set Current Shell Commands. + +(defvar *shell-names* (make-string-table) + "A string-table of the string-name of all process buffers and corresponding + buffer structures.") + +(defcommand "Set Current Shell" (p) + "Sets the value of \"Current Shell\", which the \"Shell\" command uses." + "Sets the value of \"Current Shell\", which the \"Shell\" command uses." + (declare (ignore p)) + (set-current-shell)) + +;;; SET-CURRENT-SHELL -- Internal. +;;; +;;; This prompts for a known shell buffer to which it sets "Current Shell". +;;; It signals an error if there are none. +;;; +(defun set-current-shell () + (let ((old-buffer (value current-shell)) + (first-old-shell (do-strings (var val *shell-names* nil) + (declare (ignore val)) + (return var)))) + (when (and (not old-buffer) (not first-old-shell)) + (editor-error "Nothing to set current shell to.")) + (let ((default-shell (if old-buffer + (buffer-name old-buffer) + first-old-shell))) + (multiple-value-bind + (new-buffer-name new-buffer) + (prompt-for-keyword (list *shell-names*) + :must-exist t + :default default-shell + :default-string default-shell + :prompt "Existing Shell: " + :help "Enter the name of an existing shell.") + (declare (ignore new-buffer-name)) + (setf (value current-shell) new-buffer))))) + +(defcommand "Shell" (p) + "This spawns a shell in a buffer. If there already is a \"Current Shell\", + this goes to that buffer. If there is no \"Current Shell\", there are + shell buffers, and \"Ask about Old Shells\" is set, this prompts for one + of them, setting \"Current Shell\" to that shell. Supplying an argument + forces the creation of a new shell buffer." + "This spawns a shell in a buffer. If there already is a \"Current Shell\", + this goes to that buffer. If there is no \"Current Shell\", there are + shell buffers, and \"Ask about Old Shells\" is set, this prompts for one + of them, setting \"Current Shell\" to that shell. Supplying an argument + forces the creation of a new shell buffer." + (let ((shell (value current-shell)) + (no-shells-p (do-strings (var val *shell-names* t) + (declare (ignore var val)) + (return nil)))) + (cond (p (make-new-shell nil no-shells-p)) + (shell (change-to-buffer shell)) + ((and (value ask-about-old-shells) (not no-shells-p)) + (set-current-shell) + (change-to-buffer (value current-shell))) + (t (make-new-shell nil))))) + +(defcommand "Shell Command Line in Buffer" (p) + "Prompts the user for a process and a buffer in which to run the process." + "Prompts the user for a process and a buffer in which to run the process." + (declare (ignore p)) + (make-new-shell t)) + +;;; MAKE-NEW-SHELL -- Internal. +;;; +;;; This makes new shells for us dealing with prompting for various things and +;;; setting "Current Shell" according to user documentation. +;;; +(defun make-new-shell (prompt-for-command-p &optional (set-current-shell-p t) + (command-line (get-command-line) clp)) + (let* ((command (or (and clp command-line) + (if prompt-for-command-p + (prompt-for-string + :default command-line :trim t + :prompt "Command to execute: " + :help "Shell command line to execute.") + command-line))) + (buffer-name (if prompt-for-command-p + (prompt-for-string + :default + (concatenate 'simple-string command " process") + :trim t + :prompt `("Buffer in which to execute ~A? " + ,command) + :help "Where output from this process will appear.") + (new-shell-name))) + (temp (make-buffer + buffer-name + :modes '("Fundamental" "Process") + :delete-hook + (list #'(lambda (buffer) + (when (eq (value current-shell) buffer) + (setf (value current-shell) nil)) + (delete-string (buffer-name buffer) *shell-names*) + (kill-process (variable-value 'process + :buffer buffer)))))) + (buffer (or temp (getstring buffer-name *buffer-names*))) + (stream (variable-value 'process-output-stream :buffer buffer)) + (output-stream + ;; If we re-used an old shell buffer, this isn't necessary. + (if (hemlock-output-stream-p stream) + (setf (variable-value 'process-output-stream :buffer buffer) + (make-shell-filter-stream buffer stream)) + stream))) + (buffer-end (buffer-point buffer)) + (defhvar "Process" + "The process for Shell and Process buffers." + :buffer buffer + :value (ext::run-program "/bin/sh" (list "-c" command) + :wait nil + :pty output-stream + :env (frob-environment-list + (car (buffer-windows buffer))) + :status-hook #'(lambda (process) + (declare (ignore process)) + (update-process-buffer buffer)) + :input t :output t)) + (defhvar "Current Working Directory" + "The pathname of the current working directory for this buffer." + :buffer buffer + :value (default-directory)) + (setf (getstring buffer-name *shell-names*) buffer) + (update-process-buffer buffer) + (when (and (not (value current-shell)) set-current-shell-p) + (setf (value current-shell) buffer)) + (change-to-buffer buffer))) + +;;; GET-COMMAND-LINE -- Internal. +;;; +;;; This just conses up a string to feed to the shell. +;;; +(defun get-command-line () + (concatenate 'simple-string (value shell-utility) " " + (value shell-utility-switches))) + +;;; FROB-ENVIRONMENT-LIST -- Internal. +;;; +;;; This sets some environment variables so the shell will be in the proper +;;; state when it comes up. +;;; +(defun frob-environment-list (window) + (list* (cons :termcap (concatenate 'simple-string + "emacs:co#" + (if window + (lisp::quick-integer-to-string + (window-width window)) + "") + ":tc=unkown:")) + (cons :emacs "t") (cons :term "emacs") + (remove-if #'(lambda (keyword) + (member keyword '(:termcap :emacs :term) + :test #'(lambda (cons keyword) + (eql (car cons) keyword)))) + ext:*environment-list*))) + +;;; NEW-SHELL-NAME -- Internal. +;;; +;;; This returns a unique buffer name for a shell by incrementing the value of +;;; *process-number* until "Process <*process-number*> is not already the name +;;; of a buffer. Perhaps this is being overly cautious, but I've seen some +;;; really stupid users. +;;; +(defvar *process-number* 0) +;;; +(defun new-shell-name () + (loop + (let ((buffer-name (format nil "Shell ~D" (incf *process-number*)))) + (unless (getstring buffer-name *buffer-names*) (return buffer-name))))) + + + +;;;; Modeline support. + +(defun modeline-process-status (buffer window) + (declare (ignore window)) + (when (hemlock-bound-p 'process :buffer buffer) + (let ((process (variable-value 'process :buffer buffer))) + (ecase (ext:process-status process) + (:running "running") + (:stopped "stopped") + (:signaled "killed by signal ~D" (unix:unix-signal-name + (ext:process-exit-code process))) + (:exited (format nil "exited with status ~D" + (ext:process-exit-code process))))))) + + +(make-modeline-field :name :process-status + :function #'modeline-process-status) + +(defun update-process-buffer (buffer) + (when (buffer-modeline-field-p buffer :process-status) + (dolist (window (buffer-windows buffer)) + (update-modeline-field buffer window :process-status))) + (let ((process (variable-value 'process :buffer buffer))) + (unless (ext:process-alive-p process) + (ext:process-close process) + (when (eq (value current-shell) buffer) + (setf (value current-shell) nil))))) + + + +;;;; Supporting Commands. + +(defcommand "Confirm Process Input" (p) + "Evaluate Process Mode input between the point and last prompt." + "Evaluate Process Mode input between the point and last prompt." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (let* ((process (value process)) + (stream (ext:process-pty process))) + (case (ext:process-status process) + (:running) + (:stopped (editor-error "The process has been stopped.")) + (t (editor-error "The process is dead."))) + (let ((input-region (get-interactive-input))) + (write-line (region-to-string input-region) stream) + (force-output (ext:process-pty process)) + (insert-character (current-point) #\newline) + ;; Move "Buffer Input Mark" to end of buffer. + (move-mark (region-start input-region) (region-end input-region))))) + +(defcommand "Shell Complete Filename" (p) + "Attempts to complete the filename immediately preceding the point. + It will beep if the result of completion is not unique." + "Attempts to complete the filename immediately preceding the point. + It will beep if the result of completion is not unique." + (declare (ignore p)) + (unless (hemlock-bound-p 'current-working-directory) + (editor-error "Shell filename completion only works in shells.")) + (let ((point (current-point))) + (with-mark ((start point)) + (pre-command-parse-check start) + (unless (form-offset start -1) (editor-error "Can't grab filename.")) + (when (member (next-character start) '(#\" #\' #\< #\>)) + (mark-after start)) + (let* ((name-region (region start point)) + (fragment (filter-tildes (region-to-string name-region))) + (dir (default-directory)) + (shell-dir (value current-working-directory))) + (multiple-value-bind (filename unique) + (unwind-protect + (progn + (setf (default-directory) shell-dir) + (complete-file fragment :defaults shell-dir)) + (setf (default-directory) dir)) + (cond (filename + (delete-region name-region) + (insert-string point (namestring filename)) + (when (not unique) + (editor-error))) + (t (editor-error "No such file exists.")))))))) + +(defcommand "Kill Main Process" (p) + "Kills the process in the current buffer." + "Kills the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (when (or (not (value kill-process-confirm)) + (prompt-for-y-or-n :default nil + :prompt "Really blow away shell? " + :default nil + :default-string "no")) + (kill-process (value process)))) + +(defcommand "Stop Main Process" (p) + "Stops the process in the current buffer. With an argument use :SIGSTOP + instead of :SIGTSTP." + "Stops the process in the current buffer. With an argument use :SIGSTOP + instead of :SIGTSTP." + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process))) + +(defcommand "Continue Main Process" (p) + "Continues the process in the current buffer." + "Continues the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-process :SIGCONT (value process))) + +(defun kill-process (process) + "Self-explanatory." + (deliver-signal-to-process :SIGKILL process)) + +(defun deliver-signal-to-process (signal process) + "Delivers a signal to a process." + (ext:process-kill process signal :process-group)) + +(defcommand "Send EOF to Process" (p) + "Sends a Ctrl-D to the process in the current buffer." + "Sends a Ctrl-D to the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (let ((stream (ext:process-pty (value process)))) + (write-char (code-char 4) stream) + (force-output stream))) + +(defcommand "Interrupt Buffer Subprocess" (p) + "Stop the subprocess currently executing in this shell." + "Stop the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (buffer-end (current-point)) + (buffer-end (value buffer-input-mark)) + (deliver-signal-to-subprocess :SIGINT (value process))) + +(defcommand "Kill Buffer Subprocess" (p) + "Kill the subprocess currently executing in this shell." + "Kill the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess :SIGKILL (value process))) + +(defcommand "Quit Buffer Subprocess" (p) + "Quit the subprocess currently executing int his shell." + "Quit the subprocess currently executing int his shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess :SIGQUIT (value process))) + +(defcommand "Stop Buffer Subprocess" (p) + "Stop the subprocess currently executing in this shell." + "Stop the subprocess currently executing in this shell." + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process))) + +(defun deliver-signal-to-subprocess (signal process) + "Delivers a signal to a subprocess of a shell." + (ext:process-kill process signal :pty-process-group)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-aug.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-aug.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-aug.lisp (revision 8058) @@ -0,0 +1,237 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; +;;; This file contains the code to grow the spelling dictionary in system +;;; space by reading a text file of entries or adding one at a time. This +;;; code relies on implementation dependent code found in Spell-RT.Lisp. + + +(in-package "SPELL") + + + +;;;; Converting Flags to Masks + +(defconstant flag-names-to-masks + `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask) + (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask) + (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask) + (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask) + (#\P . ,P-mask) (#\M . ,M-mask))) + +(defvar *flag-masks* + (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) + "This holds the masks for character flags, which is used when reading + a text file of dictionary words. Illegal character flags hold zero.") + +(eval-when (:compile-toplevel :execute) +(defmacro flag-mask (char) + `(aref *flag-masks* (char-code ,char))) +) ;eval-when + +(dolist (e flag-names-to-masks) + (let ((char (car e)) + (mask (cdr e))) + (setf (flag-mask char) mask) + (setf (flag-mask (char-downcase char)) mask))) + + + + +;;;; String and Hashing Macros + +(eval-when (:compile-toplevel :execute) + +(defmacro string-table-replace (src-string dst-start length) + `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) + +;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for +;;; adding a new entry. If a location contains a zero, then it has never been +;;; used, and no entries have ever been "hashed past" it. If a location +;;; contains SPELL-DELETED-ENTRY, then it once contained an entry that has +;;; since been deleted. +;;; +(defmacro hash-entry (entry entry-len) + (let ((loop-loc (gensym)) (loc-contents (gensym)) + (hash (gensym)) (loc (gensym))) + `(let* ((,hash (string-hash ,entry ,entry-len)) + (,loc (rem ,hash (the fixnum *dictionary-size*))) + (,loc-contents (dictionary-ref ,loc))) + (declare (fixnum ,loc ,loc-contents)) + (if (or (zerop ,loc-contents) (= ,loc-contents spell-deleted-entry)) + ,loc + (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash + ,loop-loc nil t))))) + +) ;eval-when + + + + +;;;; Top Level Stuff + +(defun spell-read-dictionary (filename) + "Add entries to dictionary from lines in the file filename." + (with-open-file (s filename :direction :input) + (loop (multiple-value-bind (entry eofp) (read-line s nil nil) + (declare (type (or simple-string null) entry)) + (unless entry (return)) + (spell-add-entry entry) + (if eofp (return)))))) + + +;;; This is used to break up an 18 bit string table index into two parts +;;; for storage in a word descriptor unit. See the documentation at the +;;; top of Spell-Correct.Lisp. +;;; +(defconstant whole-index-low-byte (byte 16 0)) + +(defun spell-add-entry (line &optional + (word-end (or (position #\/ line :test #'char=) + (length line)))) + "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and + added to the spelling dictionary. Line is desstructively modified." + (declare (simple-string line) (fixnum word-end)) + (nstring-upcase line :end word-end) + (when (> word-end max-entry-length) + (return-from spell-add-entry nil)) + (let ((entry (lookup-entry line word-end))) + (when entry + (add-flags (+ entry 2) line word-end) + (return-from spell-add-entry nil))) + (let* ((hash-loc (hash-entry line word-end)) + (string-ptr *string-table-size*) + (desc-ptr *descriptors-size*) + (desc-ptr+1 (1+ desc-ptr)) + (desc-ptr+2 (1+ desc-ptr+1))) + (declare (fixnum string-ptr)) + (when (not hash-loc) (error "Dictionary Overflow!")) + (when (> 3 *free-descriptor-elements*) (grow-descriptors)) + (when (> word-end *free-string-table-bytes*) (grow-string-table)) + (decf *free-descriptor-elements* 3) + (incf *descriptors-size* 3) + (decf *free-string-table-bytes* word-end) + (incf *string-table-size* word-end) + (setf (dictionary-ref hash-loc) desc-ptr) + (setf (descriptor-ref desc-ptr) + (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end))) + stored-hash-byte + word-end)) + (setf (descriptor-ref desc-ptr+1) + (ldb whole-index-low-byte string-ptr)) + (setf (descriptor-ref desc-ptr+2) + (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) + stored-index-high-byte + 0)) + (add-flags desc-ptr+2 line word-end) + (string-table-replace line string-ptr word-end)) + t) + +(defun add-flags (loc line word-end) + (declare (simple-string line) (fixnum word-end)) + (do ((flag (1+ word-end) (+ 2 flag)) + (line-end (length line))) + ((>= flag line-end)) + (declare (fixnum flag line-end)) + (let ((flag-mask (flag-mask (schar line flag)))) + (declare (fixnum flag-mask)) + (unless (zerop flag-mask) + (setf (descriptor-ref loc) + (logior flag-mask (descriptor-ref loc))))))) + +;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from +;;; the dictionary. First entry is looked up, and if it is found due to a +;;; flag, the flag is cleared in the descriptor table. If entry is a root +;;; word in the dictionary (that is, looked up without the use of a flag), +;;; then the root and all its derivitives are deleted by setting its +;;; dictionary location to spell-deleted-entry. +;;; +(defun spell-remove-entry (entry) + "Removes entry from the dictionary, so it will be an unknown word. Entry + is a simple string and is destructively modified. If entry is a root + word, then all words derived with entry and its flags will also be deleted." + (declare (simple-string entry)) + (nstring-upcase entry) + (let ((entry-len (length entry))) + (declare (fixnum entry-len)) + (when (<= 2 entry-len max-entry-length) + (multiple-value-bind (index flagp) + (spell-try-word entry entry-len) + (when index + (if flagp + (setf (descriptor-ref (+ 2 index)) + (logandc2 (descriptor-ref (+ 2 index)) flagp)) + (let* ((hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + (setf (dictionary-ref loc) spell-deleted-entry)) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (when (found-entry-p loc-contents entry + entry-len hash-and-len) + (setf (dictionary-ref loop-loc) + spell-deleted-entry) + (return spell-deleted-entry)))))))))))) + +(defun spell-root-flags (index) + "Return the flags associated with the root word corresponding to a + dictionary entry at index." + (let ((desc-word (descriptor-ref (+ 2 index))) + (result ())) + (declare (fixnum desc-word)) + (dolist (ele flag-names-to-masks result) + (unless (zerop (logand (the fixnum (cdr ele)) desc-word)) + (push (car ele) result))))) + + + + +;;;; Growing Dictionary Structures + +;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. +;;; +(defun grow-descriptors () + (let* ((old-size (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))) + (new-size (truncate (* old-size 1.1))) + (new-bytes (* new-size 2)) + (new-sap (allocate-bytes new-bytes))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *descriptors* 0 0 + (* 2 (the fixnum *descriptors-size*))) + (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) + (setf *free-descriptor-elements* + (- new-size (the fixnum *descriptors-size*))) + (setf *descriptors* new-sap))) + +;;; GROW-STRING-TABLE grows the string table by 10%. +;;; +(defun grow-string-table () + (let* ((old-size (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*))) + (new-size (truncate (* old-size 1.1))) + (new-sap (allocate-bytes new-size))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *string-table* 0 0 *string-table-size*) + (setf *free-string-table-bytes* + (- new-size (the fixnum *string-table-size*))) + (deallocate-bytes (system-address *string-table*) old-size) + (setf *string-table* new-sap))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-corr.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-corr.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-corr.lisp (revision 8058) @@ -0,0 +1,816 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This is the file that deals with checking and correcting words +;;; using a dictionary read in from a binary file. It has been written +;;; from the basic ideas used in Ispell (on DEC-20's) which originated as +;;; Spell on the ITS machines at MIT. There are flags which have proper +;;; uses defined for them that indicate permissible suffixes to entries. +;;; This allows for about three times as many known words than are actually +;;; stored. When checking the spelling of a word, first it is looked up; +;;; if this fails, then possible roots are looked up, and if any has the +;;; appropriate suffix flag, then the word is considered to be correctly +;;; spelled. For an unknown word, the following rules define "close" words +;;; which are possible corrections: +;;; 1] two adjacent letters are transposed to form a correct spelling; +;;; 2] one letter is changed to form a correct spelling; +;;; 3] one letter is added to form a correct spelling; and/or +;;; 4] one letter is removed to form a correct spelling. +;;; There are two restrictions on the length of a word in regards to its +;;; worthiness of recognition: it must be at least more than two letters +;;; long, and if it has a suffix, then it must be at least four letters +;;; long. More will be said about this when the flags are discussed. +;;; This is implemented in as tense a fashion as possible, and it uses +;;; implementation dependent code from Spell-RT.Lisp to accomplish this. +;;; In general the file I/O and structure accesses encompass the system +;;; dependencies. + +;;; This next section will discuss the storage of the dictionary +;;; information. There are three data structures that "are" the +;;; dictionary: a hash table, descriptors table, and a string table. The +;;; hash table is a vector of type '(unsigned-byte 16), whose elements +;;; point into the descriptors table. This is a cyclic hash table to +;;; facilitate dumping it to a file. The descriptors table (also of type +;;; '(unsigned-byte 16)) dedicates three elements to each entry in the +;;; dictionary. Each group of three elements has the following organization +;;; imposed on them: +;;; ---------------------------------------------- +;;; | 15..5 hash code | 4..0 length | +;;; ---------------------------------------------- +;;; | 15..0 character index | +;;; ---------------------------------------------- +;;; | 15..14 character index | 13..0 flags | +;;; ---------------------------------------------- +;;; "Length" is the number of characters in the entry; "hash code" is some +;;; eleven bits from the hash code to allow for quicker lookup, "flags" +;;; indicate possible suffixes for the basic entry, and "character index" +;;; is the index of the start of the entry in the string table. +;;; This was originally adopted due to the Perq's word size (can you guess? +;;; 16 bits, that's right). Note the constraint that is placed on the number +;;; of the entries, 21845, because the hash table could not point to more +;;; descriptor units (16 bits of pointer divided by three). Since a value of +;;; zero as a hash table element indicates an empty location, the zeroth element +;;; of the descriptors table must be unused (it cannot be pointed to). + + +;;; The following is a short discussion with examples of the correct +;;; use of the suffix flags. Let # and @ be symbols that can stand for any +;;; single letter. Upper case letters are constants. "..." stands for any +;;; string of zero or more letters, but note that no word may exist in the +;;; dictionary which is not at least 2 letters long, so, for example, FLY +;;; may not be produced by placing the "Y" flag on "F". Also, no flag is +;;; effective unless the word that it creates is at least 4 letters long, +;;; so, for example, WED may not be produced by placing the "D" flag on +;;; "WE". These flags and examples are from the Ispell documentation with +;;; only slight modifications. Here are the correct uses of the flags: +;;; +;;; "V" flag: +;;; ...E => ...IVE as in create => creative +;;; if # .ne. E, then ...# => ...#IVE as in prevent => preventive +;;; +;;; "N" flag: +;;; ...E => ...ION as in create => creation +;;; ...Y => ...ICATION as in multiply => multiplication +;;; if # .ne. E or Y, then ...# => ...#EN as in fall => fallen +;;; +;;; "X" flag: +;;; ...E => ...IONS as in create => creations +;;; ...Y => ...ICATIONS as in multiply => multiplications +;;; if # .ne. E or Y, ...# => ...#ENS as in weak => weakens +;;; +;;; "H" flag: +;;; ...Y => ...IETH as in twenty => twentieth +;;; if # .ne. Y, then ...# => ...#TH as in hundred => hundredth +;;; +;;; "Y" FLAG: +;;; ... => ...LY as in quick => quickly +;;; +;;; "G" FLAG: +;;; ...E => ...ING as in file => filing +;;; if # .ne. E, then ...# => ...#ING as in cross => crossing +;;; +;;; "J" FLAG" +;;; ...E => ...INGS as in file => filings +;;; if # .ne. E, then ...# => ...#INGS as in cross => crossings +;;; +;;; "D" FLAG: +;;; ...E => ...ED as in create => created +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IED as in imply => implied +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ED as in convey => conveyed +;;; if # .ne. E or Y, then ...# => ...#ED as in cross => crossed +;;; +;;; "T" FLAG: +;;; ...E => ...EST as in late => latest +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IEST as in dirty => dirtiest +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#EST as in gray => grayest +;;; if # .ne. E or Y, then ...# => ...#EST as in small => smallest +;;; +;;; "R" FLAG: +;;; ...E => ...ER as in skate => skater +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IER as in multiply => multiplier +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ER as in convey => conveyer +;;; if # .ne. E or Y, then ...# => ...#ER as in build => builder +;;; + +;;; "Z FLAG: +;;; ...E => ...ERS as in skate => skaters +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IERS as in multiply => multipliers +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ERS as in slay => slayers +;;; if # .ne. E or Y, then ...@# => ...@#ERS as in build => builders +;;; +;;; "S" FLAG: +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IES as in imply => implies +;;; if # .eq. S, X, Z, or H, +;;; then ...# => ...#ES as in fix => fixes +;;; if # .ne. S, X, Z, H, or Y, +;;; then ...# => ...#S as in bat => bats +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#S as in convey => conveys +;;; +;;; "P" FLAG: +;;; if # .ne. Y, or @ = A, E, I, O, or U, +;;; then ...@# => ...@#NESS as in late => lateness and +;;; gray => grayness +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@INESS as in cloudy => cloudiness +;;; +;;; "M" FLAG: +;;; ... => ...'S as in DOG => DOG'S + +(in-package "SPELL") + + + +;;;; Some Constants + +(eval-when (:compile-toplevel :execute :load-toplevel) + +(defconstant spell-deleted-entry #xFFFF) + +;;; The next number (using 6 bits) is 63, and that's pretty silly because +;;; "supercalafragalistic" is less than 31 characters long. +;;; +(defconstant max-entry-length 31 + "This the maximum number of characters an entry may have.") + +;;; These are the flags (described above), and an entry is allowed a +;;; certain suffix if the appropriate bit is on in the third element of +;;; its descriptor unit (described above). +;;; +(defconstant V-mask (ash 1 13)) +(defconstant N-mask (ash 1 12)) +(defconstant X-mask (ash 1 11)) +(defconstant H-mask (ash 1 10)) +(defconstant Y-mask (ash 1 9)) +(defconstant G-mask (ash 1 8)) +(defconstant J-mask (ash 1 7)) +(defconstant D-mask (ash 1 6)) +(defconstant T-mask (ash 1 5)) +(defconstant R-mask (ash 1 4)) +(defconstant Z-mask (ash 1 3)) +(defconstant S-mask (ash 1 2)) +(defconstant P-mask (ash 1 1)) +(defconstant M-mask 1) + + +;;; These are the eleven bits of a computed hash that are stored as part of +;;; an entries descriptor unit. The shifting constant is how much the +;;; eleven bits need to be shifted to the right, so they take up the upper +;;; eleven bits of one 16-bit element in a descriptor unit. +;;; +(defconstant new-hash-byte (byte 11 13)) +(defconstant stored-hash-byte (byte 11 5)) + + +;;; The next two constants are used to extract information from an entry's +;;; descriptor unit. The first is the two most significant bits of 18 +;;; bits that hold an index into the string table where the entry is +;;; located. If this is confusing, regard the diagram of the descriptor +;;; units above. +;;; +(defconstant whole-index-high-byte (byte 2 16)) +(defconstant stored-index-high-byte (byte 2 14)) +(defconstant stored-length-byte (byte 5 0)) + + +); eval-when (:compile-toplevel :execute :load-toplevel) + + + +;;;; Some Specials and Accesses + +;;; *spell-aeiou* will have bits on that represent the capital letters +;;; A, E, I, O, and U to be used to determine if some word roots are legal +;;; for looking up. +;;; +(defvar *aeiou* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *aeiou* (char-code #\A)) 1) +(setf (aref *aeiou* (char-code #\E)) 1) +(setf (aref *aeiou* (char-code #\I)) 1) +(setf (aref *aeiou* (char-code #\O)) 1) +(setf (aref *aeiou* (char-code #\U)) 1) + + +;;; *sxzh* will have bits on that represent the capital letters +;;; S, X, Z, and H to be used to determine if some word roots are legal for +;;; looking up. +;;; +(defvar *sxzh* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *sxzh* (char-code #\S)) 1) +(setf (aref *sxzh* (char-code #\X)) 1) +(setf (aref *sxzh* (char-code #\Z)) 1) +(setf (aref *sxzh* (char-code #\H)) 1) + + +;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a +;;; character is in the specified set. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro set-member-p (char set) + `(not (zerop (the fixnum (aref (the simple-bit-vector ,set) + (char-code ,char)))))) +) ;eval-when + + +(defvar *dictionary*) +(defvar *dictionary-size*) +(defvar *descriptors*) +(defvar *descriptors-size*) +(defvar *string-table*) +(defvar *string-table-size*) + + +(eval-when (:compile-toplevel :execute) + +;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation +;;; dependent structures. *dictionary* and *descriptors* are "system +;;; area pointers" as a result of the way the binary file is opened for +;;; fast access. +;;; +(defmacro dictionary-ref (idx) + `(sapref *dictionary* ,idx)) + +(defmacro descriptor-ref (idx) + `(sapref *descriptors* ,idx)) + + +;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx) +;;; descriptor unit (described at the beginning of the file) and returns +;;; the start index of the entry in the string table. The second of three +;;; words in the descriptor holds the 16 least significant bits of 18, and +;;; the top two bits of the third word are the 2 most significant bits. +;;; These 18 bits are the index into the string table. +;;; +(defmacro descriptor-string-start (idx) + `(dpb (the fixnum (ldb stored-index-high-byte + (the fixnum (descriptor-ref (+ 2 ,idx))))) + whole-index-high-byte + (the fixnum (descriptor-ref (1+ ,idx))))) + +) ;eval-when + + + + +;;;; Top level Checking/Correcting + +;;; CORRECT-SPELLING can be called from top level to check/correct a words +;;; spelling. It is not used for any other purpose. +;;; +(defun correct-spelling (word) + "Check/correct the spelling of word. Output is done to *standard-output*." + (setf word (coerce word 'simple-string)) + (let ((word (string-upcase (the simple-string word))) + (word-len (length (the simple-string word)))) + (declare (simple-string word) (fixnum word-len)) + (maybe-read-spell-dictionary) + (when (= word-len 1) + (error "Single character words are not in the dictionary.")) + (when (> word-len max-entry-length) + (error "~A is too long for the dictionary." word)) + (multiple-value-bind (idx used-flag-p) + (spell-try-word word word-len) + (if idx + (format t "Found it~:[~; because of ~A~]." used-flag-p + (spell-root-word idx)) + (let ((close-words (spell-collect-close-words word))) + (if close-words + (format *standard-output* + "The possible correct spelling~[~; is~:;s are~]:~ + ~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~ + ~{~#[~; and~] ~A~^,~}~]." + (length close-words) + close-words) + (format *standard-output* "Word not found."))))))) + + +(defvar *dictionary-read-p* nil) + +;;; MAYBE-READ-SPELL-DICTIONARY -- Public +;;; +(defun maybe-read-spell-dictionary () + "Read the spelling dictionary if it has not be read already." + (unless *dictionary-read-p* (read-dictionary))) + + +(defun spell-root-word (index) + "Return the root word corresponding to a dictionary entry at index." + (let* ((start (descriptor-string-start index)) + (len (the fixnum (ldb stored-length-byte + (the fixnum (descriptor-ref index))))) + (result (make-string len))) + (declare (fixnum start len) + (simple-string result)) + (sap-replace result (the system-area-pointer *string-table*) + start 0 len) + result)) + + +(eval-when (:compile-toplevel :execute) +(defmacro check-closeness (word word-len closeness-list) + `(if (spell-try-word ,word ,word-len) + (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=))) +) ;eval-when + +(defconstant spell-alphabet + (list #\A #\B #\C #\D #\E #\F #\G #\H + #\I #\J #\K #\L #\M #\N #\O #\P + #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) + +;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled +;;; words. The definition of "close" is at the beginning of the file, and +;;; there are four sections to this function which collect each of the four +;;; different kinds of close words. +;;; +(defun spell-collect-close-words (word) + "Returns a list of all \"close\" correctly spelled words. This has the + same contraints as SPELL-TRY-WORD, which you have probably already called + if you are calling this." + (declare (simple-string word)) + (let* ((word-len (length word)) + (word-len--1 (1- word-len)) + (word-len-+1 (1+ word-len)) + (result ()) + (correcting-buffer (make-string max-entry-length))) + (declare (simple-string correcting-buffer) + (fixnum word-len word-len--1 word-len-+1)) + (replace correcting-buffer word :end1 word-len :end2 word-len) + + ;; Misspelled because one letter is different. + (dotimes (i word-len) + (do ((save-char (schar correcting-buffer i)) + (alphabet spell-alphabet (cdr alphabet))) + ((null alphabet) + (setf (schar correcting-buffer i) save-char)) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness correcting-buffer word-len result))) + + ;; Misspelled because two adjacent letters are transposed. + (dotimes (i word-len--1) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))) + (check-closeness correcting-buffer word-len result) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))) + + ;; Misspelled because of extraneous letter. + (replace correcting-buffer word + :start2 1 :end1 word-len--1 :end2 word-len) + (check-closeness correcting-buffer word-len--1 result) + (dotimes (i word-len--1) + (setf (schar correcting-buffer i) (schar word i)) + (replace correcting-buffer word + :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len) + (check-closeness correcting-buffer word-len--1 result)) + + ;; Misspelled because a letter is missing. + (replace correcting-buffer word + :start1 1 :end1 word-len-+1 :end2 word-len) + (dotimes (i word-len-+1) + (do ((alphabet spell-alphabet (cdr alphabet))) + ((null alphabet) + (rotatef (schar correcting-buffer i) + (schar correcting-buffer (1+ i)))) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness correcting-buffer word-len-+1 result))) + result)) + +;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it +;;; is part of the definition of the function of looking up words. +;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4. +;;; +(defun spell-try-word (word word-len) + "See if the word or an appropriate root is in the spelling dicitionary. + Word-len must be inclusively in the range 2..max-entry-length." + (or (lookup-entry word word-len) + (if (>= (the fixnum word-len) 4) + (try-word-endings word word-len)))) + + + + +;;;; Divining Correct Spelling + +(eval-when (:compile-toplevel :execute) + +(defmacro setup-root-buffer (word buffer root-len) + `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len)) + +(defmacro try-root (word root-len flag-mask) + (let ((result (gensym))) + `(let ((,result (lookup-entry ,word ,root-len))) + (if (and ,result (descriptor-flag ,result ,flag-mask)) + (return (values ,result ,flag-mask)))))) + +;;; TRY-MODIFIED-ROOT is used for root words that become truncated +;;; when suffixes are added (e.g., skate => skating). Char-idx is the last +;;; character in the root that has to typically be changed from a #\I to a +;;; #\Y or #\E. +;;; +(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char) + (let ((root-word (gensym))) + `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len))) + (setf (schar ,root-word ,char-idx) ,new-char) + (try-root ,root-word ,root-len ,flag-mask)))) + +) ;eval-when + + +(defvar *rooting-buffer* (make-string max-entry-length)) + +;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and +;;; returns multiple values on success (the index where the word's root's +;;; descriptor starts and :used-flag), otherwise nil. It looks at +;;; characters from the end to the beginning of the word to determine if it +;;; has any known suffixes. This is a VERY simple finite state machine +;;; where all of the suffixes are narrowed down to one possible one in at +;;; most two state changes. This is a PROG form for speed, and in some sense, +;;; readability. The states of the machine are the flag names that denote +;;; suffixes. The two points of branching to labels are the very beginning +;;; of the PROG and the S state. This is a fairly straight forward +;;; implementation of the flag rules presented at the beginning of this +;;; file, with char-idx checks, so we do not index the string below zero. + +(defun try-word-endings (word word-len) + (declare (simple-string word) + (fixnum word-len)) + (prog* ((char-idx (1- word-len)) + (char (schar word char-idx)) + (rooting-buffer *rooting-buffer*) + flag-mask) + (declare (simple-string rooting-buffer) + (fixnum char-idx)) + (case char + (#\S (go S)) ;This covers over half of the possible endings + ;by branching off the second to last character + ;to other flag states that have plural endings. + (#\R (setf flag-mask R-mask) ;"er" and "ier" + (go D-R-Z-FLAG)) + (#\T (go T-FLAG)) ;"est" and "iest" + (#\D (setf flag-mask D-mask) ;"ed" and "ied" + (go D-R-Z-FLAG)) + (#\H (go H-FLAG)) ;"th" and "ieth" + (#\N (setf flag-mask N-mask) ;"ion", "ication", and "en" + (go N-X-FLAG)) + (#\G (setf flag-mask G-mask) ;"ing" + (go G-J-FLAG)) + (#\Y (go Y-FLAG)) ;"ly" + (#\E (go V-FLAG))) ;"ive" + (return nil) + + S + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) S-mask) + (return nil)) + (if (not (set-member-p char *sxzh*)) + (try-root word (1+ char-idx) S-mask))) + (case char + (#\E (go S-FLAG)) ;"es" and "ies" + (#\R (setf flag-mask Z-mask) ;"ers" and "iers" + (go D-R-Z-FLAG)) + (#\G (setf flag-mask J-mask) ;"ings" + (go G-J-FLAG)) + (#\S (go P-FLAG)) ;"ness" and "iness" + (#\N (setf flag-mask X-mask) ;"ions", "ications", and "ens" + (go N-X-FLAG)) + (#\' (try-root word char-idx M-mask))) + (return nil) + + S-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (set-member-p char *sxzh*) + (try-root word (1+ char-idx) S-mask)) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + S-mask char-idx #\Y)) + (return nil) + + D-R-Z-FLAG + (if (char/= (schar word (1- char-idx)) #\E) (return nil)) + (try-root word char-idx flag-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) flag-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root word (1+ char-idx) flag-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + flag-mask char-idx #\Y)) + (return nil) + + P-FLAG + (if (or (char/= (schar word (1- char-idx)) #\E) + (char/= (schar word (- char-idx 2)) #\N)) + (return nil)) + (if (<= (setf char-idx (- char-idx 3)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) P-mask) + (return nil))) + (try-root word (1+ char-idx) P-mask) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + P-mask char-idx #\Y)) + (return nil) + + G-J-FLAG + (if (< char-idx 3) (return nil)) + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root word char-idx flag-mask)) + (try-modified-root word rooting-buffer (1+ char-idx) + flag-mask char-idx #\E) + (return nil) + + N-X-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (cond ((char= char #\E) + (setf char (schar word (1- char-idx))) + (if (and (char/= char #\Y) (char/= char #\E)) + (try-root word char-idx flag-mask)) + (return nil)) + ((char= char #\O) + (if (char= (schar word (1- char-idx)) #\I) + (try-modified-root word rooting-buffer char-idx + flag-mask (1- char-idx) #\E) + (return nil)) + (if (< char-idx 5) (return nil)) + (if (or (char/= (schar word (- char-idx 2)) #\T) + (char/= (schar word (- char-idx 3)) #\A) + (char/= (schar word (- char-idx 4)) #\C) + (char/= (schar word (- char-idx 5)) #\I)) + (return nil) + (setf char-idx (- char-idx 4))) + (try-modified-root word rooting-buffer char-idx + flag-mask (1- char-idx) #\Y)) + (t (return nil))) + + T-FLAG + (if (or (char/= (schar word (1- char-idx)) #\S) + (char/= (schar word (- char-idx 2)) #\E)) + (return nil) + (setf char-idx (1- char-idx))) + (try-root word char-idx T-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) T-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root word (1+ char-idx) T-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + T-mask char-idx #\Y)) + (return nil) + + H-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char/= char #\T) (return nil)) + (if (char/= (schar word (1- char-idx)) #\Y) + (try-root word char-idx H-mask)) + (if (and (char= (schar word (1- char-idx)) #\E) + (char= (schar word (- char-idx 2)) #\I)) + (try-modified-root word rooting-buffer (1- char-idx) + H-mask (- char-idx 2) #\Y)) + (return nil) + + Y-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\L) + (try-root word char-idx Y-mask)) + (return nil) + + V-FLAG + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root word char-idx V-mask)) + (try-modified-root word rooting-buffer (1+ char-idx) + V-mask char-idx #\E) + (return nil))) + + + +;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on. +;;; From the diagram at the beginning of the file, we see that the flags +;;; are stored two words off of the first word in the descriptor unit for +;;; an entry. +;;; +(defun descriptor-flag (descriptor-start flag-mask) + (not (zerop + (the fixnum + (logand + (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start)))) + (the fixnum flag-mask)))))) + + + +;;;; Looking up Trials + +(eval-when (:compile-toplevel :execute) + +;;; SPELL-STRING= determines if string1 and string2 are the same. Before +;;; it is called it is known that they are both of (- end1 0) length, and +;;; string2 is in system space. This is used in FOUND-ENTRY-P. +;;; +(defmacro spell-string= (string1 string2 end1 start2) + (let ((idx1 (gensym)) + (idx2 (gensym))) + `(do ((,idx1 0 (1+ ,idx1)) + (,idx2 ,start2 (1+ ,idx2))) + ((= ,idx1 ,end1) t) + (declare (fixnum ,idx1 ,idx2)) + (unless (= (the fixnum (char-code (schar ,string1 ,idx1))) + (the fixnum (string-sapref ,string2 ,idx2))) + (return nil))))) + +;;; FOUND-ENTRY-P determines if entry is what is described at idx. +;;; Hash-and-length is 16 bits that look just like the first word of any +;;; entry's descriptor unit (see diagram at the beginning of the file). If +;;; the word stored at idx and entry have the same hash bits and length, +;;; then we compare characters to see if they are the same. +;;; +(defmacro found-entry-p (idx entry entry-len hash-and-length) + `(if (= (the fixnum (descriptor-ref ,idx)) + (the fixnum ,hash-and-length)) + (spell-string= ,entry *string-table* ,entry-len + (descriptor-string-start ,idx)))) + +(defmacro hash2-increment (hash) + `(- (the fixnum *dictionary-size*) + 2 + (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2))))) + +(defmacro hash2-loop ((location-var contents-var) + loc hash zero-contents-form + &optional body-form (for-insertion-p nil)) + (let ((incr (gensym))) + `(let* ((,incr (hash2-increment ,hash)) + (,location-var ,loc) + (,contents-var 0)) + (declare (fixnum ,location-var ,contents-var ,incr)) + (loop (setf ,location-var + (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*))) + (setf ,contents-var (dictionary-ref ,location-var)) + (if (zerop ,contents-var) (return ,zero-contents-form)) + ,@(if for-insertion-p + `((if (= ,contents-var spell-deleted-entry) + (return ,zero-contents-form)))) + (if (= ,location-var ,loc) (return nil)) + ,@(if body-form `(,body-form)))))) + +) ;eval-when + + +;;; LOOKUP-ENTRY returns the index of the first element of entry's +;;; descriptor unit on success, otherwise nil. +;;; +(defun lookup-entry (entry &optional len) + (declare (simple-string entry)) + (let* ((entry-len (or len (length entry))) + (hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum entry-len hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + loc-contents) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (if (found-entry-p loc-contents entry entry-len hash-and-len) + (return loc-contents))))))) + + +;;;; Binary File Reading + +(defparameter default-binary-dictionary + "library:spell-dictionary.bin") + +;;; This is the first thing in a spell binary dictionary file to serve as a +;;; quick check of its proposed contents. This particular number is +;;; "BILLS" on a calculator held upside-down. +;;; +(defconstant magic-file-id 57718) + +;;; These constants are derived from the order things are written to the +;;; binary dictionary in Spell-Build.Lisp. +;;; +(defconstant magic-file-id-loc 0) +(defconstant dictionary-size-loc 1) +(defconstant descriptors-size-loc 2) +(defconstant string-table-size-low-byte-loc 3) +(defconstant string-table-size-high-byte-loc 4) +(defconstant file-header-bytes 10) + +;;; Initially, there are no free descriptor elements and string table bytes, +;;; but when these structures are grown, they are grown by more than that +;;; which is necessary. +;;; +(defvar *free-descriptor-elements* 0) +(defvar *free-string-table-bytes* 0) + +;;; READ-DICTIONARY opens the dictionary and sets up the global structures +;;; manifesting the spelling dictionary. When computing the start addresses +;;; of these structures, we multiply by two since their sizes are in 16bit +;;; lengths while the RT is 8bit-byte addressable. +;;; +(defun read-dictionary (&optional (f default-binary-dictionary)) + (when *dictionary-read-p* + (setf *dictionary-read-p* nil) + (deallocate-bytes (system-address *dictionary*) + (* 2 (the fixnum *dictionary-size*))) + (deallocate-bytes (system-address *descriptors*) + (* 2 (the fixnum + (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))))) + (deallocate-bytes (system-address *string-table*) + (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*)))) + (setf *free-descriptor-elements* 0) + (setf *free-string-table-bytes* 0) + (let* ((fd (open-dictionary f)) + (header-info (read-dictionary-structure fd file-header-bytes))) + (unless (= (sapref header-info magic-file-id-loc) magic-file-id) + (deallocate-bytes (system-address header-info) file-header-bytes) + (error "File is not a dictionary: ~S." f)) + (setf *dictionary-size* (sapref header-info dictionary-size-loc)) + (setf *descriptors-size* (sapref header-info descriptors-size-loc)) + (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc)) + (setf (ldb (byte 12 16) (the fixnum *string-table-size*)) + (the fixnum (sapref header-info string-table-size-high-byte-loc))) + (deallocate-bytes (system-address header-info) file-header-bytes) + (setf *dictionary* + (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*)))) + (setf *descriptors* + (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*)))) + (setf *string-table* (read-dictionary-structure fd *string-table-size*)) + (setf *dictionary-read-p* t) + (close-dictionary fd))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-rt.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-rt.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell-rt.lisp (revision 8058) @@ -0,0 +1,107 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains system dependent primitives for the spelling checking/ +;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and +;;; Spell-Build.Lisp. + +(defpackage "SPELL" + (:use "LISP" "EXTENSIONS" "SYSTEM") + (:export spell-try-word spell-root-word spell-collect-close-words + maybe-read-spell-dictionary correct-spelling max-entry-length + spell-read-dictionary spell-add-entry spell-root-flags + spell-remove-entry)) + +(in-package "SPELL") + + + +;;;; System Area Referencing and Setting + +(eval-when (:compile-toplevel :execute) + +;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and +;;; *string-table* are bound to. Address is in the system area. +;;; +(defmacro make-sap (address) + `(system:int-sap ,address)) + +(defmacro system-address (sap) + `(system:sap-int ,sap)) + + +(defmacro allocate-bytes (count) + `(system:allocate-system-memory ,count)) + +(defmacro deallocate-bytes (address byte-count) + `(system:deallocate-system-memory (int-sap ,address) ,byte-count)) + + +(defmacro sapref (sap offset) + `(system:sap-ref-16 ,sap (* ,offset 2))) + +(defsetf sapref (sap offset) (value) + `(setf (system:sap-ref-16 ,sap (* ,offset 2)) ,value)) + + +(defmacro sap-replace (dst-string src-string src-start dst-start dst-end) + `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) + +(defmacro string-sapref (sap index) + `(system:sap-ref-8 ,sap ,index)) + + + + +;;;; Primitive String Hashing + +;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes +;;; an end argument, so we do not have to use SXHASH. SXHASH would mean +;;; doing a SUBSEQ of entry. +;;; +(defmacro string-hash (string length) + `(ext:truly-the lisp::index + (%primitive sxhash-simple-substring + ,string + (the fixnum ,length)))) + +) ;eval-when + + + + +;;;; Binary Dictionary File I/O + +(defun open-dictionary (f) + (let* ((filename (ext:unix-namestring f)) + (kind (unix:unix-file-kind filename))) + (unless kind (error "Cannot find dictionary -- ~S." filename)) + (multiple-value-bind (fd err) + (unix:unix-open filename unix:o_rdonly 0) + (unless fd + (error "Opening ~S failed: ~A." filename err)) + (multiple-value-bind (winp dev-or-err) (unix:unix-fstat fd) + (unless winp (error "Opening ~S failed: ~A." filename dev-or-err)) + fd)))) + +(defun close-dictionary (fd) + (unix:unix-close fd)) + +(defun read-dictionary-structure (fd bytes) + (let* ((structure (allocate-bytes bytes))) + (multiple-value-bind (read-bytes err) + (unix:unix-read fd structure bytes) + (when (or (null read-bytes) (not (= bytes read-bytes))) + (deallocate-bytes (system-address structure) bytes) + (error "Reading dictionary structure failed: ~A." err)) + structure))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/README =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/README (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/README (revision 8058) @@ -0,0 +1,26 @@ +SPELL was originally part of Hemlock, CMUCL's Common Lisp text editor. +This version has been mostly rewritten in portable ANSI CL. The only +file that remains to be converted is spell-aug.lisp. Besides ripping +out implementation-specific code, the biggest change is that the spelling +dictionary is no longer a global variable. Instead, it has been +converted to be a class; multiple dictionaries may thus coexist at any +one time. Most functions have therefore been changed to take an extra +DICTIONARY parameter. + +An ASDF system definition is contained in spell.asd. + +Semi-extensive testing has been done. However, a test suite would be +a good thing to write. + +To get started, compile and load the system, then enter + +(SPELL::BUILD-DICTIONARY #p"/path/to/spell-dictionary.text" "outfile") +(SETF MY-DICTIONARY *) +(CORRECT-SPELLING MY-DICTIONARY "debugg") + +spellcoms.lisp is a file containing Hemlock commands and functions to +integrate the SPELL package into Hemlock. It needs to be rewritten +to work with the new code, but is an example of what can be done with +the provided interfaces. + +Please email any comments, questions, or bug fixes to froydnj@cs.rice.edu. Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/build.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/build.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/build.lisp (revision 8058) @@ -0,0 +1,200 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This file contains code to build a new binary dictionary file from +;;; text in system space. This code relies on implementation dependent +;;; code from spell-rt.lisp. Also, it is expected that spell-corr.lisp +;;; and spell-aug.lisp have been loaded. In order to compile this file, +;;; you must first compile spell-rt, spell-corr.lisp, and spell-aug.lisp. + +;;; The text file must be in the following format: +;;; entry1/flag1/flag2/flag3 +;;; entry2 +;;; entry3/flag1/flag2/flag3/flag4/flag5. +;;; The flags are single letter indicators of legal suffixes for the entry; +;;; the available flags and their correct use may be found at the beginning +;;; of spell-corr.lisp in the Hemlock sources. There must be exactly one +;;; entry per line, and each line must be flushleft. + + +(in-package "SPELL") + +;;; An interesting value when building an initial dictionary. +(defvar *collision-count* 0) + +(defvar *new-dictionary*) +(defvar *new-descriptors*) +(defvar *new-string-table*) + +(declaim (optimize (debug 3))) + + + +;;;; Constants + +;;; This is an upper bound estimate of the number of stored entries in the +;;; dictionary. It should not be more than 21,845 because the dictionary +;;; is a vector of type '(unsigned-byte 16), and the descriptors' vector +;;; for the entries uses three '(unsigned-byte 16) elements per descriptor +;;; unit. See the beginning of Spell-Correct.Lisp. +;;; +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defconstant +max-entry-count-estimate+ 15600) + +(defconstant +new-dictionary-size+ 20011) + +(defconstant +new-descriptors-size+ (1+ +max-entry-count-estimate+)) + +(defconstant +max-string-table-length+ (* 10 +max-entry-count-estimate+)) + +); eval-when + + + +;;;; Hashing + +;;; These hashing macros are different from the ones in Spell-Correct.Lisp +;;; simply because we are using separate space and global specials/constants. +;;; Of course, they should be identical, but it doesn't seem worth cluttering +;;; up Spell-Correct with macro generating macros for this file. + +;;; Well, we've made them functions now. we should really clean up the +;;; other macros mentioned above by merging them with these + +(declaim (inline hash-increment handle-collision get-hash-index)) +(defun hash-increment (hash size) + (- size 2 (rem hash (- size 2)))) + +(defun handle-collision (descriptor-table hash location) + (do* ((incr (hash-increment hash +new-dictionary-size+)) + (collide-location (rem (+ location incr) + +new-dictionary-size+) + (rem (+ collide-location incr) + +new-dictionary-size+))) + ;; if we've found our way back to where we started, there are + ;; no free slots available. indicate failure. + ((= collide-location location) nil) + (when (zerop (aref descriptor-table collide-location)) + (return-from handle-collision collide-location)))) + +(defun get-hash-index (descriptor-table entry entry-length) + "Finds a suitable position in DESCRIPTOR-TABLE for ENTRY. + Returns NIL if one cannot be located." + (let* ((hash (string-hash entry entry-length)) + (location (rem hash +new-dictionary-size+))) + (cond + ((not (zerop (aref descriptor-table location))) + ;; crud. the desirable spot was already taken. hunt for another + (incf *collision-count*) + (handle-collision descriptor-table hash location)) + (t location)))) + + + +;;;; Build-Dictionary + +(defun build-dictionary (input output) + (let* ((descriptors (make-array +new-descriptors-size+)) + (string-table (make-string +max-string-table-length+)) + (descriptor-table (make-array +new-dictionary-size+ + :element-type '(unsigned-byte 16))) + (new-dictionary (make-instance 'dictionary + :string-table string-table + :descriptors descriptors + :descriptor-table descriptor-table))) + (write-line "Reading dictionary ...") + (force-output) + (setf *collision-count* 0) + (multiple-value-bind (entry-count string-table-length) + (read-initial-dictionary input descriptor-table + descriptors string-table) + (write-line "Writing dictionary ...") + (force-output) + (write-dictionary output new-dictionary entry-count string-table-length) + (format t "~D entries processed with ~D collisions." + entry-count *collision-count*) + new-dictionary))) + +(defun read-initial-dictionary (f dictionary descriptors string-table) + (let* ((filename (pathname f)) + (s (open filename :direction :input :if-does-not-exist nil))) + (unless s (error "File ~S does not exist." f)) + (multiple-value-prog1 + (let ((descriptor-ptr 1) + (string-ptr 0) + (entry-count 0)) + (declare (fixnum descriptor-ptr string-ptr entry-count)) + (loop (multiple-value-bind (line eofp) (read-line s nil nil) + (declare (type (or null simple-string) line)) + (unless line (return (values entry-count string-ptr))) + (incf entry-count) + (when (> entry-count +max-entry-count-estimate+) + (error "There are too many entries in text file!~%~ + Please change constants in spell-build.lisp, ~ + recompile the file, and reload it.~%~ + Be sure to understand the constraints of permissible ~ + values.")) + (let ((flags (or (position #\/ line :test #'char=) + (length line)))) + (declare (fixnum flags)) + (cond ((> flags +max-entry-length+) + (format t "Entry ~s too long." (subseq line 0 flags)) + (force-output)) + (t (let ((new-string-ptr (+ string-ptr flags))) + (declare (fixnum new-string-ptr)) + (when (> new-string-ptr +max-string-table-length+) + (error "Spell string table overflow!~%~ + Please change constants in ~ + spell-build.lisp, recompile the file, ~ + and reload it.~%~ + Be sure to understand the constraints ~ + of permissible values.")) + (spell-place-entry line flags + dictionary descriptors string-table + descriptor-ptr string-ptr) + (incf descriptor-ptr) + (setf string-ptr new-string-ptr))))) + (when eofp (return (values entry-count string-ptr)))))) + (close s)))) + +(defun word-flags (line word-end) + (declare (simple-string line) (fixnum word-end)) + (let ((word-flags 0)) + (do ((flag (1+ word-end) (+ 2 flag)) + (line-end (length line))) + ((>= flag line-end) word-flags) + (declare (fixnum flag line-end)) + (let ((flag-mask (flag-mask (schar line flag)))) + (declare (fixnum flag-mask)) + (if (zerop flag-mask) + (format t "Illegal flag ~S on word ~S." + (schar line flag) (subseq line 0 word-end)) + (setf word-flags + (logior flag-mask word-flags))))))) + +(defun spell-place-entry (line word-end dictionary descriptors string-table + descriptor-ptr string-ptr) + (declare (simple-string line string-table) + (fixnum word-end descriptor-ptr string-ptr)) + (nstring-upcase line :end word-end) + (let* ((hash-loc (get-hash-index dictionary line word-end))) + (unless hash-loc (error "Dictionary Overflow!")) + (setf (aref dictionary hash-loc) descriptor-ptr) + (let* ((hash-code (ldb +new-hash-byte+ + (string-hash line word-end))) + (descriptor (make-descriptor :hash-code hash-code + :length word-end + :string-index string-ptr))) + (setf (desc-flags descriptor) (word-flags line word-end) + (aref descriptors descriptor-ptr) descriptor) + (replace string-table line :start1 string-ptr :end2 word-end)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/classes.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/classes.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/classes.lisp (revision 8058) @@ -0,0 +1,21 @@ +(in-package :spell) + +(defclass dictionary () + ((string-table :accessor string-table :initarg :string-table) + (descriptors :accessor descriptors :initarg :descriptors) + ;; maps from hashes of strings to their corresponding descriptors + (descriptor-table :accessor descriptor-table + :initarg :descriptor-table) + (free-descriptors :accessor free-descriptors + :initarg :free-descriptors + :initform 0) + (free-string-table-bytes :accessor free-string-table-bytes + :initarg :free-string-table-bytes + :initform 0))) + +(defstruct (descriptor + (:conc-name desc-)) + hash-code + length + string-index + flags) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/constants.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/constants.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/constants.lisp (revision 8058) @@ -0,0 +1,61 @@ +(in-package "SPELL") + +(defconstant +spell-deleted-entry+ #xFFFF) + +;;; The next number (using 6 bits) is 63, and that's pretty silly because +;;; "supercalafragalistic" is less than 31 characters long. +;;; +(defconstant +max-entry-length+ 31 + "This the maximum number of characters an entry may have.") + + + +;;; These are the eleven bits of a computed hash that are stored as part of +;;; an entries descriptor unit. The shifting constant is how much the +;;; eleven bits need to be shifted to the right, so they take up the upper +;;; eleven bits of one 16-bit element in a descriptor unit. +;;; +(defconstant +new-hash-byte+ (byte 11 13)) +(defconstant +stored-hash-byte+ (byte 11 5)) + + +;;; The next two constants are used to extract information from an entry's +;;; descriptor unit. The first is the two most significant bits of 18 +;;; bits that hold an index into the string table where the entry is +;;; located. If this is confusing, regard the diagram of the descriptor +;;; units above. +;;; +;;; This is used to break up an 18 bit string table index into two parts +;;; for storage in a word descriptor unit. See the documentation at the +;;; top of Spell-Correct.Lisp. +;;; +(defconstant +whole-index-low-byte+ (byte 16 0)) +(defconstant +whole-index-high-byte+ (byte 2 16)) + +(defconstant +stored-index-high-byte+ (byte 2 14)) +(defconstant +stored-length-byte+ (byte 5 0)) + +(defconstant +spell-alphabet+ + (list #\A #\B #\C #\D #\E #\F #\G #\H + #\I #\J #\K #\L #\M #\N #\O #\P + #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) + +;;; This is the first thing in a spell binary dictionary file to serve as a +;;; quick check of its proposed contents. This particular number is +;;; "BILLS" on a calculator held upside-down. +;;; +(defconstant +magic-file-id+ 57718) + +;;; These constants are derived from the order things are written to the +;;; binary dictionary in Spell-Build.Lisp. +;;; +(defconstant +magic-file-id-loc+ 0) +(defconstant +dictionary-size-loc+ 1) +(defconstant +descriptors-size-loc+ 2) +(defconstant +string-table-size-low-byte-loc+ 3) +(defconstant +string-table-size-high-byte-loc+ 4) +(defconstant +file-header-bytes+ 10) + +;;; bump this up a bit, but do not lower it. TRY-WORD-ENDINGS depends on +;;; this value being at least 4. +(defconstant +minimum-try-word-endings-length+ 4) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/correlate.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/correlate.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/correlate.lisp (revision 8058) @@ -0,0 +1,648 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This is the file that deals with checking and correcting words +;;; using a dictionary read in from a binary file. It has been written +;;; from the basic ideas used in Ispell (on DEC-20's) which originated as +;;; Spell on the ITS machines at MIT. There are flags which have proper +;;; uses defined for them that indicate permissible suffixes to entries. +;;; This allows for about three times as many known words than are actually +;;; stored. When checking the spelling of a word, first it is looked up; +;;; if this fails, then possible roots are looked up, and if any has the +;;; appropriate suffix flag, then the word is considered to be correctly +;;; spelled. For an unknown word, the following rules define "close" words +;;; which are possible corrections: +;;; 1] two adjacent letters are transposed to form a correct spelling; +;;; 2] one letter is changed to form a correct spelling; +;;; 3] one letter is added to form a correct spelling; and/or +;;; 4] one letter is removed to form a correct spelling. +;;; There are two restrictions on the length of a word in regards to its +;;; worthiness of recognition: it must be at least more than two letters +;;; long, and if it has a suffix, then it must be at least four letters +;;; long. More will be said about this when the flags are discussed. +;;; This is implemented in as tense a fashion as possible, and it uses +;;; implementation dependent code from Spell-RT.Lisp to accomplish this. +;;; In general the file I/O and structure accesses encompass the system +;;; dependencies. + +;;; This next section will discuss the storage of the dictionary +;;; information. There are three data structures that "are" the +;;; dictionary: a hash table, descriptors table, and a string table. The +;;; hash table is a vector of type '(unsigned-byte 16), whose elements +;;; point into the descriptors table. This is a cyclic hash table to +;;; facilitate dumping it to a file. The descriptors table (also of type +;;; '(unsigned-byte 16)) dedicates three elements to each entry in the +;;; dictionary. Each group of three elements has the following organization +;;; imposed on them: +;;; ---------------------------------------------- +;;; | 15..5 hash code | 4..0 length | +;;; ---------------------------------------------- +;;; | 15..0 character index | +;;; ---------------------------------------------- +;;; | 15..14 character index | 13..0 flags | +;;; ---------------------------------------------- +;;; "Length" is the number of characters in the entry; "hash code" is some +;;; eleven bits from the hash code to allow for quicker lookup, "flags" +;;; indicate possible suffixes for the basic entry, and "character index" +;;; is the index of the start of the entry in the string table. +;;; This was originally adopted due to the Perq's word size (can you guess? +;;; 16 bits, that's right). Note the constraint that is placed on the number +;;; of the entries, 21845, because the hash table could not point to more +;;; descriptor units (16 bits of pointer divided by three). Since a value of +;;; zero as a hash table element indicates an empty location, the zeroth element +;;; of the descriptors table must be unused (it cannot be pointed to). + + +;;; The following is a short discussion with examples of the correct +;;; use of the suffix flags. Let # and @ be symbols that can stand for any +;;; single letter. Upper case letters are constants. "..." stands for any +;;; string of zero or more letters, but note that no word may exist in the +;;; dictionary which is not at least 2 letters long, so, for example, FLY +;;; may not be produced by placing the "Y" flag on "F". Also, no flag is +;;; effective unless the word that it creates is at least 4 letters long, +;;; so, for example, WED may not be produced by placing the "D" flag on +;;; "WE". These flags and examples are from the Ispell documentation with +;;; only slight modifications. Here are the correct uses of the flags: +;;; +;;; "V" flag: +;;; ...E => ...IVE as in create => creative +;;; if # .ne. E, then ...# => ...#IVE as in prevent => preventive +;;; +;;; "N" flag: +;;; ...E => ...ION as in create => creation +;;; ...Y => ...ICATION as in multiply => multiplication +;;; if # .ne. E or Y, then ...# => ...#EN as in fall => fallen +;;; +;;; "X" flag: +;;; ...E => ...IONS as in create => creations +;;; ...Y => ...ICATIONS as in multiply => multiplications +;;; if # .ne. E or Y, ...# => ...#ENS as in weak => weakens +;;; +;;; "H" flag: +;;; ...Y => ...IETH as in twenty => twentieth +;;; if # .ne. Y, then ...# => ...#TH as in hundred => hundredth +;;; +;;; "Y" FLAG: +;;; ... => ...LY as in quick => quickly +;;; +;;; "G" FLAG: +;;; ...E => ...ING as in file => filing +;;; if # .ne. E, then ...# => ...#ING as in cross => crossing +;;; +;;; "J" FLAG" +;;; ...E => ...INGS as in file => filings +;;; if # .ne. E, then ...# => ...#INGS as in cross => crossings +;;; +;;; "D" FLAG: +;;; ...E => ...ED as in create => created +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IED as in imply => implied +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ED as in convey => conveyed +;;; if # .ne. E or Y, then ...# => ...#ED as in cross => crossed +;;; +;;; "T" FLAG: +;;; ...E => ...EST as in late => latest +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IEST as in dirty => dirtiest +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#EST as in gray => grayest +;;; if # .ne. E or Y, then ...# => ...#EST as in small => smallest +;;; +;;; "R" FLAG: +;;; ...E => ...ER as in skate => skater +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IER as in multiply => multiplier +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ER as in convey => conveyer +;;; if # .ne. E or Y, then ...# => ...#ER as in build => builder +;;; + +;;; "Z FLAG: +;;; ...E => ...ERS as in skate => skaters +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IERS as in multiply => multipliers +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ERS as in slay => slayers +;;; if # .ne. E or Y, then ...@# => ...@#ERS as in build => builders +;;; +;;; "S" FLAG: +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IES as in imply => implies +;;; if # .eq. S, X, Z, or H, +;;; then ...# => ...#ES as in fix => fixes +;;; if # .ne. S, X, Z, H, or Y, +;;; then ...# => ...#S as in bat => bats +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#S as in convey => conveys +;;; +;;; "P" FLAG: +;;; if # .ne. Y, or @ = A, E, I, O, or U, +;;; then ...@# => ...@#NESS as in late => lateness and +;;; gray => grayness +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@INESS as in cloudy => cloudiness +;;; +;;; "M" FLAG: +;;; ... => ...'S as in DOG => DOG'S + +(in-package "SPELL") + + + +;;;; Some Specials and Accesses + +;;; *spell-aeiou* will have bits on that represent the capital letters +;;; A, E, I, O, and U to be used to determine if some word roots are legal +;;; for looking up. +;;; +(defvar *aeiou* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *aeiou* (char-code #\A)) 1) +(setf (aref *aeiou* (char-code #\E)) 1) +(setf (aref *aeiou* (char-code #\I)) 1) +(setf (aref *aeiou* (char-code #\O)) 1) +(setf (aref *aeiou* (char-code #\U)) 1) + + +;;; *sxzh* will have bits on that represent the capital letters +;;; S, X, Z, and H to be used to determine if some word roots are legal for +;;; looking up. +;;; +(defvar *sxzh* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *sxzh* (char-code #\S)) 1) +(setf (aref *sxzh* (char-code #\X)) 1) +(setf (aref *sxzh* (char-code #\Z)) 1) +(setf (aref *sxzh* (char-code #\H)) 1) + + +;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a +;;; character is in the specified set. +;;; +(declaim (inline set-member-p)) +(defun set-member-p (char set) + (not (zerop (the fixnum (aref (the simple-bit-vector set) + (char-code char)))))) + +;;; DESC-TABLE-REF and DESCRIPTOR-REF are references to implementation +;;; dependent structures. +;;; +(declaim (inline desc-table-ref descriptor-ref)) +(defun desc-table-ref (dictionary index) + (aref (descriptor-table dictionary) index)) +(defun %set-desc-table-ref (dictionary index value) + (setf (aref (descriptor-table dictionary) index) value)) + +(defsetf desc-table-ref %set-desc-table-ref) + +(defun descriptor-ref (dictionary index) + (aref (descriptors dictionary) index)) + + +;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx) +;;; descriptor unit (described at the beginning of the file) and returns +;;; the start index of the entry in the string table. The second of three +;;; words in the descriptor holds the 16 least significant bits of 18, and +;;; the top two bits of the third word are the 2 most significant bits. +;;; These 18 bits are the index into the string table. +;;; +(defun descriptor-string-start (dictionary index) + (desc-string-index (descriptor-ref dictionary index))) + + + +;;;; Top level Checking/Correcting + +;;; CORRECT-SPELLING can be called from top level to check/correct a words +;;; spelling. It is not used for any other purpose. +;;; +(defun correct-spelling (dictionary word) + "Check/correct the spelling of word. Output is done to *standard-output*." + (setf word (coerce word 'simple-string)) + (let ((word (string-upcase (the simple-string word))) + (word-len (length (the simple-string word)))) + (declare (simple-string word) (fixnum word-len)) + (when (= word-len 1) + (error "Single character words are not in the dictionary.")) + (when (> word-len +max-entry-length+) + (error "~A is too long for the dictionary." word)) + (multiple-value-bind (idx used-flag-p) + (spell-try-word dictionary word word-len) + (if idx + (format t "Found it~:[~; because of ~A~]." used-flag-p + (spell-root-word dictionary idx)) + (let ((close-words (spell-collect-close-words dictionary word))) + (if close-words + (format *standard-output* + "The possible correct spelling~[~; is~:;s are~]:~ + ~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~ + ~{~#[~; and~] ~A~^,~}~]." + (length close-words) + close-words) + (format *standard-output* "Word not found."))))))) + + +(defun spell-root-word (dictionary index) + "Return the root word corresponding to a dictionary entry at index." + (let* ((descriptor (descriptor-ref dictionary index)) + (start (desc-string-index descriptor)) + (len (desc-length descriptor))) + (declare (fixnum start len)) + ;; return a copy + (subseq (string-table dictionary) start (+ start len)))) + + +;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled +;;; words. The definition of "close" is at the beginning of the file, and +;;; there are four sections to this function which collect each of the four +;;; different kinds of close words. +;;; +(defun spell-collect-close-words (dictionary word) + "Returns a list of all \"close\" correctly spelled words. This has the + same contraints as SPELL-TRY-WORD, which you have probably already called + if you are calling this." + (declare (simple-string word)) + (let* ((word-len (length word)) + (word-len--1 (1- word-len)) + (word-len-+1 (1+ word-len)) + (result ()) + (correcting-buffer (make-string +max-entry-length+))) + (macrolet ((check-closeness (dictionary word word-len closeness-list) + `(when (spell-try-word ,dictionary ,word ,word-len) + (pushnew (subseq ,word 0 ,word-len) + ,closeness-list :test #'string=)))) + (declare (simple-string correcting-buffer) + (fixnum word-len word-len--1 word-len-+1)) + (replace correcting-buffer word :end1 word-len :end2 word-len) + + ;; Misspelled because one letter is different. + (dotimes (i word-len) + (do ((save-char (schar correcting-buffer i)) + (alphabet +spell-alphabet+ (cdr alphabet))) + ((null alphabet) + (setf (schar correcting-buffer i) save-char)) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness dictionary correcting-buffer word-len result))) + + ;; Misspelled because two adjacent letters are transposed. + (dotimes (i word-len--1) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))) + (check-closeness dictionary correcting-buffer word-len result) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))) + + ;; Misspelled because of extraneous letter. + (replace correcting-buffer word + :start2 1 :end1 word-len--1 :end2 word-len) + (check-closeness dictionary correcting-buffer word-len--1 result) + (dotimes (i word-len--1) + (setf (schar correcting-buffer i) (schar word i)) + (replace correcting-buffer word + :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len) + (check-closeness dictionary correcting-buffer word-len--1 result)) + + ;; Misspelled because a letter is missing. + (replace correcting-buffer word + :start1 1 :end1 word-len-+1 :end2 word-len) + (dotimes (i word-len-+1) + (do ((alphabet +spell-alphabet+ (cdr alphabet))) + ((null alphabet) + (rotatef (schar correcting-buffer i) + (schar correcting-buffer (1+ i)))) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness dictionary correcting-buffer word-len-+1 result))) + result))) + +;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it +;;; is part of the definition of the function of looking up words. +;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4. +;;; +(defun spell-try-word (dictionary word word-len) + "See if the word or an appropriate root is in the spelling dicitionary. + Word-len must be inclusively in the range 2..max-entry-length." + (or (lookup-entry dictionary word word-len) + (if (>= (the fixnum word-len) +minimum-try-word-endings-length+) + (try-word-endings dictionary word word-len)))) + + + + +;;;; Divining Correct Spelling + +(eval-when (:compile-toplevel :execute) + +(defmacro setup-root-buffer (word buffer root-len) + `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len)) + +(defmacro try-root (dictionary word root-len flag-mask) + (let ((result (gensym))) + `(let ((,result (lookup-entry ,dictionary ,word ,root-len))) + (if (and ,result (descriptor-flag ,dictionary ,result ,flag-mask)) + (return (values ,result ,flag-mask)))))) + +;;; TRY-MODIFIED-ROOT is used for root words that become truncated +;;; when suffixes are added (e.g., skate => skating). Char-idx is the last +;;; character in the root that has to typically be changed from a #\I to a +;;; #\Y or #\E. +;;; +(defmacro try-modified-root (dictionary word buffer + root-len flag-mask char-idx new-char) + (let ((root-word (gensym))) + `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len))) + (setf (schar ,root-word ,char-idx) ,new-char) + (try-root ,dictionary ,root-word ,root-len ,flag-mask)))) + +) ;eval-when + +(defvar *rooting-buffer* (make-string +max-entry-length+)) + +;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and +;;; returns multiple values on success (the index where the word's root's +;;; descriptor starts and :used-flag), otherwise nil. It looks at +;;; characters from the end to the beginning of the word to determine if it +;;; has any known suffixes. This is a VERY simple finite state machine +;;; where all of the suffixes are narrowed down to one possible one in at +;;; most two state changes. This is a PROG form for speed, and in some sense, +;;; readability. The states of the machine are the flag names that denote +;;; suffixes. The two points of branching to labels are the very beginning +;;; of the PROG and the S state. This is a fairly straight forward +;;; implementation of the flag rules presented at the beginning of this +;;; file, with char-idx checks, so we do not index the string below zero. + +(defun try-word-endings (dictionary word word-len) + (declare (simple-string word) + (fixnum word-len)) + (prog* ((char-idx (1- word-len)) + (char (schar word char-idx)) + (rooting-buffer *rooting-buffer*) + flag-mask) + (declare (simple-string rooting-buffer) + (fixnum char-idx)) + (case char + (#\S (go S)) ;This covers over half of the possible endings + ;by branching off the second to last character + ;to other flag states that have plural endings. + (#\R (setf flag-mask +R-mask+) ;"er" and "ier" + (go D-R-Z-FLAG)) + (#\T (go T-FLAG)) ;"est" and "iest" + (#\D (setf flag-mask +D-mask+) ;"ed" and "ied" + (go D-R-Z-FLAG)) + (#\H (go H-FLAG)) ;"th" and "ieth" + (#\N (setf flag-mask +N-mask+) ;"ion", "ication", and "en" + (go N-X-FLAG)) + (#\G (setf flag-mask +G-mask+) ;"ing" + (go G-J-FLAG)) + (#\Y (go Y-FLAG)) ;"ly" + (#\E (go V-FLAG))) ;"ive" + (return nil) + + S + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root dictionary word (1+ char-idx) +S-mask+) + (return nil)) + (if (not (set-member-p char *sxzh*)) + (try-root dictionary word (1+ char-idx) +S-mask+))) + (case char + (#\E (go S-FLAG)) ;"es" and "ies" + (#\R (setf flag-mask +Z-mask+) ;"ers" and "iers" + (go D-R-Z-FLAG)) + (#\G (setf flag-mask +J-mask+) ;"ings" + (go G-J-FLAG)) + (#\S (go P-FLAG)) ;"ness" and "iness" + (#\N (setf flag-mask +X-mask+) ;"ions", "ications", and "ens" + (go N-X-FLAG)) + (#\' (try-root dictionary word char-idx +M-mask+))) + (return nil) + + S-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (set-member-p char *sxzh*) + (try-root dictionary word (1+ char-idx) +S-mask+)) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root dictionary word rooting-buffer (1+ char-idx) + +S-mask+ char-idx #\Y)) + (return nil) + + D-R-Z-FLAG + (if (char/= (schar word (1- char-idx)) #\E) (return nil)) + (try-root dictionary word char-idx flag-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root dictionary word (1+ char-idx) flag-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root dictionary word (1+ char-idx) flag-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root dictionary word rooting-buffer (1+ char-idx) + flag-mask char-idx #\Y)) + (return nil) + + P-FLAG + (if (or (char/= (schar word (1- char-idx)) #\E) + (char/= (schar word (- char-idx 2)) #\N)) + (return nil)) + (if (<= (setf char-idx (- char-idx 3)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root dictionary word (1+ char-idx) +P-mask+) + (return nil))) + (try-root dictionary word (1+ char-idx) +P-mask+) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root dictionary word rooting-buffer (1+ char-idx) + +P-mask+ char-idx #\Y)) + (return nil) + + G-J-FLAG + (if (< char-idx 3) (return nil)) + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root dictionary word char-idx flag-mask)) + (try-modified-root dictionary word rooting-buffer (1+ char-idx) + flag-mask char-idx #\E) + (return nil) + + N-X-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (cond ((char= char #\E) + (setf char (schar word (1- char-idx))) + (if (and (char/= char #\Y) (char/= char #\E)) + (try-root dictionary word char-idx flag-mask)) + (return nil)) + ((char= char #\O) + (if (char= (schar word (1- char-idx)) #\I) + (try-modified-root dictionary word rooting-buffer char-idx + flag-mask (1- char-idx) #\E) + (return nil)) + (if (< char-idx 5) (return nil)) + (if (or (char/= (schar word (- char-idx 2)) #\T) + (char/= (schar word (- char-idx 3)) #\A) + (char/= (schar word (- char-idx 4)) #\C) + (char/= (schar word (- char-idx 5)) #\I)) + (return nil) + (setf char-idx (- char-idx 4))) + (try-modified-root dictionary word rooting-buffer char-idx + flag-mask (1- char-idx) #\Y)) + (t (return nil))) + + T-FLAG + (if (or (char/= (schar word (1- char-idx)) #\S) + (char/= (schar word (- char-idx 2)) #\E)) + (return nil) + (setf char-idx (1- char-idx))) + (try-root dictionary word char-idx +T-mask+) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root dictionary word (1+ char-idx) +T-mask+) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root dictionary word (1+ char-idx) +T-mask+))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root dictionary word rooting-buffer (1+ char-idx) + +T-mask+ char-idx #\Y)) + (return nil) + + H-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char/= char #\T) (return nil)) + (if (char/= (schar word (1- char-idx)) #\Y) + (try-root dictionary word char-idx +H-mask+)) + (if (and (char= (schar word (1- char-idx)) #\E) + (char= (schar word (- char-idx 2)) #\I)) + (try-modified-root dictionary word rooting-buffer (1- char-idx) + +H-mask+ (- char-idx 2) #\Y)) + (return nil) + + Y-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\L) + (try-root dictionary word char-idx +Y-mask+)) + (return nil) + + V-FLAG + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root dictionary word char-idx +V-mask+)) + (try-modified-root dictionary word rooting-buffer (1+ char-idx) + +V-mask+ char-idx #\E) + (return nil))) + + + +;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on. +;;; From the diagram at the beginning of the file, we see that the flags +;;; are stored two words off of the first word in the descriptor unit for +;;; an entry. +;;; +;;; Note: modified for new descriptor scheme +(defun descriptor-flag (dictionary descriptor flag-mask) + (not (zerop + (the fixnum + (logand + (the fixnum (desc-flags (descriptor-ref dictionary descriptor))) + (the fixnum flag-mask)))))) + + + +;;;; Looking up Trials + +;;; these functions used to be macros +(declaim (inline spell-string= found-entry-p)) + +(defun spell-string= (string1 string2 end1 start2) + (string= string1 string2 + :end1 end1 + :start2 start2 + :end2 (+ start2 end1))) + +;;; FOUND-ENTRY-P determines if entry is what is described at idx. +;;; Hash-and-length is 16 bits that look just like the first word of any +;;; entry's descriptor unit (see diagram at the beginning of the file). If +;;; the word stored at idx and entry have the same hash bits and length, +;;; then we compare characters to see if they are the same. +;;; +(defun found-entry-p (dictionary idx entry entry-len hash) + (let ((desc (descriptor-ref dictionary idx))) + (if (and (= (desc-hash-code desc) hash) + (= (desc-length desc) entry-len)) + hash + (spell-string= entry (string-table dictionary) entry-len + (desc-string-index desc))))) + +(eval-when (:compile-toplevel :execute) + +(defmacro hash2-loop ((location-var contents-var) + dictionary loc hash zero-contents-form + &optional body-form (for-insertion-p nil)) + (let ((incr (gensym))) + `(let* ((,incr (hash-increment ,hash +new-dictionary-size+)) + (,location-var ,loc) + (,contents-var 0)) + (declare (fixnum ,location-var ,contents-var ,incr)) + (loop (setf ,location-var + (rem (+ ,location-var ,incr) (the fixnum +new-dictionary-size+))) + (setf ,contents-var (desc-table-ref ,dictionary ,location-var)) + (if (zerop ,contents-var) (return ,zero-contents-form)) + ,@(if for-insertion-p + `((if (= ,contents-var spell-deleted-entry) + (return ,zero-contents-form)))) + (if (= ,location-var ,loc) (return nil)) + ,@(if body-form `(,body-form)))))) + +) ;eval-when + + +;;; LOOKUP-ENTRY returns the index of the first element of entry's +;;; descriptor unit on success, otherwise nil. +;;; +(defun lookup-entry (dictionary entry &optional length) + (declare (simple-string entry)) + (let* ((entry-length (or length (length entry))) + (hash (string-hash entry entry-length)) + (loc (rem hash (the fixnum +new-dictionary-size+))) + (loc-contents (desc-table-ref dictionary loc))) + (declare (fixnum entry-length hash loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p dictionary loc-contents entry entry-length hash) + loc-contents) + (t + (hash2-loop (loop-loc loc-contents) + dictionary loc hash + nil + (if (found-entry-p dictionary loc-contents entry + entry-length hash) + (return loc-contents))))))) + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/flags.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/flags.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/flags.lisp (revision 8058) @@ -0,0 +1,43 @@ +(in-package "SPELL") + +;;; FIXME: show where these things are documented +(defconstant +V-mask+ (ash 1 13)) +(defconstant +N-mask+ (ash 1 12)) +(defconstant +X-mask+ (ash 1 11)) +(defconstant +H-mask+ (ash 1 10)) +(defconstant +Y-mask+ (ash 1 9)) +(defconstant +G-mask+ (ash 1 8)) +(defconstant +J-mask+ (ash 1 7)) +(defconstant +D-mask+ (ash 1 6)) +(defconstant +T-mask+ (ash 1 5)) +(defconstant +R-mask+ (ash 1 4)) +(defconstant +Z-mask+ (ash 1 3)) +(defconstant +S-mask+ (ash 1 2)) +(defconstant +P-mask+ (ash 1 1)) +(defconstant +M-mask+ 1) + +(defconstant flag-names-to-masks + `((#\V . ,+V-mask+) (#\N . ,+N-mask+) (#\X . ,+X-mask+) + (#\H . ,+H-mask+) (#\Y . ,+Y-mask+) (#\G . ,+G-mask+) + (#\J . ,+J-mask+) (#\D . ,+D-mask+) (#\T . ,+T-mask+) + (#\R . ,+R-mask+) (#\Z . ,+Z-mask+) (#\S . ,+S-mask+) + (#\P . ,+P-mask+) (#\M . ,+M-mask+))) + +(defvar *flag-masks* + (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) + "This holds the masks for character flags, which is used when reading + a text file of dictionary words. Illegal character flags hold zero.") + +(declaim (inline flag-mask)) +(defun flag-mask (char) + (aref *flag-masks* (char-code char))) +(defun %set-flag-mask (char value) + (setf (aref *flag-masks* (char-code char)) value)) + +(defsetf flag-mask %set-flag-mask) + +(dolist (e flag-names-to-masks) + (let ((char (car e)) + (mask (cdr e))) + (setf (flag-mask char) mask) + (setf (flag-mask (char-downcase char)) mask))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/hashing.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/hashing.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/hashing.lisp (revision 8058) @@ -0,0 +1,14 @@ +(in-package "SPELL") + +;;; FIXME: the original code included the below comment; obviously, it +;;; utilized implementation-specific primitives to speed up hashing. is +;;; this reasonable to do? +;;; +;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes +;;; an end argument, so we do not have to use SXHASH. SXHASH would mean +;;; doing a SUBSEQ of entry. +(declaim (inline string-hash)) +(defun string-hash (string length) + (if (= length (length string)) + (sxhash string) + (sxhash (subseq string 0 length)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/io.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/io.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/io.lisp (revision 8058) @@ -0,0 +1,95 @@ +(in-package "SPELL") + +(defparameter default-binary-dictionary #p"HOME:spell.bin") + +(defconstant +descriptor-bytes+ 10 + "The number of bytes a descriptor takes up on disk.") + +;;; going for ease of writing on this first pass. later we'll pack things +;;; together a little bit more and document it. +(defun read-descriptor (stream) + (let ((hash-code (read-byte stream)) + (length (read-byte stream)) + (low-index (read-byte stream)) + (high-index (read-byte stream)) + (flags (read-byte stream))) + (make-descriptor :hash-code hash-code + :length length + :char-index (dpb high-index +whole-index-high-byte+ + low-index) + :flags flags))) + +(defun write-descriptor (descriptor stream) + (write-byte (desc-hash-code descriptor) stream) + (write-byte (desc-length descriptor) stream) + (write-byte (ldb +whole-index-low-byte+ (desc-string-index descriptor)) + stream) + (write-byte (ldb +whole-index-high-byte+ (desc-string-index descriptor)) + stream) + (write-byte (desc-flags descriptor) stream) + (values)) + +(defun write-dictionary (filename dictionary entry-count string-table-length) + (declare (fixnum string-table-length)) + (with-open-file (s filename + :direction :output + :element-type '(unsigned-byte 16) + :if-exists :overwrite + :if-does-not-exist :create) + (write-byte +magic-file-id+ s) + (write-byte +new-dictionary-size+ s) + (write-byte entry-count s) + (write-byte (ldb +whole-index-low-byte+ string-table-length) s) + (write-byte (ldb +whole-index-high-byte+ string-table-length) s) + (dotimes (i +new-dictionary-size+) + (write-byte (aref (descriptor-table dictionary) i) s)) + (dotimes (i entry-count) + ;; hack, because the 0th element goes unused. see if we can + ;; fix this assumption in the code elsewhere + (unless (zerop i) + (write-descriptor (aref (descriptors dictionary) i) s))) + (with-open-file (s filename + :direction :output + :element-type 'base-char + :if-exists :append) + (write-string (string-table dictionary) + s :end string-table-length)))) + +(defun read-dictionary (&optional (filename default-binary-dictionary)) + (with-open-file (stream filename + :direction :input + :if-does-not-exist :error + :element-type '(unsigned-byte 16)) + (let* ((header (make-array 5 :element-type '(unsigned-byte 16))) + (header-len (read-sequence header stream))) + (unless (= header-len 5) + (error "File is not a dictionary: ~S." filename)) + (unless (= (aref header 0) +magic-file-id+) + (error "File is not a dictionary: ~S." filename)) + (let* ((dict-size (read-byte stream)) + (entry-count (read-byte stream)) + (string-table-length-low (read-byte stream)) + (string-table-length-high (read-byte stream)) + (string-table-length (dpb string-table-length-high + +whole-index-high-byte+ + string-table-length-low)) + (word-table (make-array dict-size + :element-type '(unsigned-byte 16))) + (descriptors (make-array (1+ entry-count) + :initial-element nil)) + (string-table (make-array string-table-length + :element-type 'base-char))) + (read-sequence word-table stream) + (dotimes (i entry-count) + (setf (aref descriptors (1+ i)) (read-descriptor stream))) + (with-open-file (s filename + :direction :input + :if-does-not-exist :error + :element-type 'base-char) + ;; ??? is this portable? + (file-position s (file-position stream)) + (read-sequence string-table s)) + (make-instance 'dictionary + :string-table string-table + :descriptors descriptors + :descriptor-table word-table))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/package.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/package.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/package.lisp (revision 8058) @@ -0,0 +1,7 @@ +(defpackage "SPELL" + (:use "COMMON-LISP") + (:export #:spell-try-word #:spell-root-word #:spell-collect-close-words + #:correct-spelling + #:+max-entry-length+ + #:spell-read-dictionary #:spell-add-entry #:spell-root-flags + #:spell-remove-entry)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell-aug.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell-aug.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell-aug.lisp (revision 8058) @@ -0,0 +1,181 @@ +; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; +;;; This file contains the code to grow the spelling dictionary in system +;;; space by reading a text file of entries or adding one at a time. This +;;; code relies on implementation dependent code found in Spell-RT.Lisp. + + +(in-package "SPELL") + + + +;;;; String and Hashing Macros + +(eval-when (:compile-toplevel :execute) + +(defmacro string-table-replace (src-string dst-start length) + `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) + +;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for +;;; adding a new entry. If a location contains a zero, then it has never been +;;; used, and no entries have ever been "hashed past" it. If a location +;;; contains SPELL-DELETED-ENTRY, then it once contained an entry that has +;;; since been deleted. +;;; +(defmacro hash-entry (entry entry-len) + (let ((loop-loc (gensym)) (loc-contents (gensym)) + (hash (gensym)) (loc (gensym))) + `(let* ((,hash (string-hash ,entry ,entry-len)) + (,loc (rem ,hash (the fixnum *dictionary-size*))) + (,loc-contents (dictionary-ref ,loc))) + (declare (fixnum ,loc ,loc-contents)) + (if (or (zerop ,loc-contents) (= ,loc-contents spell-deleted-entry)) + ,loc + (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash + ,loop-loc nil t))))) + +) ;eval-when + + + + +;;;; Top Level Stuff + +(defun spell-read-dictionary (dictionary filename) + "Add entries to DICTIONARY from lines in the file FILENAME." + (with-open-file (s filename :direction :input) + (loop (multiple-value-bind (entry eofp) (read-line s nil nil) + (declare (type (or simple-string null) entry)) + (unless entry (return)) + (spell-add-entry entry) + (if eofp (return)))))) + + +(defun spell-add-entry (dictionary line &optional + (word-end (or (position #\/ line :test #'char=) + (length line)))) + "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and + added to the spelling dictionary. Line is destructively modified." + (declare (simple-string line) (fixnum word-end)) + (nstring-upcase line :end word-end) + (when (> word-end max-entry-length) + (return-from spell-add-entry nil)) + (let ((entry (lookup-entry line word-end))) + (when entry + (add-flags (+ entry 2) line word-end) + (return-from spell-add-entry nil))) + (let* ((hash-loc (hash-entry line word-end)) + (string-ptr *string-table-size*) + (desc-ptr *descriptors-size*) + (desc-ptr+1 (1+ desc-ptr)) + (desc-ptr+2 (1+ desc-ptr+1))) + (declare (fixnum string-ptr)) + (when (not hash-loc) (error "Dictionary Overflow!")) + (when (> 3 *free-descriptor-elements*) (grow-descriptors)) + (when (> word-end *free-string-table-bytes*) (grow-string-table)) + (decf *free-descriptor-elements* 3) + (incf *descriptors-size* 3) + (decf *free-string-table-bytes* word-end) + (incf *string-table-size* word-end) + (setf (dictionary-ref hash-loc) desc-ptr) + (let ((desc (make-descriptor :hash-code (ldb new-hash-byte + (string-hash line word-end)) + :length word-end + :string-index string-ptr + :flags (word-flags line word-end)))) + (add-flags desc-ptr+2 line word-end) + (string-table-replace line string-ptr word-end)) + t) + +;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from +;;; the dictionary. First entry is looked up, and if it is found due to a +;;; flag, the flag is cleared in the descriptor table. If entry is a root +;;; word in the dictionary (that is, looked up without the use of a flag), +;;; then the root and all its derivitives are deleted by setting its +;;; dictionary location to spell-deleted-entry. +;;; +(defun spell-remove-entry (dictionary entry) + "Removes ENTRY from DICTIONARY, so it will be an unknown word. Entry + is a simple string and is destructively modified. If entry is a root + word, then all words derived with entry and its flags will also be deleted." + (declare (simple-string entry)) + (nstring-upcase entry) + (let ((entry-len (length entry))) + (declare (fixnum entry-len)) + (when (<= 2 entry-len max-entry-length) + (multiple-value-bind (index flagp) + (spell-try-word entry entry-len) + (when index + (if flagp + (setf (descriptor-ref (+ 2 index)) + (logandc2 (descriptor-ref (+ 2 index)) flagp)) + (let* ((hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + (setf (dictionary-ref loc) spell-deleted-entry)) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (when (found-entry-p loc-contents entry + entry-len hash-and-len) + (setf (dictionary-ref loop-loc) + spell-deleted-entry) + (return spell-deleted-entry)))))))))))) + +(defun spell-root-flags (dictionary index) + "Return the flags associated with the root word corresponding to a + dictionary entry at index." + (let* ((descriptor (descriptor-ref dictionary index)) + (desc-flags (desc-flags descriptor))) + (loop for element in flag-names-to-masks + unless (zerop (logand (cdr element) desc-flags)) + collect (car element)))) + + + +;;;; Growing Dictionary Structures + +;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. +;;; +(defun grow-descriptors (dictionary) + (let* ((old-size (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))) + (new-size (truncate (* old-size 1.1))) + (new-bytes (* new-size 2)) + (new-sap (allocate-bytes new-bytes))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *descriptors* 0 0 + (* 2 (the fixnum *descriptors-size*))) + (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) + (setf *free-descriptor-elements* + (- new-size (the fixnum *descriptors-size*))) + (setf *descriptors* new-sap))) + +;;; GROW-STRING-TABLE grows the string table by 10%. +;;; +(defun grow-string-table (dictionary) + (let* ((old-size (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*))) + (new-size (truncate (* old-size 1.1))) + (new-sap (allocate-bytes new-size))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *string-table* 0 0 *string-table-size*) + (setf *free-string-table-bytes* + (- new-size (the fixnum *string-table-size*))) + (deallocate-bytes (system-address *string-table*) old-size) + (setf *string-table* new-sap))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell-dictionary.text =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell-dictionary.text (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell-dictionary.text (revision 8058) @@ -0,0 +1,15505 @@ +AAAI +ABACK +ABAFT +ABANDON/D/G/S +ABANDONMENT +ABASE/D/G/S +ABASEMENT/S +ABASH/D/G/S +ABATE/D/R/G/S +ABATEMENT/S +ABBE +ABBEY/M/S +ABBOT/M/S +ABBREVIATE/D/G/N/X/S +ABDOMEN/M/S +ABDOMINAL +ABDUCT/D/S +ABDUCTION/M/S +ABDUCTOR/M/S +ABED +ABERRANT +ABERRATION/S +ABET/S +ABETTED +ABETTER +ABETTING +ABETTOR +ABEYANCE +ABHOR/S +ABHORRED +ABHORRENT +ABHORRER +ABHORRING +ABIDE/D/G/S +ABILITY/M/S +ABJECT/P/Y +ABJECTION/S +ABJURE/D/G/S +ABLATE/D/G/N/V/S +ABLAZE +ABLE/T/R +ABLUTE +ABLY +ABNORMAL/Y +ABNORMALITY/S +ABOARD +ABODE/M/S +ABOLISH/D/R/Z/G/S +ABOLISHMENT/M/S +ABOLITION +ABOLITIONIST/S +ABOMINABLE +ABORIGINAL +ABORIGINE/M/S +ABORT/D/G/V/S +ABORTION/M/S +ABORTIVE/Y +ABOUND/D/G/S +ABOUT +ABOVE +ABOVEGROUND +ABRADE/D/G/S +ABRASION/M/S +ABREACTION/S +ABREAST +ABRIDGE/D/G/S +ABRIDGMENT +ABROAD +ABROGATE/D/G/S +ABRUPT/P/Y +ABSCESS/D/S +ABSCISSA/M/S +ABSCOND/D/G/S +ABSENCE/M/S +ABSENT/D/G/Y/S +ABSENTEE/M/S +ABSENTEEISM +ABSENTIA +ABSENTMINDED +ABSINTHE +ABSOLUTE/P/N/Y/S +ABSOLVE/D/G/S +ABSORB/D/R/G/S +ABSORBENCY +ABSORBENT +ABSORPTION/M/S +ABSORPTIVE +ABSTAIN/D/R/G/S +ABSTENTION/S +ABSTINENCE +ABSTRACT/P/D/G/Y/S +ABSTRACTION/M/S +ABSTRACTIONISM +ABSTRACTIONIST +ABSTRACTOR/M/S +ABSTRUSE/P +ABSURD/Y +ABSURDITY/M/S +ABUNDANCE +ABUNDANT/Y +ABUSE/D/G/V/S +ABUT/S +ABUTMENT +ABUTTED +ABUTTER/M/S +ABUTTING +ABYSMAL/Y +ABYSS/M/S +ACACIA +ACADEMIA +ACADEMIC/S +ACADEMICALLY +ACADEMY/M/S +ACCEDE/D/S +ACCELERATE/D/G/N/X/S +ACCELERATOR/S +ACCELEROMETER/M/S +ACCENT/D/G/S +ACCENTUAL +ACCENTUATE/D/G/N/S +ACCEPT/D/R/Z/G/S +ACCEPTABILITY +ACCEPTABLE +ACCEPTABLY +ACCEPTANCE/M/S +ACCEPTOR/M/S +ACCESS/D/G/S +ACCESSIBILITY +ACCESSIBLE +ACCESSIBLY +ACCESSION/M/S +ACCESSOR/M/S +ACCESSORY/M/S +ACCIDENT/M/S +ACCIDENTAL/Y +ACCLAIM/D/G/S +ACCLAMATION +ACCLIMATE/D/G/S +ACCLIMATIZATION +ACCLIMATIZED +ACCOLADE/S +ACCOMMODATE/D/G/N/X/S +ACCOMPANIMENT/M/S +ACCOMPANIST/M/S +ACCOMPANY/D/G/S +ACCOMPLICE/S +ACCOMPLISH/D/R/Z/G/S +ACCOMPLISHMENT/M/S +ACCORD/D/R/Z/G/S +ACCORDANCE +ACCORDINGLY +ACCORDION/M/S +ACCOST/D/G/S +ACCOUNT/D/G/S +ACCOUNTABILITY +ACCOUNTABLE +ACCOUNTABLY +ACCOUNTANCY +ACCOUNTANT/M/S +ACCOUTREMENT/S +ACCREDIT/D +ACCREDITATION/S +ACCRETION/M/S +ACCRUE/D/G/S +ACCULTURATE/D/G/N/S +ACCUMULATE/D/G/N/X/S +ACCUMULATOR/M/S +ACCURACY/S +ACCURATE/P/Y +ACCURSED +ACCUSAL +ACCUSATION/M/S +ACCUSATIVE +ACCUSE/D/R/G/S +ACCUSINGLY +ACCUSTOM/D/G/S +ACE/M/S +ACETATE +ACETONE +ACETYLENE +ACHE/D/G/S +ACHIEVABLE +ACHIEVE/D/R/Z/G/S +ACHIEVEMENT/M/S +ACHILLES +ACID/Y/S +ACIDIC +ACIDITY/S +ACIDULOUS +ACKNOWLEDGE/D/R/Z/G/S +ACKNOWLEDGMENT/M/S +ACM +ACME +ACNE +ACOLYTE/S +ACORN/M/S +ACOUSTIC/S +ACOUSTICAL/Y +ACOUSTICIAN +ACQUAINT/D/G/S +ACQUAINTANCE/M/S +ACQUIESCE/D/G/S +ACQUIESCENCE +ACQUIRABLE +ACQUIRE/D/G/S +ACQUISITION/M/S +ACQUISITIVENESS +ACQUIT/S +ACQUITTAL +ACQUITTED +ACQUITTER +ACQUITTING +ACRE/M/S +ACREAGE +ACRID +ACRIMONIOUS +ACRIMONY +ACROBAT/M/S +ACROBATIC/S +ACRONYM/M/S +ACROPOLIS +ACROSS +ACRYLIC +ACT/D/G/V/S +ACTINIUM +ACTINOMETER/S +ACTION/M/S +ACTIVATE/D/G/N/X/S +ACTIVATOR/M/S +ACTIVELY +ACTIVISM +ACTIVIST/M/S +ACTIVITY/M/S +ACTOR/M/S +ACTRESS/M/S +ACTUAL/Y/S +ACTUALITY/S +ACTUALIZATION +ACTUARIAL/Y +ACTUATE/D/G/S +ACTUATOR/M/S +ACUITY +ACUMEN +ACUTE/P/Y +ACYCLIC +ACYCLICALLY +AD +ADAGE/S +ADAGIO/S +ADAMANT/Y +ADAPT/D/R/Z/G/V/S +ADAPTABILITY +ADAPTABLE +ADAPTATION/M/S +ADAPTIVELY +ADAPTOR/S +ADD/D/R/Z/G/S +ADDENDA +ADDENDUM +ADDICT/D/G/S +ADDICTION/M/S +ADDISON +ADDITION/M/S +ADDITIONAL/Y +ADDITIVE/M/S +ADDITIVITY +ADDRESS/D/R/Z/G/S +ADDRESSABILITY +ADDRESSABLE +ADDRESSEE/M/S +ADDUCE/D/G/S +ADDUCIBLE +ADDUCT/D/G/S +ADDUCTION +ADDUCTOR +ADEPT +ADEQUACY/S +ADEQUATE/Y +ADHERE/D/R/Z/G/S +ADHERENCE +ADHERENT/M/S +ADHESION/S +ADHESIVE/M/S +ADIABATIC +ADIABATICALLY +ADIEU +ADJACENCY +ADJACENT +ADJECTIVE/M/S +ADJOIN/D/G/S +ADJOURN/D/G/S +ADJOURNMENT +ADJUDGE/D/G/S +ADJUDICATE/D/G/S +ADJUDICATION/M/S +ADJUNCT/M/S +ADJURE/D/G/S +ADJUST/D/R/Z/G/S +ADJUSTABLE +ADJUSTABLY +ADJUSTMENT/M/S +ADJUSTOR/M/S +ADJUTANT/S +ADMINISTER/D/G/J/S +ADMINISTRATION/M/S +ADMINISTRATIVE/Y +ADMINISTRATOR/M/S +ADMIRABLE +ADMIRABLY +ADMIRAL/M/S +ADMIRALTY +ADMIRATION/S +ADMIRE/D/R/Z/G/S +ADMIRING/Y +ADMISSIBILITY +ADMISSIBLE +ADMISSION/M/S +ADMIT/S +ADMITTANCE +ADMITTED/Y +ADMITTER/S +ADMITTING +ADMIX/D/S +ADMIXTURE +ADMONISH/D/G/S +ADMONISHMENT/M/S +ADMONITION/M/S +ADO +ADOBE +ADOLESCENCE +ADOLESCENT/M/S +ADOPT/D/R/Z/G/V/S +ADOPTION/M/S +ADORABLE +ADORATION +ADORE/D/S +ADORN/D/S +ADORNMENT/M/S +ADRENAL +ADRENALINE +ADRIFT +ADROIT/P +ADS +ADSORB/D/G/S +ADSORPTION +ADULATION +ADULT/M/S +ADULTERATE/D/G/S +ADULTERER/M/S +ADULTEROUS/Y +ADULTERY +ADULTHOOD +ADUMBRATE/D/G/S +ADVANCE/D/G/S +ADVANCEMENT/M/S +ADVANTAGE/D/S +ADVANTAGEOUS/Y +ADVENT +ADVENTIST/S +ADVENTITIOUS +ADVENTURE/D/R/Z/G/S +ADVENTUROUS +ADVERB/M/S +ADVERBIAL +ADVERSARY/M/S +ADVERSE/Y +ADVERSITY/S +ADVERTISE/D/R/Z/G/S +ADVERTISEMENT/M/S +ADVICE +ADVISABILITY +ADVISABLE +ADVISABLY +ADVISE/D/R/Z/G/S +ADVISEDLY +ADVISEE/M/S +ADVISEMENT/S +ADVISOR/M/S +ADVISORY +ADVOCACY +ADVOCATE/D/G/S +AEGIS +AERATE/D/G/N/S +AERATOR/S +AERIAL/M/S +AEROACOUSTIC +AEROBIC/S +AERODYNAMIC/S +AERONAUTIC/S +AERONAUTICAL +AEROSOL/S +AEROSOLIZE +AEROSPACE +AESTHETIC/M/S +AESTHETICALLY +AFAR +AFFABLE +AFFAIR/M/S +AFFECT/D/G/V/S +AFFECTATION/M/S +AFFECTINGLY +AFFECTION/M/S +AFFECTIONATE/Y +AFFECTOR +AFFERENT +AFFIANCED +AFFIDAVIT/M/S +AFFILIATE/D/G/N/X/S +AFFINITY/M/S +AFFIRM/D/G/S +AFFIRMATION/M/S +AFFIRMATIVE/Y +AFFIX/D/G/S +AFFLICT/D/G/V/S +AFFLICTION/M/S +AFFLUENCE +AFFLUENT +AFFORD/D/G/S +AFFORDABLE +AFFRICATE/S +AFFRIGHT +AFFRONT/D/G/S +AFGHAN/S +AFGHANISTAN +AFICIONADO +AFIELD +AFIRE +AFLAME +AFLOAT +AFOOT +AFORE +AFOREMENTIONED +AFORESAID +AFORETHOUGHT +AFOSR +AFOUL +AFRAID +AFRESH +AFRICA +AFRICAN/S +AFT/R +AFTEREFFECT +AFTERMATH +AFTERMOST +AFTERNOON/M/S +AFTERSHOCK/S +AFTERTHOUGHT/S +AFTERWARD/S +AGAIN +AGAINST +AGAPE +AGAR +AGATE/S +AGE/D/R/Z/G/S +AGELESS +AGENCY/M/S +AGENDA/M/S +AGENT/M/S +AGGLOMERATE/D/N/S +AGGLUTINATE/D/G/N/S +AGGLUTININ/S +AGGRAVATE/D/N/S +AGGREGATE/D/G/N/X/Y/S +AGGRESSION/M/S +AGGRESSIVE/P/Y +AGGRESSOR/S +AGGRIEVE/D/G/S +AGHAST +AGILE/Y +AGILITY +AGITATE/D/G/N/X/S +AGITATOR/M/S +AGLEAM +AGLOW +AGNOSTIC/M/S +AGO +AGOG +AGONIZE/D/G/S +AGONY/S +AGRARIAN +AGREE/D/R/Z/S +AGREEABLE/P +AGREEABLY +AGREEING +AGREEMENT/M/S +AGRICULTURAL/Y +AGRICULTURE +AGUE +AH +AHEAD +AI +AID/D/G/S +AIDE/D/G/S +AIL/G +AILERON/S +AILMENT/M/S +AIM/D/R/Z/G/S +AIMLESS/Y +AIR/D/R/Z/G/J/S +AIRBAG/S +AIRBORNE +AIRCRAFT +AIRDROP/S +AIREDALE +AIRFIELD/M/S +AIRFLOW +AIRFOIL/S +AIRFRAME/S +AIRILY +AIRLESS +AIRLIFT/M/S +AIRLINE/R/S +AIRLOCK/M/S +AIRMAIL/S +AIRMAN +AIRMEN +AIRPLANE/M/S +AIRPORT/M/S +AIRSHIP/M/S +AIRSPACE +AIRSPEED +AIRSTRIP/M/S +AIRWAY/M/S +AIRY +AISLE +AJAR +AKIMBO +AKIN +AL/M +ALABAMA +ALABAMIAN +ALABASTER +ALACRITY +ALARM/D/G/S +ALARMINGLY +ALARMIST +ALAS +ALASKA +ALBA +ALBACORE +ALBANIA +ALBANIAN/S +ALBEIT +ALBUM/S +ALBUMIN +ALCHEMY +ALCIBIADES +ALCOHOL/M/S +ALCOHOLIC/M/S +ALCOHOLISM +ALCOVE/M/S +ALDEN +ALDER +ALDERMAN/M +ALDERMEN +ALE/V +ALEE +ALERT/P/D/R/Z/G/Y/S +ALERTEDLY +ALEXANDER/M +ALFALFA +ALFRED/M +ALFRESCO +ALGA +ALGAE +ALGAECIDE +ALGEBRA/M/S +ALGEBRAIC +ALGEBRAICALLY +ALGERIA +ALGERIAN +ALGINATE +ALGOL +ALGORITHM/M/S +ALGORITHMIC +ALGORITHMICALLY +ALIAS/D/G/S +ALIBI/M/S +ALIEN/M/S +ALIENATE/D/G/N/S +ALIGHT +ALIGN/D/G/S +ALIGNMENT/S +ALIKE +ALIMENT/S +ALIMONY +ALKALI/M/S +ALKALINE +ALKALOID/M/S +ALKYL +ALL +ALLAH/M +ALLAY/D/G/S +ALLEGATION/M/S +ALLEGE/D/G/S +ALLEGEDLY +ALLEGIANCE/M/S +ALLEGORIC +ALLEGORICAL/Y +ALLEGORY/M/S +ALLEGRETTO/M/S +ALLEGRO/M/S +ALLELE/S +ALLEMANDE +ALLEN/M +ALLERGIC +ALLERGY/M/S +ALLEVIATE/D/R/Z/G/N/S +ALLEY/M/S +ALLEYWAY/M/S +ALLIANCE/M/S +ALLIGATOR/M/S +ALLITERATION/M/S +ALLITERATIVE +ALLOCATE/D/G/N/X/S +ALLOCATOR/M/S +ALLOPHONE/S +ALLOPHONIC +ALLOT/S +ALLOTMENT/M/S +ALLOTTED +ALLOTTER +ALLOTTING +ALLOW/D/G/S +ALLOWABLE +ALLOWABLY +ALLOWANCE/M/S +ALLOY/M/S +ALLUDE/D/G/S +ALLURE/G +ALLUREMENT +ALLUSION/M/S +ALLUSIVE/P +ALLY/D/G/S +ALMA +ALMANAC/M/S +ALMIGHTY +ALMOND/M/S +ALMONER +ALMOST +ALMS +ALMSMAN +ALNICO +ALOE/S +ALOFT +ALOHA +ALONE/P +ALONG +ALONGSIDE +ALOOF/P +ALOUD +ALPHA +ALPHABET/M/S +ALPHABETIC/S +ALPHABETICAL/Y +ALPHABETIZE/D/G/S +ALPHANUMERIC +ALPINE +ALPS +ALREADY +ALSO +ALTAR/M/S +ALTER/D/R/Z/G/S +ALTERABLE +ALTERATION/M/S +ALTERCATION/M/S +ALTERNATE/D/G/N/X/V/Y/S +ALTERNATIVE/Y/S +ALTERNATOR/M/S +ALTHOUGH +ALTITUDE/S +ALTMODE +ALTO/M/S +ALTOGETHER +ALTRUISM +ALTRUIST +ALTRUISTIC +ALTRUISTICALLY +ALUM +ALUMINUM +ALUMNA/M +ALUMNAE +ALUMNI +ALUMNUS +ALUNDUM +ALVEOLAR +ALVEOLI +ALVEOLUS +ALWAYS +ALZHEIMER/M +AM/N +AMAIN +AMALGAM/M/S +AMALGAMATE/D/G/N/S +AMANUENSIS +AMASS/D/G/S +AMATEUR/M/S +AMATEURISH/P +AMATEURISM +AMATORY +AMAZE/D/R/Z/G/S +AMAZEDLY +AMAZEMENT +AMAZING/Y +AMAZON/M/S +AMBASSADOR/M/S +AMBER +AMBIANCE +AMBIDEXTROUS/Y +AMBIENT +AMBIGUITY/M/S +AMBIGUOUS/Y +AMBITION/M/S +AMBITIOUS/Y +AMBIVALENCE +AMBIVALENT/Y +AMBLE/D/R/G/S +AMBROSIAL +AMBULANCE/M/S +AMBULATORY +AMBUSCADE +AMBUSH/D/S +AMDAHL/M +AMELIA +AMELIORATE/D/G +AMENABLE +AMEND/D/G/S +AMENDMENT/M/S +AMENITY/S +AMENORRHEA +AMERICA/M/S +AMERICAN/M/S +AMERICANA +AMERICIUM +AMIABLE +AMICABLE +AMICABLY +AMID +AMIDE +AMIDST +AMIGO +AMINO +AMISS +AMITY +AMMO +AMMONIA +AMMONIAC +AMMONIUM +AMMUNITION +AMNESTY +AMOEBA/M/S +AMOK +AMONG +AMONGST +AMORAL +AMORALITY +AMORIST +AMOROUS +AMORPHOUS/Y +AMORTIZE/D/G/S +AMOUNT/D/R/Z/G/S +AMOUR +AMP/Y/S +AMPERE/S +AMPERSAND/M/S +AMPHETAMINE/S +AMPHIBIAN/M/S +AMPHIBIOUS/Y +AMPHIBOLOGY +AMPHITHEATER/M/S +AMPLE +AMPLIFY/D/R/Z/G/N/S +AMPLITUDE/M/S +AMPOULE/M/S +AMPUTATE/D/G/S +AMSTERDAM +AMTRAK +AMULET/S +AMUSE/D/R/Z/G/S +AMUSEDLY +AMUSEMENT/M/S +AMUSINGLY +AMYL +AN +ANABAPTIST/M/S +ANACHRONISM/M/S +ANACHRONISTICALLY +ANACONDA/S +ANAEROBIC +ANAESTHESIA +ANAGRAM/M/S +ANAL +ANALOG +ANALOGICAL +ANALOGOUS/Y +ANALOGUE/M/S +ANALOGY/M/S +ANALYSES +ANALYSIS +ANALYST/M/S +ANALYTIC +ANALYTICAL/Y +ANALYTICITY/S +ANALYZABLE +ANALYZE/D/R/Z/G/S +ANAPHORA +ANAPHORIC +ANAPHORICALLY +ANAPLASMOSIS +ANARCHIC +ANARCHICAL +ANARCHIST/M/S +ANARCHY +ANASTOMOSES +ANASTOMOSIS +ANASTOMOTIC +ANATHEMA +ANATOMIC +ANATOMICAL/Y +ANATOMY +ANCESTOR/M/S +ANCESTRAL +ANCESTRY +ANCHOR/D/G/S +ANCHORAGE/M/S +ANCHORITE +ANCHORITISM +ANCHOVY/S +ANCIENT/Y/S +ANCILLARY +AND/Z/G +ANDERSON/M +ANDORRA +ANDREW/M +ANDY/M +ANECDOTAL +ANECDOTE/M/S +ANECHOIC +ANEMIA +ANEMIC +ANEMOMETER/M/S +ANEMOMETRY +ANEMONE +ANESTHESIA +ANESTHETIC/M/S +ANESTHETICALLY +ANESTHETIZE/D/G/S +ANEW +ANGEL/M/S +ANGELIC +ANGER/D/G/S +ANGIOGRAPHY +ANGLE/D/R/Z/G/S +ANGLICAN/S +ANGLICANISM +ANGLOPHILIA +ANGLOPHOBIA +ANGOLA +ANGRILY +ANGRY/T/R +ANGST +ANGSTROM +ANGUISH/D +ANGULAR/Y +ANHYDROUS/Y +ANILINE +ANIMAL/M/S +ANIMATE/P/D/G/N/X/Y/S +ANIMATEDLY +ANIMATOR/M/S +ANIMISM +ANIMIZED +ANIMOSITY +ANION/M/S +ANIONIC +ANISE +ANISEIKONIC +ANISOTROPIC +ANISOTROPY +ANKLE/M/S +ANNAL/S +ANNEAL/G +ANNEX/D/G/S +ANNEXATION +ANNIHILATE/D/G/N/S +ANNIVERSARY/M/S +ANNOTATE/D/G/N/X/S +ANNOUNCE/D/R/Z/G/S +ANNOUNCEMENT/M/S +ANNOY/D/G/S +ANNOYANCE/M/S +ANNOYER/S +ANNOYINGLY +ANNUAL/Y/S +ANNUITY +ANNUL/S +ANNULLED +ANNULLING +ANNULMENT/M/S +ANNUM +ANNUNCIATE/D/G/S +ANNUNCIATOR/S +ANODE/M/S +ANODIZE/D/S +ANOINT/D/G/S +ANOMALOUS/Y +ANOMALY/M/S +ANOMIC +ANOMIE +ANON +ANONYMITY +ANONYMOUS/Y +ANOREXIA +ANOTHER/M +ANSI +ANSWER/D/R/Z/G/S +ANSWERABLE +ANT/M/S +ANTAGONISM/S +ANTAGONIST/M/S +ANTAGONISTIC +ANTAGONISTICALLY +ANTAGONIZE/D/G/S +ANTARCTIC +ANTARCTICA +ANTE +ANTEATER/M/S +ANTECEDENT/M/S +ANTEDATE +ANTELOPE/M/S +ANTENNA/M/S +ANTENNAE +ANTERIOR +ANTHEM/M/S +ANTHER +ANTHOLOGY/S +ANTHONY +ANTHRACITE +ANTHROPOLOGICAL/Y +ANTHROPOLOGIST/M/S +ANTHROPOLOGY +ANTHROPOMORPHIC +ANTHROPOMORPHICALLY +ANTI +ANTIBACTERIAL +ANTIBIOTIC/S +ANTIBODY/S +ANTIC/M/S +ANTICIPATE/D/G/N/X/S +ANTICIPATORY +ANTICOAGULATION +ANTICOMPETITIVE +ANTIDISESTABLISHMENTARIANISM +ANTIDOTE/M/S +ANTIFORMANT +ANTIFUNDAMENTALIST +ANTIGEN/M/S +ANTIHISTORICAL +ANTIMICROBIAL +ANTIMONY +ANTINOMIAN +ANTINOMY +ANTIPATHY +ANTIPHONAL +ANTIPODE/M/S +ANTIQUARIAN/M/S +ANTIQUATE/D +ANTIQUE/M/S +ANTIQUITY/S +ANTIREDEPOSITION +ANTIRESONANCE +ANTIRESONATOR +ANTISEPTIC +ANTISERA +ANTISERUM +ANTISLAVERY +ANTISOCIAL +ANTISUBMARINE +ANTISYMMETRIC +ANTISYMMETRY +ANTITHESIS +ANTITHETICAL +ANTITHYROID +ANTITOXIN/M/S +ANTITRUST +ANTLER/D +ANUS +ANVIL/M/S +ANXIETY/S +ANXIOUS/Y +ANY +ANYBODY +ANYHOW +ANYMORE +ANYONE +ANYPLACE +ANYTHING +ANYTIME +ANYWAY +ANYWHERE +AORTA +APACE +APART +APARTHEID +APARTMENT/M/S +APATHETIC +APATHY +APE/D/G/S +APERIODIC +APERIODICITY +APERTURE +APEX +APHASIA +APHASIC +APHID/M/S +APHONIC +APHORISM/M/S +APHRODITE +APIARY/S +APICAL +APIECE +APISH +APLENTY +APLOMB +APOCALYPSE +APOCALYPTIC +APOCRYPHA +APOCRYPHAL +APOGEE/S +APOLLO +APOLLONIAN +APOLOGETIC +APOLOGETICALLY +APOLOGIA +APOLOGIST/M/S +APOLOGIZE/D/G/S +APOLOGY/M/S +APOSTATE +APOSTLE/M/S +APOSTOLIC +APOSTROPHE/S +APOTHECARY +APOTHEOSES +APOTHEOSIS +APPALACHIA +APPALACHIAN/S +APPALL/D/G +APPALLINGLY +APPANAGE +APPARATUS +APPAREL/D +APPARENT/Y +APPARITION/M/S +APPEAL/D/R/Z/G/S +APPEALINGLY +APPEAR/D/R/Z/G/S +APPEARANCE/S +APPEASE/D/G/S +APPEASEMENT +APPELLANT/M/S +APPELLATE +APPEND/D/R/Z/G/S +APPENDAGE/M/S +APPENDICES +APPENDICITIS +APPENDIX/M/S +APPERTAIN/S +APPETITE/M/S +APPETIZER +APPETIZING +APPLAUD/D/G/S +APPLAUSE +APPLE/M/S +APPLEJACK +APPLIANCE/M/S +APPLICABILITY +APPLICABLE +APPLICANT/M/S +APPLICATION/M/S +APPLICATIVE/Y +APPLICATOR/M/S +APPLIQUE +APPLY/D/R/Z/G/N/X/S +APPOINT/D/R/Z/G/V/S +APPOINTEE/M/S +APPOINTMENT/M/S +APPORTION/D/G/S +APPORTIONMENT/S +APPRAISAL/M/S +APPRAISE/D/R/Z/G/S +APPRAISINGLY +APPRECIABLE +APPRECIABLY +APPRECIATE/D/G/N/X/V/S +APPRECIATIVELY +APPREHEND/D +APPREHENSIBLE +APPREHENSION/M/S +APPREHENSIVE/P/Y +APPRENTICE/D/S +APPRENTICESHIP +APPRISE/D/G/S +APPROACH/D/R/Z/G/S +APPROACHABILITY +APPROACHABLE +APPROBATE/N +APPROPRIATE/P/D/G/N/X/Y/S +APPROPRIATOR/M/S +APPROVAL/M/S +APPROVE/D/R/Z/G/S +APPROVINGLY +APPROXIMATE/D/G/N/X/Y/S +APPURTENANCE/S +APRICOT/M/S +APRIL +APRON/M/S +APROPOS +APSE +APSIS +APT/P/Y +APTITUDE/S +AQUA +AQUARIA +AQUARIUM +AQUARIUS +AQUATIC +AQUEDUCT/M/S +AQUEOUS +AQUIFER/S +ARAB/M/S +ARABESQUE +ARABIA +ARABIAN/S +ARABIC +ARABLE +ARACHNID/M/S +ARBITER/M/S +ARBITRARILY +ARBITRARY/P +ARBITRATE/D/G/N/S +ARBITRATOR/M/S +ARBOR/M/S +ARBOREAL +ARC/D/G/S +ARCADE/D/M/S +ARCANE +ARCH/D/R/Z/G/Y/S +ARCHAEOLOGICAL +ARCHAEOLOGIST/M/S +ARCHAEOLOGY +ARCHAIC/P +ARCHAICALLY +ARCHAISM +ARCHAIZE +ARCHANGEL/M/S +ARCHBISHOP +ARCHDIOCESE/S +ARCHENEMY +ARCHEOLOGICAL +ARCHEOLOGIST +ARCHEOLOGY +ARCHERY +ARCHETYPE +ARCHFOOL +ARCHIPELAGO +ARCHIPELAGOES +ARCHITECT/M/S +ARCHITECTONIC +ARCHITECTURAL/Y +ARCHITECTURE/M/S +ARCHIVAL +ARCHIVE/D/R/Z/G/S +ARCHIVIST +ARCLIKE +ARCTIC +ARDENT/Y +ARDOR +ARDUOUS/P/Y +ARE +AREA/M/S +AREN'T +ARENA/M/S +ARGENTINA +ARGO/S +ARGON +ARGONAUT/S +ARGOT +ARGUABLE +ARGUABLY +ARGUE/D/R/Z/G/S +ARGUMENT/M/S +ARGUMENTATION +ARGUMENTATIVE +ARIANISM +ARIANIST/S +ARID +ARIDITY +ARIES +ARIGHT +ARISE/R/G/J/S +ARISEN +ARISTOCRACY +ARISTOCRAT/M/S +ARISTOCRATIC +ARISTOCRATICALLY +ARISTOTELIAN +ARISTOTLE +ARITHMETIC/S +ARITHMETICAL/Y +ARITHMETIZE/D/S +ARIZONA +ARK +ARKANSAS +ARM/D/R/Z/G/S +ARMADILLO/S +ARMAGEDDON +ARMAMENT/M/S +ARMCHAIR/M/S +ARMENIAN +ARMFUL +ARMHOLE +ARMISTICE +ARMLOAD +ARMOR/D/R +ARMORY +ARMOUR +ARMPIT/M/S +ARMSTRONG +ARMY/M/S +AROMA/S +AROMATIC +AROSE +AROUND +AROUSAL +AROUSE/D/G/S +ARPA +ARPANET +ARPEGGIO/M/S +ARRACK +ARRAIGN/D/G/S +ARRAIGNMENT/M/S +ARRANGE/D/R/Z/G/S +ARRANGEMENT/M/S +ARRANT +ARRAY/D/S +ARREARS +ARREST/D/R/Z/G/S +ARRESTINGLY +ARRESTOR/M/S +ARRIVAL/M/S +ARRIVE/D/G/S +ARROGANCE +ARROGANT/Y +ARROGATE/D/G/N/S +ARROW/D/S +ARROWHEAD/M/S +ARROYO/S +ARSENAL/M/S +ARSENIC +ARSINE +ARSON +ART/M/S +ARTEMIS +ARTERIAL +ARTERIOLAR +ARTERIOLE/M/S +ARTERIOSCLEROSIS +ARTERY/M/S +ARTFUL/P/Y +ARTHOGRAM +ARTHRITIS +ARTHROPOD/M/S +ARTICHOKE/M/S +ARTICLE/M/S +ARTICULATE/P/D/G/N/X/Y/S +ARTICULATOR/S +ARTICULATORY +ARTIFACT/M/S +ARTIFACTUALLY +ARTIFICE/R/S +ARTIFICIAL/P/Y +ARTIFICIALITY/S +ARTILLERIST +ARTILLERY +ARTISAN/M/S +ARTIST/M/S +ARTISTIC +ARTISTICALLY +ARTISTRY +ARTLESS +ARTWORK +ARYAN +AS +ASBESTOS +ASCEND/D/R/Z/G/S +ASCENDANCY +ASCENDANT +ASCENDENCY +ASCENDENT +ASCENSION/S +ASCENT +ASCERTAIN/D/G/S +ASCERTAINABLE +ASCETIC/M/S +ASCETICISM +ASCII +ASCOT +ASCRIBABLE +ASCRIBE/D/G/S +ASCRIPTION +ASEPTIC +ASH/R/N/S +ASHAMED/Y +ASHMAN +ASHORE +ASHTRAY/M/S +ASIA +ASIAN/S +ASIATIC +ASIDE +ASININE +ASK/D/R/Z/G/S +ASKANCE +ASKEW +ASLEEP +ASOCIAL +ASP/N +ASPARAGUS +ASPECT/M/S +ASPERSION/M/S +ASPHALT +ASPHYXIA +ASPIC +ASPIRANT/M/S +ASPIRATE/D/G/S +ASPIRATION/M/S +ASPIRATOR/S +ASPIRE/D/G/S +ASPIRIN/S +ASS/M/S +ASSAIL/D/G/S +ASSAILANT/M/S +ASSASSIN/M/S +ASSASSINATE/D/G/N/X/S +ASSAULT/D/G/S +ASSAY/D/G +ASSEMBLAGE/M/S +ASSEMBLE/D/R/Z/G/S +ASSEMBLY/M/S +ASSENT/D/R/G/S +ASSERT/D/R/Z/G/V/S +ASSERTION/M/S +ASSERTIVELY +ASSERTIVENESS +ASSESS/D/G/S +ASSESSMENT/M/S +ASSESSOR/S +ASSET/M/S +ASSIDUITY +ASSIDUOUS/Y +ASSIGN/D/R/Z/G/S +ASSIGNABLE +ASSIGNEE/M/S +ASSIGNMENT/M/S +ASSIMILATE/D/G/N/X/S +ASSIST/D/G/S +ASSISTANCE/S +ASSISTANT/M/S +ASSISTANTSHIP/S +ASSOCIATE/D/G/N/X/V/S +ASSOCIATIONAL +ASSOCIATIVELY +ASSOCIATIVITY +ASSOCIATOR/M/S +ASSONANCE +ASSONANT +ASSORT/D/S +ASSORTMENT/M/S +ASSUAGE/D/S +ASSUME/D/G/S +ASSUMPTION/M/S +ASSURANCE/M/S +ASSURE/D/R/Z/G/S +ASSUREDLY +ASSURINGLY +ASSYRIAN +ASSYRIOLOGY +ASTATINE +ASTER/M/S +ASTERISK/M/S +ASTEROID/M/S +ASTEROIDAL +ASTHMA +ASTONISH/D/G/S +ASTONISHINGLY +ASTONISHMENT +ASTOUND/D/G/S +ASTRAL +ASTRAY +ASTRIDE +ASTRINGENCY +ASTRINGENT +ASTRONAUT/M/S +ASTRONAUTICS +ASTRONOMER/M/S +ASTRONOMICAL/Y +ASTRONOMY +ASTROPHYSICAL +ASTROPHYSICS +ASTUTE/P +ASUNDER +ASYLUM +ASYMMETRIC +ASYMMETRICALLY +ASYMMETRY +ASYMPTOMATICALLY +ASYMPTOTE/M/S +ASYMPTOTIC +ASYMPTOTICALLY +ASYNCHRONISM +ASYNCHRONOUS/Y +ASYNCHRONY +AT +ATAVISTIC +ATE +ATEMPORAL +ATHEIST/M/S +ATHEISTIC +ATHENA +ATHENIAN/S +ATHENS +ATHEROSCLEROSIS +ATHLETE/M/S +ATHLETIC/S +ATHLETICISM +ATLANTIC +ATLAS +ATMOSPHERE/M/S +ATMOSPHERIC +ATOLL/M/S +ATOM/M/S +ATOMIC/S +ATOMICALLY +ATOMIZATION +ATOMIZE/D/G/S +ATONAL/Y +ATONE/D/S +ATONEMENT +ATOP +ATROCIOUS/Y +ATROCITY/M/S +ATROPHIC +ATROPHY/D/G/S +ATTACH/D/R/Z/G/S +ATTACHE/D/G/S +ATTACHMENT/M/S +ATTACK/D/R/Z/G/S +ATTACKABLE +ATTAIN/D/R/Z/G/S +ATTAINABLE +ATTAINABLY +ATTAINMENT/M/S +ATTEMPT/D/R/Z/G/S +ATTEND/D/R/Z/G/S +ATTENDANCE/M/S +ATTENDANT/M/S +ATTENDEE/M/S +ATTENTION/M/S +ATTENTIONAL +ATTENTIONALITY +ATTENTIVE/P/Y +ATTENUATE/D/G/N/S +ATTENUATOR/M/S +ATTEST/D/G/S +ATTIC/M/S +ATTIRE/D/G/S +ATTITUDE/M/S +ATTITUDINAL +ATTORNEY/M/S +ATTRACT/D/G/V/S +ATTRACTION/M/S +ATTRACTIVELY +ATTRACTIVENESS +ATTRACTOR/M/S +ATTRIBUTABLE +ATTRIBUTE/D/G/N/X/V/S +ATTRIBUTIVELY +ATTRITION +ATTUNE/D/G/S +ATYPICAL/Y +AUBURN +AUCKLAND +AUCTION +AUCTIONEER/M/S +AUDACIOUS/P/Y +AUDACITY +AUDIBLE +AUDIBLY +AUDIENCE/M/S +AUDIO +AUDIOGRAM/M/S +AUDIOLOGICAL +AUDIOLOGIST/M/S +AUDIOLOGY +AUDIOMETER/S +AUDIOMETRIC +AUDIOMETRY +AUDIT/D/G/S +AUDITION/D/M/G/S +AUDITOR/M/S +AUDITORIUM +AUDITORY +AUDUBON +AUGER/M/S +AUGHT +AUGMENT/D/G/S +AUGMENTATION +AUGUR/S +AUGUST/P/Y +AUGUSTA +AUNT/M/S +AURA/M/S +AURAL/Y +AUREOLE +AUREOMYCIN +AURORA +AUSCULTATE/D/G/N/X/S +AUSPICE/S +AUSPICIOUS/Y +AUSTERE/Y +AUSTERITY +AUSTIN +AUSTRALIA +AUSTRALIAN +AUSTRIA +AUSTRIAN +AUTHENTIC +AUTHENTICALLY +AUTHENTICATE/D/G/N/X/S +AUTHENTICATOR/S +AUTHENTICITY +AUTHOR/D/G/S +AUTHORITARIAN +AUTHORITARIANISM +AUTHORITATIVE/Y +AUTHORITY/M/S +AUTHORIZATION/M/S +AUTHORIZE/D/R/Z/G/S +AUTHORSHIP +AUTISM +AUTISTIC +AUTO/M/S +AUTOBIOGRAPHIC +AUTOBIOGRAPHICAL +AUTOBIOGRAPHY/M/S +AUTOCOLLIMATOR +AUTOCORRELATE/N +AUTOCRACY/S +AUTOCRAT/M/S +AUTOCRATIC +AUTOCRATICALLY +AUTOFLUORESCENCE +AUTOGRAPH/D/G +AUTOGRAPHS +AUTOMATA +AUTOMATE/D/G/N/S +AUTOMATIC +AUTOMATICALLY +AUTOMATON +AUTOMOBILE/M/S +AUTOMOTIVE +AUTONAVIGATOR/M/S +AUTONOMIC +AUTONOMOUS/Y +AUTONOMY +AUTOPILOT/M/S +AUTOPSY/D/S +AUTOREGRESSIVE +AUTOSUGGESTIBILITY +AUTOTRANSFORMER +AUTUMN/M/S +AUTUMNAL +AUXILIARY/S +AVAIL/D/R/Z/G/S +AVAILABILITY/S +AVAILABLE +AVAILABLY +AVALANCHE/D/G/S +AVANT +AVARICE +AVARICIOUS/Y +AVE +AVENGE/D/R/G/S +AVENUE/M/S +AVER/S +AVERAGE/D/G/S +AVERRED +AVERRER +AVERRING +AVERSE/N +AVERSION/M/S +AVERT/D/G/S +AVIAN +AVIARY/S +AVIATION +AVIATOR/M/S +AVID/Y +AVIDITY +AVIONIC/S +AVOCADO/S +AVOCATION/M/S +AVOID/D/R/Z/G/S +AVOIDABLE +AVOIDABLY +AVOIDANCE +AVOUCH +AVOW/D/S +AWAIT/D/G/S +AWAKE/G/S +AWAKEN/D/G/S +AWARD/D/R/Z/G/S +AWARE/P +AWASH +AWAY +AWE/D +AWESOME +AWFUL/P/Y +AWHILE +AWKWARD/P/Y +AWL/M/S +AWNING/M/S +AWOKE +AWRY +AX/D/R/Z/G/S +AXE/D/S +AXIAL/Y +AXIOLOGICAL +AXIOM/M/S +AXIOMATIC +AXIOMATICALLY +AXIOMATIZATION/M/S +AXIOMATIZE/D/G/S +AXIS +AXLE/M/S +AXOLOTL/M/S +AXON/M/S +AYE/S +AZALEA/M/S +AZIMUTH/M +AZIMUTHS +AZURE +BABBLE/D/G/S +BABE/M/S +BABEL/M +BABY/D/G/S +BABYHOOD +BABYISH +BACCALAUREATE +BACH/M +BACHELOR/M/S +BACILLI +BACILLUS +BACK/D/R/Z/G/S +BACKACHE/M/S +BACKARROW/S +BACKBEND/M/S +BACKBONE/M/S +BACKDROP/M/S +BACKGAMMON +BACKGROUND/M/S +BACKLASH +BACKLOG/M/S +BACKPACK/M/S +BACKPLANE/M/S +BACKPOINTER/M/S +BACKPROPAGATE/D/G/N/X/S +BACKSCATTER/D/G/S +BACKSLASH/S +BACKSPACE/D/S +BACKSTAGE +BACKSTAIRS +BACKSTITCH/D/G/S +BACKTRACK/D/R/Z/G/S +BACKUP/S +BACKWARD/P/S +BACKWATER/M/S +BACKWOODS +BACKYARD/M/S +BACON +BACTERIA +BACTERIAL +BACTERIUM +BAD/P/Y +BADE +BADGE/R/Z/S +BADGER'S +BADGERED +BADGERING +BADLANDS +BADMINTON +BAFFLE/D/R/Z/G +BAG/M/S +BAGATELLE/M/S +BAGEL/M/S +BAGGAGE +BAGGED +BAGGER/M/S +BAGGING +BAGGY +BAGPIPE/M/S +BAH +BAIL/G +BAILIFF/M/S +BAIT/D/R/G/S +BAKE/D/R/Z/G/S +BAKERY/M/S +BAKLAVA +BALALAIKA/M/S +BALANCE/D/R/Z/G/S +BALCONY/M/S +BALD/P/G/Y +BALE/R/S +BALEFUL +BALK/D/G/S +BALKAN/S +BALKANIZE/D/G +BALKY/P +BALL/D/R/Z/G/S +BALLAD/M/S +BALLAST/M/S +BALLERINA/M/S +BALLET/M/S +BALLGOWN/M/S +BALLISTIC/S +BALLOON/D/R/Z/G/S +BALLOT/M/S +BALLPARK/M/S +BALLPLAYER/M/S +BALLROOM/M/S +BALLYHOO +BALM/M/S +BALMY +BALSA +BALSAM +BALTIC +BALUSTRADE/M/S +BAMBOO +BAN/M/S +BANAL/Y +BANANA/M/S +BAND/D/G/S +BANDAGE/D/G/S +BANDIT/M/S +BANDLIMIT/D/G/S +BANDPASS +BANDSTAND/M/S +BANDWAGON/M/S +BANDWIDTH +BANDWIDTHS +BANDY/D/G/S +BANE +BANEFUL +BANG/D/G/S +BANGLADESH +BANGLE/M/S +BANISH/D/G/S +BANISHMENT +BANISTER/M/S +BANJO/M/S +BANK/D/R/Z/G/S +BANKRUPT/D/G/S +BANKRUPTCY/M/S +BANNED +BANNER/M/S +BANNING +BANQUET/G/J/S +BANSHEE/M/S +BANTAM +BANTER/D/G/S +BANTU/S +BAPTISM/M/S +BAPTISMAL +BAPTIST/M/S +BAPTISTERY +BAPTISTRY/M/S +BAPTIZE/D/G/S +BAR/M/S +BARB/D/R/S +BARBADOS +BARBARA/M +BARBARIAN/M/S +BARBARIC +BARBARITY/S +BARBAROUS/Y +BARBECUE/D/S/G +BARBELL/M/S +BARBITAL +BARBITURATE/S +BARD/M/S +BARE/P/D/T/R/G/Y/S +BAREFOOT/D +BARFLY/M/S +BARGAIN/D/G/S +BARGE/G/S +BARITONE/M/S +BARIUM +BARK/D/R/Z/G/S +BARLEY +BARN/M/S +BARNSTORM/D/G/S +BARNYARD/M/S +BAROMETER/M/S +BAROMETRIC +BARON/M/S +BARONESS +BARONIAL +BARONY/M/S +BAROQUE/P +BARRACK/S +BARRAGE/M/S +BARRED +BARREL/M/S/D/G +BARRELLED +BARRELLING +BARREN/P +BARRICADE/M/S +BARRIER/M/S +BARRING/R +BARROW +BARTENDER/M/S +BARTER/D/G/S +BAS +BASAL +BASALT +BASE/P/D/R/G/Y/S +BASEBALL/M/S +BASEBOARD/M/S +BASELESS +BASELINE/M/S +BASEMAN +BASEMENT/M/S +BASH/D/G/S +BASHFUL/P +BASIC/S +BASICALLY +BASIL +BASIN/M/S +BASIS +BASK/D/G +BASKET/M/S +BASKETBALL/M/S +BASS/M/S +BASSET +BASSINET/M/S +BASSO +BASTARD/M/S +BASTE/D/G/N/X/S +BASTION'S +BAT/M/S +BATCH/D/S +BATH +BATHE/D/R/Z/G/S +BATHOS +BATHROBE/M/S +BATHROOM/M/S +BATHS +BATHTUB/M/S +BATON/M/S +BATTALION/M/S +BATTED +BATTEN/S +BATTER/D/G/S +BATTERY/M/S +BATTING +BATTLE/D/R/Z/G/S +BATTLEFIELD/M/S +BATTLEFRONT/M/S +BATTLEGROUND/M/S +BATTLEMENT/M/S +BATTLESHIP/M/S +BAUBLE/M/S +BAUD +BAUXITE +BAWDY +BAWL/D/G/S +BAY/D/G/S +BAYONET/M/S +BAYOU/M/S +BAZAAR/M/S +BE/D/G/Y +BEACH/D/G/S +BEACHHEAD/M/S +BEACON/M/S +BEAD/D/G/S +BEADLE/M/S +BEADY +BEAGLE/M/S +BEAK/D/R/Z/S +BEAM/D/R/Z/G/S +BEAN/D/R/Z/G/S +BEAR/R/Z/G/J/S +BEARABLE +BEARABLY +BEARD/D/S +BEARDLESS +BEARISH +BEAST/Y/S +BEAT/R/Z/G/N/J/S +BEATABLE +BEATABLY +BEATIFIC +BEATIFY/N +BEATITUDE/M/S +BEATNIK/M/S +BEAU/M/S +BEAUTEOUS/Y +BEAUTIFUL/Y +BEAUTIFY/D/R/Z/G/X/S +BEAUTY/M/S +BEAVER/M/S +BECALM/D/G/S +BECAME +BECAUSE +BECK +BECKON/D/G/S +BECOME/G/S +BECOMINGLY +BED/M/S +BEDAZZLE/D/G/S +BEDAZZLEMENT +BEDBUG/M/S +BEDDED +BEDDER/M/S +BEDDING +BEDEVIL/D/G/S +BEDFAST +BEDLAM +BEDPOST/M/S +BEDRAGGLE/D +BEDRIDDEN +BEDROCK/M +BEDROOM/M/S +BEDSIDE +BEDSPREAD/M/S +BEDSPRING/M/S +BEDSTEAD/M/S +BEDTIME +BEE/R/Z/G/J/S +BEECH/R/N +BEEF/D/R/Z/G/S +BEEFSTEAK +BEEFY +BEEHIVE/M/S +BEEN +BEEP/S +BEET/M/S +BEETHOVEN +BEETLE/D/M/G/S +BEFALL/G/N/S +BEFELL +BEFIT/M/S +BEFITTED +BEFITTING +BEFOG +BEFOGGED +BEFOGGING +BEFORE +BEFOREHAND +BEFOUL/D/G/S +BEFRIEND/D/G/S +BEFUDDLE/D/G/S +BEG/S +BEGAN +BEGET/S +BEGETTING +BEGGAR/Y/S +BEGGARY +BEGGED +BEGGING +BEGIN/S +BEGINNER/M/S +BEGINNING/M/S +BEGOT +BEGOTTEN +BEGRUDGE/D/G/S +BEGRUDGINGLY +BEGUILE/D/G/S +BEGUN +BEHALF +BEHAVE/D/G/S +BEHAVIOR/S +BEHAVIORAL/Y +BEHAVIORISM +BEHAVIORISTIC +BEHEAD/G +BEHELD +BEHEST +BEHIND +BEHOLD/R/Z/G/N/S +BEHOOVE/S +BEIGE +BEIJING +BELABOR/D/G/S +BELATED/Y +BELAY/D/G/S +BELCH/D/G/S +BELFRY/M/S +BELGIAN/M/S +BELGIUM +BELIE/D/S +BELIEF/M/S +BELIEVABLE +BELIEVABLY +BELIEVE/D/R/Z/G/S +BELITTLE/D/G/S +BELL/M/S +BELLBOY/M/S +BELLE/M/S +BELLHOP/M/S +BELLICOSE +BELLICOSITY +BELLIGERENCE +BELLIGERENT/M/Y/S +BELLMAN +BELLMEN +BELLOW/D/G/S +BELLWETHER/M/S +BELLY/M/S +BELLYFUL +BELONG/D/G/J/S +BELOVED +BELOW +BELT/D/G/S +BELYING +BEMOAN/D/G/S +BENCH/D/S +BENCHMARK/M/S +BEND/R/Z/G/S +BENDABLE +BENEATH +BENEDICT +BENEDICTINE +BENEDICTION/M/S +BENEFACTOR/M/S +BENEFICENCE/S +BENEFICIAL/Y +BENEFICIARY/S +BENEFIT/D/G/S +BENEFITTED +BENEFITTING +BENEVOLENCE +BENEVOLENT +BENGAL +BENGALI +BENIGHTED +BENIGN/Y +BENT +BENZEDRINE +BENZENE +BEQUEATH/D/G/S +BEQUEST/M/S +BERATE/D/G/S +BEREAVE/D/G/S +BEREAVEMENT/S +BEREFT +BERET/M/S +BERIBBONED +BERIBERI +BERKELEY +BERKELIUM +BERLIN/R/Z +BERMUDA +BERRY/M/S +BERTH +BERTHS +BERYL +BERYLLIUM +BESEECH/G/S +BESET/S +BESETTING +BESIDE/S +BESIEGE/D/R/Z/G +BESMIRCH/D/G/S +BESOTTED +BESOTTER +BESOTTING +BESOUGHT +BESPEAK/S +BESPECTACLED +BESSEL +BEST/D/G/S +BESTIAL +BESTOW/D +BESTOWAL +BESTSELLER/M/S +BESTSELLING +BET/M/S +BETA +BETHESDA +BETIDE +BETRAY/D/R/G/S +BETRAYAL +BETROTH/D +BETROTHAL +BETTER/D/G/S +BETTERMENT/S +BETTING +BETWEEN +BETWIXT +BEVEL/D/G/S +BEVERAGE/M/S +BEVY +BEWAIL/D/G/S +BEWARE +BEWHISKERED +BEWILDER/D/G/S +BEWILDERINGLY +BEWILDERMENT +BEWITCH/D/G/S +BEYOND +BEZIER +BIANNUAL +BIAS/D/G/S +BIB/M/S +BIBBED +BIBBING +BIBLE/M/S +BIBLICAL/Y +BIBLIOGRAPHIC +BIBLIOGRAPHICAL +BIBLIOGRAPHY/M/S +BIBLIOPHILE +BICAMERAL +BICARBONATE +BICENTENNIAL +BICEP/M/S +BICKER/D/G/S +BICONCAVE +BICONVEX +BICYCLE/D/R/Z/G/S +BID/M/S +BIDDABLE +BIDDEN +BIDDER/M/S +BIDDING +BIDDY/S +BIDE +BIDIRECTIONAL +BIENNIAL +BIENNIUM +BIFOCAL/S +BIG/P +BIGGER +BIGGEST +BIGHT/M/S +BIGNUM +BIGOT/D/M/S +BIGOTRY +BIJECTION/M/S +BIJECTIVE/Y +BIKE/M/G/S +BIKINI/M/S +BILABIAL +BILATERAL/Y +BILE +BILGE/M/S +BILINEAR +BILINGUAL +BILK/D/G/S +BILL/D/R/Z/G/J/S/M +BILLBOARD/M/S +BILLET/D/G/S +BILLIARD/S +BILLION/H/S +BILLOW/D/S +BIMODAL +BIMOLECULAR +BIMONTHLY/S +BIN/M/S +BINARY +BINAURAL +BIND/R/Z/G/J/S +BINGE/S +BINGO +BINOCULAR/S +BINOMIAL +BINUCLEAR +BIOCHEMICAL +BIOCHEMISTRY +BIOFEEDBACK +BIOGRAPHER/M/S +BIOGRAPHIC +BIOGRAPHICAL/Y +BIOGRAPHY/M/S +BIOLOGICAL/Y +BIOLOGIST/M/S +BIOLOGY +BIOMEDICAL +BIOMEDICINE +BIOPHYSICAL +BIOPHYSICS +BIOPSY/S +BIOTECHNOLOGY +BIPARTISAN +BIPARTITE +BIPED/S +BIPLANE/M/S +BIPOLAR +BIRACIAL +BIRCH/N/S +BIRD/M/S +BIRDBATH/M +BIRDBATHS +BIRDIE/D/S +BIRDLIKE +BIREFRINGENCE +BIREFRINGENT +BIRMINGHAM +BIRTH/D +BIRTHDAY/M/S +BIRTHPLACE/S +BIRTHRIGHT/M/S +BIRTHS +BISCUIT/M/S +BISECT/D/G/S +BISECTION/M/S +BISECTOR/M/S +BISHOP/M/S +BISMUTH +BISON/M/S +BISQUE/S +BIT/M/S +BITCH/M/S +BITE/G/R/S/Z +BITINGLY +BITMAP/S +BITMAPPED +BITTEN +BITTER/P/T/R/Y/S +BITTERSWEET +BITUMINOUS +BITWISE +BIVALVE/M/S +BIVARIATE +BIVOUAC/S +BIWEEKLY +BIZARRE +BLAB/S +BLABBED +BLABBERMOUTH +BLABBERMOUTHS +BLABBING +BLACK/P/D/T/R/G/N/X/Y/S +BLACKBERRY/M/S +BLACKBIRD/M/S +BLACKBOARD/M/S +BLACKENED +BLACKENING +BLACKJACK/M/S +BLACKLIST/D/G/S +BLACKMAIL/D/R/Z/G/S +BLACKOUT/M/S +BLACKSMITH +BLACKSMITHS +BLADDER/M/S +BLADE/M/S +BLAINE +BLAMABLE +BLAME/D/R/Z/G/S +BLAMELESS/P +BLANCH/D/G/S +BLAND/P/Y +BLANK/P/D/T/R/G/Y/S +BLANKET/D/R/Z/G/S +BLARE/D/G/S +BLASE +BLASPHEME/D/G/S +BLASPHEMOUS/P/Y +BLASPHEMY/S +BLAST/D/R/Z/G/S +BLATANT/Y +BLAZE/D/R/Z/G/S +BLEACH/D/R/Z/G/S +BLEAK/P/Y +BLEAR +BLEARY +BLEAT/G/S +BLED +BLEED/R/G/J/S +BLEMISH/M/S +BLEND/D/G/S +BLESS/D/G/J +BLEW +BLIGHT/D +BLIMP/M/S +BLIND/P/D/R/Z/G/Y/S +BLINDFOLD/D/G/S +BLINDINGLY +BLINK/D/R/Z/G/S +BLIP/M/S +BLISS +BLISSFUL/Y +BLISTER/D/G/S +BLITHE/Y +BLITZ/M/S +BLITZKRIEG +BLIZZARD/M/S +BLOAT/D/R/G/S +BLOB/M/S +BLOC/M/S +BLOCK'S +BLOCK/D/R/Z/G/S +BLOCKADE/D/G/S +BLOCKAGE/M/S +BLOCKHOUSE/S +BLOKE/M/S +BLOND/M/S +BLONDE/M/S +BLOOD/D/S +BLOODHOUND/M/S +BLOODLESS +BLOODSHED +BLOODSHOT +BLOODSTAIN/D/M/S +BLOODSTREAM +BLOODY/D/T +BLOOM/D/Z/G/S +BLOSSOM/D/S +BLOT/M/S +BLOTTED +BLOTTING +BLOUSE/M/S +BLOW/R/Z/G/S +BLOWFISH +BLOWN +BLOWUP +BLUBBER +BLUDGEON/D/G/S +BLUE/P/T/R/G/S +BLUEBERRY/M/S +BLUEBIRD/M/S +BLUEBONNET/M/S +BLUEFISH +BLUEPRINT/M/S +BLUESTOCKING +BLUFF/G/S +BLUISH +BLUNDER/D/G/J/S +BLUNT/P/D/T/R/G/Y/S +BLUR/M/S +BLURB +BLURRED +BLURRING +BLURRY +BLURT/D/G/S +BLUSH/D/G/S +BLUSTER/D/G/S +BLUSTERY +BOAR +BOARD/D/R/Z/G/S +BOARDINGHOUSE/M/S +BOAST/D/R/Z/G/J/S +BOASTFUL/Y +BOAT/R/Z/G/S +BOATHOUSE/M/S +BOATLOAD/M/S +BOATMAN +BOATMEN +BOATSMAN +BOATSMEN +BOATSWAIN/M/S +BOATYARD/M/S +BOB/M/S +BOBBED +BOBBIN/M/S +BOBBING +BOBBY +BOBOLINK/M/S +BOBWHITE/M/S +BODE/S +BODICE +BODILY +BODONI +BODY/D/S +BODYBUILDER/M/S +BODYBUILDING +BODYGUARD/M/S +BODYWEIGHT +BOG/M/S +BOGGED +BOGGLE/D/G/S +BOGUS +BOIL/D/R/Z/G/S +BOILERPLATE +BOISTEROUS/Y +BOLD/P/T/R/Y +BOLDFACE +BOLIVIA +BOLL +BOLOGNA +BOLSHEVIK/M/S +BOLSHEVISM +BOLSTER/D/G/S +BOLT/D/G/S +BOLTZMANN +BOMB/D/R/Z/G/J/S +BOMBARD/D/G/S +BOMBARDMENT +BOMBAST +BOMBASTIC +BOMBPROOF +BONANZA/M/S +BOND/D/R/Z/G/S +BONDAGE +BONDSMAN +BONDSMEN +BONE/D/R/Z/G/S +BONFIRE/M/S +BONG +BONNET/D/S +BONNY +BONUS/M/S +BONY +BOO/H/S +BOOB +BOOBOO +BOOBY +BOOK/D/R/Z/G/J/S +BOOKCASE/M/S +BOOKIE/M/S +BOOKISH +BOOKKEEPER/M/S +BOOKKEEPING +BOOKLET/M/S +BOOKSELLER/M/S +BOOKSHELF/M +BOOKSHELVES +BOOKSTORE/M/S +BOOLEAN +BOOM/D/G/S +BOOMERANG/M/S +BOOMTOWN/M/S +BOON +BOOR/M/S +BOORISH +BOOST/D/R/G/S +BOOT/D/G/S +BOOTHS +BOOTLEG/S +BOOTLEGGED +BOOTLEGGER/M/S +BOOTLEGGING +BOOTSTRAP/M/S +BOOTSTRAPPED +BOOTSTRAPPING +BOOTY +BOOZE +BORATE/S +BORAX +BORDELLO/M/S +BORDER/D/G/J/S +BORDERLAND/M/S +BORDERLINE +BORE/D/R/G/S +BOREDOM +BORIC +BORN +BORNE +BORNEO +BORON +BOROUGH +BOROUGHS +BORROW/D/R/Z/G/S +BOSOM/M/S +BOSS/D/S +BOSTON +BOSTONIAN/M/S +BOSUN +BOTANICAL +BOTANIST/M/S +BOTANY +BOTCH/D/R/Z/G/S +BOTH/Z +BOTHER/D/G/S +BOTHERSOME +BOTSWANA +BOTTLE/D/R/Z/G/S +BOTTLENECK/M/S +BOTTOM/D/G/S +BOTTOMLESS +BOTULINUS +BOTULISM +BOUFFANT +BOUGH/M +BOUGHS +BOUGHT +BOULDER/M/S +BOULEVARD/M/S +BOUNCE/D/R/G/S +BOUNCY +BOUND/D/G/N/S +BOUNDARY/M/S +BOUNDLESS/P +BOUNTEOUS/Y +BOUNTY/M/S +BOUQUET/M/S +BOURBON +BOURGEOIS +BOURGEOISIE +BOUT/M/S +BOVINE/S +BOW/D/R/Z/G/S +BOWDLERIZE/D/G/S +BOWEL/M/S +BOWL/D/R/Z/G/S +BOWLINE/M/S +BOWMAN +BOWSTRING/M/S +BOX/D/R/Z/G/S +BOXCAR/M/S +BOXTOP/M/S +BOXWOOD +BOY/M/S +BOYCOTT/D/S +BOYFRIEND/M/S +BOYHOOD +BOYISH/P +BRA/M/S +BRACE/D/G/S +BRACELET/M/S +BRACKET/D/G/S +BRACKISH +BRAD/M +BRAE/M/S +BRAG/S +BRAGGED +BRAGGER +BRAGGING +BRAID/D/G/S +BRAILLE +BRAIN/D/G/S +BRAINCHILD/M +BRAINSTEM/M/S +BRAINSTORM/M/S +BRAINWASH/D/G/S +BRAINY +BRAKE/D/G/S +BRAMBLE/M/S +BRAMBLY +BRAN +BRANCH/D/G/J/S +BRAND/D/G/S +BRANDISH/G/S +BRANDY +BRASH/P/Y +BRASS/S +BRASSIERE +BRASSY +BRAT/M/S +BRAVADO +BRAVE/P/D/T/R/G/Y/S +BRAVERY +BRAVO/S +BRAVURA +BRAWL/R/G +BRAWN +BRAY/D/R/G/S +BRAZE/D/G/S +BRAZEN/P/Y +BRAZIER/M/S +BRAZIL +BRAZILIAN +BREACH/D/R/Z/G/S +BREAD/D/G/H/S +BREADBOARD/M/S +BREADBOX/M/S +BREADWINNER/M/S +BREAK/R/Z/G/S +BREAKABLE/S +BREAKAGE +BREAKAWAY +BREAKDOWN/M/S +BREAKFAST/D/R/Z/G/S +BREAKPOINT/M/S +BREAKTHROUGH/M/S +BREAKTHROUGHS +BREAKUP +BREAKWATER/M/S +BREAST/D/S +BREASTWORK/M/S +BREATH +BREATHABLE +BREATHE/D/R/Z/G/S +BREATHLESS/Y +BREATHS +BREATHTAKING/Y +BREATHY +BRED +BREECH/M/S +BREED/R/G/S +BREEZE/M/S +BREEZILY +BREEZY +BREMSSTRAHLUNG +BRETHREN +BREVE +BREVET/D/G/S +BREVITY +BREW/D/R/Z/G/S +BREWERY/M/S +BRIAN/M +BRIAR/M/S +BRIBE/D/R/Z/G/S +BRICK/D/R/S +BRICKLAYER/M/S +BRICKLAYING +BRIDAL +BRIDE/M/S +BRIDEGROOM +BRIDESMAID/M/S +BRIDGE/D/G/S +BRIDGEABLE +BRIDGEHEAD/M/S +BRIDGEWORK/M +BRIDLE/D/G/S +BRIEF/P/D/T/R/Y/S +BRIEFCASE/M/S +BRIEFING/M/S +BRIER +BRIG/M/S +BRIGADE/M/S +BRIGADIER/M/S +BRIGANTINE +BRIGHT/P/T/R/X/Y +BRIGHTEN/D/R/Z/G/S +BRILLIANCE +BRILLIANCY +BRILLIANT/Y +BRIM +BRIMFUL +BRIMMED +BRINDLE/D +BRINE +BRING/G/R/S/Z +BRINK +BRINKMANSHIP +BRISK/P/R/Y +BRISTLE/D/G/S +BRITAIN +BRITCHES +BRITISH/R +BRITON/M/S +BRITTLE/P +BROACH/D/G/S +BROAD/P/T/R/X/Y +BROADBAND +BROADCAST/R/Z/G/J/S +BROADEN/D/R/Z/G/J/S +BROADSIDE +BROCADE/D +BROCCOLI +BROCHURE/M/S +BROIL/D/R/Z/G/S +BROKE/R/Z +BROKEN/P/Y +BROKERAGE +BROMIDE/M/S +BROMINE +BRONCHI +BRONCHIAL +BRONCHIOLE/M/S +BRONCHITIS +BRONCHUS +BRONZE/D/S +BROOCH/M/S +BROOD/R/G/S +BROOK/D/S +BROOKHAVEN +BROOM/M/S +BROOMSTICK/M/S +BROTH/R/Z +BROTHEL/M/S +BROTHER'S +BROTHERHOOD +BROTHERLY/P +BROUGHT +BROW/M/S +BROWBEAT/G/N/S +BROWN/P/D/T/R/G/S +BROWNIE/M/S +BROWNISH +BROWSE/G +BROWSER/S +BRUCE/M +BRUISE/D/G/S +BRUNCH/S +BRUNETTE +BRUNT +BRUSH/D/G/S +BRUSHFIRE/M/S +BRUSHLIKE +BRUSHY +BRUSQUE/Y +BRUTAL/Y +BRUTALITY/S +BRUTALIZE/D/G/S +BRUTE/M/S +BRUTISH +BSD +BUBBLE/D/G/S +BUBBLY +BUCK/D/G/S +BUCKBOARD/M/S +BUCKET/M/S +BUCKLE/D/R/G/S +BUCKSHOT +BUCKSKIN/S +BUCKWHEAT +BUCOLIC +BUD/M/S +BUDDED +BUDDING +BUDDY/M/S +BUDGE/D/G/S +BUDGET/D/R/Z/G/S +BUDGETARY +BUFF/M/S +BUFFALO +BUFFALOES +BUFFER/D/M/G/S +BUFFERER/M/S +BUFFET/D/G/J/S +BUFFOON/M/S +BUG/M/S +BUGGED +BUGGER/M/S +BUGGING +BUGGY/M/S +BUGLE/D/R/G/S +BUILD/R/Z/G/J/S +BUILDUP/M/S +BUILT +BULB/M/S +BULGE/D/G +BULK/D/S +BULKHEAD/M/S +BULKY +BULL/D/G/S +BULLDOG/M/S +BULLDOZE/D/R/G/S +BULLET/M/S +BULLETIN/M/S +BULLION +BULLISH +BULLY/D/G/S +BULWARK +BUM/M/S +BUMBLE/D/R/Z/G/S +BUMBLEBEE/M/S +BUMMED +BUMMING +BUMP/D/R/Z/G/S +BUMPTIOUS/P/Y +BUN/M/S +BUNCH/D/G/S +BUNDLE/D/G/S +BUNGALOW/M/S +BUNGLE/D/R/Z/G/S +BUNION/M/S +BUNK/R/Z/S +BUNKER'S +BUNKERED +BUNKHOUSE/M/S +BUNKMATE/M/S +BUNNY/M/S +BUNT/D/R/Z/G/S +BUOY/D/S +BUOYANCY +BUOYANT +BURDEN/D/G/S +BURDENSOME +BUREAU/M/S +BUREAUCRACY/M/S +BUREAUCRAT/M/S +BUREAUCRATIC +BURGEON/D/G +BURGESS/M/S +BURGHER/M/S +BURGLAR/M/S +BURGLARIZE/D/G/S +BURGLARPROOF/D/G/S +BURGLARY/M/S +BURIAL +BURL +BURLESQUE/S +BURLY +BURN/D/R/Z/G/J/S +BURNINGLY +BURNISH/D/G/S +BURNT/P/Y +BURP/D/G/S +BURR/M/S +BURRO/M/S +BURROW/D/R/G/S +BURSA +BURSITIS +BURST/G/S +BURY/D/G/S +BUS/D/G/S +BUSBOY/M/S +BUSH/G/S +BUSHEL/M/S +BUSHWHACK/D/G/S +BUSHY +BUSILY +BUSINESS/M/S +BUSINESSLIKE +BUSINESSMAN +BUSINESSMEN +BUSS/D/G/S +BUST/D/R/S +BUSTARD/M/S +BUSTLE/G +BUSY/D/T/R +BUT +BUTANE +BUTCHER/D/S +BUTCHERY +BUTLER/M/S +BUTT/M/S +BUTTE/D/Z/G/S +BUTTER/D/R/Z/G +BUTTERFAT +BUTTERFLY/M/S +BUTTERNUT +BUTTOCK/M/S +BUTTON/D/G/S +BUTTONHOLE/M/S +BUTTRESS/D/G/S +BUTYL +BUTYRATE +BUXOM +BUY/G/S +BUYER/M/S +BUZZ/D/R/G/S +BUZZARD/M/S +BUZZWORD/M/S +BUZZY +BY/R +BYE +BYGONE +BYLAW/M/S +BYLINE/M/S +BYPASS/D/G/S +BYPRODUCT/M/S +BYSTANDER/M/S +BYTE/M/S +BYWAY/S +BYWORD/M/S +CAB/M/S +CABBAGE/M/S +CABIN/M/S +CABINET/M/S +CABLE/D/G/S +CACHE/M/S/G/D +CACKLE/D/R/G/S +CACTI +CACTUS +CADENCE/D +CADUCEUS +CAFE/M/S +CAGE/D/R/Z/G/S +CAJOLE/D/G/S +CAKE/D/G/S +CALAMITY/M/S +CALCIUM +CALCULATE/D/G/N/X/V/S +CALCULATOR/M/S +CALCULUS +CALENDAR/M/S +CALF +CALIBER/S +CALIBRATE/D/G/N/X/S +CALICO +CALIFORNIA +CALIPH +CALIPHS +CALL/D/R/Z/G/S +CALLIGRAPHY +CALLOUS/P/D/Y +CALM/P/D/T/R/G/Y/S +CALMINGLY +CALORIE/M/S +CALVES +CAMBRIDGE +CAME +CAMEL/M/S +CAMERA/M/S +CAMOUFLAGE/D/G/S +CAMP/D/R/Z/G/S +CAMPAIGN/D/R/Z/G/S +CAMPUS/M/S +CAN'T +CAN/M/S +CANADA +CANAL/M/S +CANARY/M/S +CANCEL/D/G/S +CANCELLATION/M/S +CANCER/M/S +CANDID/P/Y +CANDIDATE/M/S +CANDLE/R/S +CANDLESTICK/M/S +CANDOR +CANDY/D/S +CANE/R +CANINE +CANKER +CANNED +CANNER/M/S +CANNIBAL/M/S +CANNIBALIZE/D/G/S +CANNING +CANNISTER/M/S +CANNON/M/S +CANNOT +CANOE/M/S +CANON/M/S +CANONICAL/Y/S +CANONICALIZATION +CANONICALIZE/D/G/S +CANOPY +CANTANKEROUS/Y +CANTO +CANTON/M/S +CANTOR/M/S +CANVAS/M/S +CANVASS/D/R/Z/G/S +CANYON/M/S +CAP/M/S +CAPABILITY/M/S +CAPABLE +CAPABLY +CAPACIOUS/P/Y +CAPACITANCE/S +CAPACITIVE +CAPACITOR/M/S +CAPACITY/S +CAPE/R/Z/S +CAPILLARY +CAPITA +CAPITAL/Y/S +CAPITALISM +CAPITALIST/M/S +CAPITALIZATION/S +CAPITALIZE/D/R/Z/G/S +CAPITOL/M/S +CAPPED +CAPPING +CAPRICIOUS/P/Y +CAPTAIN/D/G/S +CAPTION/M/S +CAPTIVATE/D/G/N/S +CAPTIVE/M/S +CAPTIVITY +CAPTOR/M/S +CAPTURE/D/R/Z/G/S +CAR/M/S +CARAVAN/M/S +CARBOHYDRATE +CARBOLIC +CARBON/M/S +CARBONATE/N/S +CARBONIC +CARBONIZATION +CARBONIZE/D/R/Z/G/S +CARCASS/M/S +CARCINOMA +CARD/R/S +CARDBOARD +CARDIAC +CARDINAL/Y/S +CARDINALITY/M/S +CARDIOLOGY +CARDIOPULMONARY +CARE/D/G/S +CAREER/M/S +CAREFREE +CAREFUL/P/Y +CARELESS/P/Y +CARESS/D/R/G/S +CARET +CARGO +CARGOES +CARIBOU +CARNEGIE +CARNIVAL/M/S +CARNIVOROUS/Y +CAROL/M/S +CAROLINA/M/S +CARPENTER/M/S +CARPET/D/G/S +CARRIAGE/M/S +CARROT/M/S +CARRY/D/R/Z/G/S +CARRYOVER/S +CART/D/R/Z/G/S +CARTESIAN +CARTOGRAPHIC +CARTOGRAPHY +CARTON/M/S +CARTOON/M/S +CARTRIDGE/M/S +CARVE/D/R/G/J/S +CASCADE/D/G/S +CASE/D/G/J/S +CASEMENT/M/S +CASH/D/R/Z/G/S +CASHIER/M/S +CASK/M/S +CASKET/M/S +CASSEROLE/M/S +CAST/G/M/S +CASTE/R/S/Z +CASTLE/D/S +CASUAL/P/Y/S +CASUALTY/M/S +CAT/M/S +CATALOG/D/R/G/S +CATALOGUE/D/S +CATALYST/M/S +CATARACT +CATASTROPHE +CATASTROPHIC +CATCH/G/R/S/Z +CATCHABLE +CATEGORICAL/Y +CATEGORIZATION +CATEGORIZE/D/R/Z/G/S +CATEGORY/M/S +CATER/D/R/G/S +CATERPILLAR/M/S +CATHEDRAL/M/S +CATHERINE/M +CATHETER/S +CATHODE/M/S +CATHOLIC/M/S +CATSUP +CATTLE +CAUGHT +CAUSAL/Y +CAUSALITY +CAUSATION/M/S +CAUSE/D/R/G/S +CAUSEWAY/M/S +CAUSTIC/Y/S +CAUTION/D/R/Z/G/J/S +CAUTIOUS/P/Y +CAVALIER/P/Y +CAVALRY +CAVE/D/G/S +CAVEAT/M/S +CAVERN/M/S +CAVITY/M/S +CAW/G +CDR +CEASE/D/G/S +CEASELESS/P/Y +CEDAR +CEILING/M/S +CELEBRATE/D/G/N/X/S +CELEBRITY/M/S +CELERY +CELESTIAL/Y +CELL/D/S +CELLAR/M/S +CELLIST/M/S +CELLULAR +CELSIUS +CEMENT/D/G/S +CEMETERY/M/S +CENSOR/D/G/S +CENSORSHIP +CENSURE/D/R/S +CENSUS/M/S +CENT/Z/S +CENTER/D/G/S +CENTERPIECE/M/S +CENTIMETER/S +CENTIPEDE/M/S +CENTRAL/Y +CENTRALIZATION +CENTRALIZE/D/G/S +CENTRIPETAL +CENTURY/M/S +CEREAL/M/S +CEREBRAL +CEREMONIAL/P/Y +CEREMONY/M/S +CERTAIN/Y +CERTAINTY/S +CERTIFIABLE +CERTIFICATE/N/X/S +CERTIFY/D/R/Z/G/N/S +CESSATION/M/S +CHAFE/R/G +CHAFF/R/G +CHAGRIN +CHAIN/D/G/S +CHAIR/D/G/S +CHAIRMAN +CHAIRMEN +CHAIRPERSON/M/S +CHALICE/M/S +CHALK/D/G/S +CHALLENGE/D/R/Z/G/S +CHAMBER/D/S +CHAMBERLAIN/M/S +CHAMPAGNE +CHAMPAIGN +CHAMPION/D/G/S +CHAMPIONSHIP/M/S +CHANCE/D/G/S +CHANCELLOR +CHANDELIER/M/S +CHANGE/D/R/Z/G/S +CHANGEABILITY +CHANGEABLE +CHANGEABLY +CHANNEL/D/G/S +CHANNELLED +CHANNELLER/M/S +CHANNELLING +CHANT/D/R/G/S +CHANTICLEER/M/S +CHAOS +CHAOTIC +CHAP/M/S +CHAPEL/M/S +CHAPERON/D +CHAPLAIN/M/S +CHAPTER/M/S +CHAR/S +CHARACTER/M/S +CHARACTERISTIC/M/S +CHARACTERISTICALLY +CHARACTERIZABLE +CHARACTERIZATION/M/S +CHARACTERIZE/D/R/Z/G/S +CHARCOAL/D +CHARGE/D/R/Z/G/S +CHARGEABLE +CHARIOT/M/S +CHARISMA +CHARISMATIC +CHARITABLE/P +CHARITY/M/S +CHARLES +CHARM/D/R/Z/G/S +CHARMINGLY +CHART/D/R/Z/G/J/S +CHARTABLE +CHARTERED +CHARTERING +CHASE/D/R/Z/G/S +CHASM/M/S +CHASTE/P/Y +CHASTISE/D/R/Z/G/S +CHAT +CHATEAU/M/S +CHATTER/D/R/G/S/Z +CHAUFFEUR/D +CHEAP/P/T/R/X/Y +CHEAPEN/D/G/S +CHEAT/D/R/Z/G/S +CHECK/D/R/Z/G/S +CHECKABLE +CHECKBOOK/M/S +CHECKOUT +CHECKPOINT/M/S +CHECKSUM/M/S +CHEEK/M/S +CHEER/D/R/G/S +CHEERFUL/P/Y +CHEERILY +CHEERLESS/P/Y +CHEERY/P +CHEESE/M/S +CHEF/M/S +CHEMICAL/Y/S +CHEMISE +CHEMIST/M/S +CHEMISTRY/S +CHERISH/D/G/S +CHERRY/M/S +CHERUB/M/S +CHERUBIM +CHESS +CHEST/R/S +CHESTNUT/M/S +CHEW/D/R/Z/G/S +CHICK/N/X/S +CHICKADEE/M/S +CHIDE/D/G/S +CHIEF/Y/S +CHIEFTAIN/M/S +CHIFFON +CHILD +CHILDHOOD +CHILDISH/P/Y +CHILDREN +CHILES +CHILL/D/R/Z/G/S +CHILLINGLY +CHILLY/P/R +CHIME/M/S +CHIMNEY/M/S +CHIN/M/S +CHINA +CHINESE +CHINK/D/S +CHINNED +CHINNER/S +CHINNING +CHINTZ +CHIP/M/S +CHIPMUNK/M/S +CHIRP/D/G/S +CHISEL/D/R/S +CHIVALROUS/P/Y +CHIVALRY +CHLORINE +CHLOROPLAST/M/S +CHOCK/M/S +CHOCOLATE/M/S +CHOICE/T/S +CHOIR/M/S +CHOKE/D/R/Z/G/S +CHOLERA +CHOOSE/R/Z/G/S +CHOP/S +CHOPPED +CHOPPER/M/S +CHOPPING +CHORAL +CHORD/M/S +CHORE/G/S +CHORUS/D/S +CHOSE +CHOSEN +CHRIS +CHRISTEN/D/G/S +CHRISTIAN/M/S +CHRISTMAS +CHRISTOPHER/M +CHROMOSOME +CHRONIC +CHRONICLE/D/R/Z/S +CHRONOLOGICAL/Y +CHRONOLOGY/M/S +CHUBBY/P/T/R +CHUCK/M/S +CHUCKLE/D/S +CHUM +CHUNK/G/D/S/M +CHURCH/Y/S +CHURCHMAN +CHURCHYARD/M/S +CHURN/D/G/S +CHUTE/M/S +CIDER +CIGAR/M/S +CIGARETTE/M/S +CINCINNATI +CINDER/M/S +CINNAMON +CIPHER/M/S +CIRCLE/D/G/S +CIRCUIT/M/S +CIRCUITOUS/Y +CIRCUITRY +CIRCULAR/Y +CIRCULARITY/S +CIRCULATE/D/G/N/S +CIRCUMFERENCE +CIRCUMFLEX +CIRCUMLOCUTION/M/S +CIRCUMSPECT/Y +CIRCUMSTANCE/M/S +CIRCUMSTANTIAL/Y +CIRCUMVENT/D/G/S +CIRCUMVENTABLE +CIRCUS/M/S +CISTERN/M/S +CITADEL/M/S +CITATION/M/S +CITE/D/G/S +CITIZEN/M/S +CITIZENSHIP +CITY/M/S +CIVIC/S +CIVIL/Y +CIVILIAN/M/S +CIVILITY +CIVILIZATION/M/S +CIVILIZE/D/G/S +CLAD +CLAIM/D/G/S +CLAIMABLE +CLAIMANT/M/S +CLAIRVOYANT/Y +CLAM/M/S +CLAMBER/D/G/S +CLAMOR/D/G/S +CLAMOROUS +CLAMP/D/G/S +CLAN +CLANG/D/G/S +CLAP/S +CLARA/M +CLARIFY/D/G/N/X/S +CLARITY +CLASH/D/G/S +CLASP/D/G/S +CLASS/D/S +CLASSIC/S +CLASSICAL/Y +CLASSIFIABLE +CLASSIFY/D/R/Z/G/N/X/S +CLASSMATE/M/S +CLASSROOM/M/S +CLATTER/D/G +CLAUSE/M/S +CLAW/D/G/S +CLAY/M/S +CLEAN/P/D/T/G/Y/S +CLEANER/M/S +CLEANLINESS +CLEANSE/D/R/Z/G/S +CLEAR/P/D/T/R/Y/S +CLEARANCE/M/S +CLEARING/M/S +CLEAVAGE +CLEAVE/D/R/Z/G/S +CLEFT/M/S +CLENCH/D/S +CLERGY +CLERGYMAN +CLERICAL +CLERK/D/G/S +CLEVER/P/T/R/Y +CLICHE/M/S +CLICK/D/G/S +CLIENT/M/S +CLIFF/M/S +CLIMATE/M/S +CLIMATIC +CLIMATICALLY +CLIMAX/D/S +CLIMB/D/R/Z/G/S +CLIME/M/S +CLINCH/D/R/S +CLING/G/S +CLINIC/M/S +CLINICAL/Y +CLINK/D/R +CLIP/M/S +CLIPPED +CLIPPER/M/S +CLIPPING/M/S +CLIQUE/M/S +CLOAK/M/S +CLOBBER/D/G/S +CLOCK/D/R/Z/G/J/S +CLOCKWISE +CLOCKWORK +CLOD/M/S +CLOG/M/S +CLOGGED +CLOGGING +CLOISTER/M/S +CLONE/D/G/S +CLOSE/D/T/G/Y/S +CLOSENESS/S +CLOSER/S +CLOSET/D/S +CLOSURE/M/S +CLOT +CLOTH +CLOTHE/D/G/S +CLOUD/D/G/S +CLOUDLESS +CLOUDY/P/T/R +CLOUT +CLOVE/R/S +CLOWN/G/S +CLUB/M/S +CLUBBED +CLUBBING +CLUCK/D/G/S +CLUE/M/S +CLUMP/D/G/S +CLUMSILY +CLUMSY/P +CLUNG +CLUSTER/D/G/J/S +CLUTCH/D/G/S +CLUTTER/D/G/S +CLX +CLYDE/M +CMU/M +COACH/D/R/G/S +COACHMAN +COAGULATION +COAL/S +COALESCE/D/G/S +COALITION +COARSE/P/T/R/Y +COARSEN/D +COAST/D/R/Z/G/S +COASTAL +COAT/D/G/J/S +COAX/D/R/G/S +COBBLER/M/S +COBOL +COBWEB/M/S +COCK/D/G/S +COCKATOO +COCKTAIL/M/S +COCOA +COCONUT/M/S +COCOON/M/S +COD +CODE/D/R/Z/G/J/S +CODEWORD/M/S +CODIFICATION/M/S +CODIFIER/M/S +CODIFY/D/G/S +COEFFICIENT/M/S +COERCE/D/G/N/V/S +COEXIST/D/G/S +COEXISTENCE +COFFEE/M/S +COFFER/M/S +COFFIN/M/S +COGENT/Y +COGITATE/D/G/N/S +COGNITION +COGNITIVE/Y +COGNIZANCE +COGNIZANT +COHABIT/S +COHABITATION/S +COHERE/D/G/S +COHERENCE +COHERENT/Y +COHESION +COHESIVE/P/Y +COIL/D/G/S +COIN/D/R/G/S +COINAGE +COINCIDE/D/G/S +COINCIDENCE/M/S +COINCIDENTAL +COKE/S +COLD/P/T/R/Y/S +COLLABORATE/D/G/N/X/V/S +COLLABORATOR/M/S +COLLAPSE/D/G/S +COLLAR/D/G/S +COLLATERAL +COLLEAGUE/M/S +COLLECT/D/G/V/S +COLLECTIBLE +COLLECTION/M/S +COLLECTIVE/Y/S +COLLECTOR/M/S +COLLEGE/M/S +COLLEGIATE +COLLIDE/D/G/S +COLLIE/R/S +COLLISION/M/S +COLLOQUIA +COLOGNE +COLON/M/S +COLONEL/M/S +COLONIAL/Y/S +COLONIST/M/S +COLONIZATION +COLONIZE/D/R/Z/G/S +COLONY/M/S +COLOR/D/R/Z/G/J/S +COLORADO +COLORFUL +COLORLESS +COLOSSAL +COLT/M/S +COLUMBUS +COLUMN/M/S +COLUMNAR +COLUMNIZE/D/G/S +COMB/D/R/Z/G/J/S +COMBAT/D/G/V/S +COMBATANT/M/S +COMBINATION/M/S +COMBINATIONAL +COMBINATOR/M/S +COMBINATORIAL/Y +COMBINATORIC/S +COMBINE/D/G/S +COMBUSTION +COME/R/Z/G/Y/J/S +COMEDIAN/M/S +COMEDIC +COMEDY/M/S +COMELINESS +COMESTIBLE +COMET/M/S +COMFORT/D/R/Z/G/S +COMFORTABILITY/S +COMFORTABLE +COMFORTABLY +COMFORTINGLY +COMIC/M/S +COMICAL/Y +COMMA/M/S +COMMAND'S +COMMAND/D/R/Z/G/S +COMMANDANT/M/S +COMMANDINGLY +COMMANDMENT/M/S +COMMEMORATE/D/G/N/V/S +COMMENCE/D/G/S +COMMENCEMENT/M/S +COMMEND/D/G/S +COMMENDABLE +COMMENDATION/M/S +COMMENSURATE +COMMENT/D/G/S +COMMENTARY/M/S +COMMENTATOR/M/S +COMMERCE +COMMERCIAL/P/Y/S +COMMISSION/D/R/Z/G/S +COMMIT/S +COMMITMENT/M/S +COMMITTED +COMMITTEE/M/S +COMMITTING +COMMODITY/M/S +COMMODORE/M/S +COMMON/P/T/Y/S +COMMONALITY/S +COMMONER/M/S +COMMONPLACE/S +COMMONWEALTH +COMMONWEALTHS +COMMOTION +COMMUNAL/Y +COMMUNE/N/S +COMMUNICANT/M/S +COMMUNICATE/D/G/N/X/V/S +COMMUNICATOR/M/S +COMMUNIST/M/S +COMMUNITY/M/S +COMMUTATIVE +COMMUTATIVITY +COMMUTE/D/R/Z/G/S +COMPACT/P/D/T/R/G/Y/S +COMPACTOR/M/S +COMPANION/M/S +COMPANIONABLE +COMPANIONSHIP +COMPANY/M/S +COMPARABILITY +COMPARABLE +COMPARABLY +COMPARATIVE/Y/S +COMPARATOR/M/S +COMPARE/D/G/S +COMPARISON/M/S +COMPARTMENT/D/S +COMPARTMENTALIZE/D/G/S +COMPASS +COMPASSION +COMPASSIONATE/Y +COMPATIBILITY/M/S +COMPATIBLE +COMPATIBLY +COMPEL/S +COMPELLED +COMPELLING/Y +COMPENDIUM +COMPENSATE/D/G/N/X/S +COMPENSATORY +COMPETE/D/G/S +COMPETENCE +COMPETENT/Y +COMPETITION/M/S +COMPETITIVE/Y +COMPETITOR/M/S +COMPILATION/M/S +COMPILE/D/R/Z/G/S +COMPILER'S +COMPLAIN/D/R/Z/G/S +COMPLAINT/M/S +COMPLEMENT/D/R/Z/G/S +COMPLEMENTARY +COMPLETE/P/D/G/N/X/Y/S +COMPLEX/Y/S +COMPLEXION +COMPLEXITY/S +COMPLIANCE +COMPLICATE/D/G/N/X/S +COMPLICATOR/M/S +COMPLICITY +COMPLIMENT/D/R/Z/G/S +COMPLIMENTARY +COMPLY/D/G +COMPONENT/M/S +COMPONENTWISE +COMPOSE/D/R/Z/G/S +COMPOSEDLY +COMPOSITE/N/X/S +COMPOSITIONAL +COMPOSURE +COMPOUND/D/G/S +COMPREHEND/D/G/S +COMPREHENSIBILITY +COMPREHENSIBLE +COMPREHENSION +COMPREHENSIVE/Y +COMPRESS/D/G/V/S +COMPRESSIBLE +COMPRESSION +COMPRISE/D/G/S +COMPROMISE/D/R/Z/G/S +COMPROMISING/Y +COMPTROLLER/M/S +COMPULSION/M/S +COMPULSORY +COMPUNCTION +COMPUTABILITY +COMPUTABLE +COMPUTATION/M/S +COMPUTATIONAL/Y +COMPUTE/D/R/Z/G/S +COMPUTER'S +COMPUTERIZE/D/G/S +COMRADE/Y/S +COMRADESHIP +CONCATENATE/D/G/N/X/S +CONCEAL/D/R/Z/G/S +CONCEALMENT +CONCEDE/D/G/S +CONCEIT/D/S +CONCEIVABLE +CONCEIVABLY +CONCEIVE/D/G/S +CONCENTRATE/D/G/N/X/S +CONCENTRATOR/S +CONCENTRIC +CONCEPT/M/S +CONCEPTION/M/S +CONCEPTUAL/Y +CONCEPTUALIZATION/M/S +CONCEPTUALIZE/D/G/S +CONCERN/D/G/S +CONCERNEDLY +CONCERT/D/S +CONCESSION/M/S +CONCISE/P/Y +CONCLUDE/D/G/S +CONCLUSION/M/S +CONCLUSIVE/Y +CONCOCT +CONCOMITANT +CONCORD +CONCORDANCE +CONCRETE/P/N/Y/S +CONCUR/S +CONCURRED +CONCURRENCE +CONCURRENCY/S +CONCURRENT/Y +CONCURRING +CONDEMN/D/R/Z/G/S +CONDEMNATION/S +CONDENSATION +CONDENSE/D/R/G/S +CONDESCEND/G +CONDITION/D/R/Z/G/S +CONDITIONAL/Y/S +CONDONE/D/G/S +CONDUCIVE +CONDUCT/D/G/V/S +CONDUCTION +CONDUCTIVITY +CONDUCTOR/M/S +CONE/M/S +CONFEDERACY +CONFEDERATE/N/X/S +CONFER/S +CONFERENCE/M/S +CONFERRED +CONFERRER/M/S +CONFERRING +CONFESS/D/G/S +CONFESSION/M/S +CONFESSOR/M/S +CONFIDANT/M/S +CONFIDE/D/G/S +CONFIDENCE/S +CONFIDENT/Y +CONFIDENTIAL/Y +CONFIDENTIALITY +CONFIDINGLY +CONFIGURABLE +CONFIGURATION/M/S +CONFIGURE/D/G/S +CONFINE/D/R/G/S +CONFINEMENT/M/S +CONFIRM/D/G/S +CONFIRMATION/M/S +CONFISCATE/D/G/N/X/S +CONFLICT/D/G/S +CONFORM/D/G/S +CONFORMITY +CONFOUND/D/G/S +CONFRONT/D/R/Z/G/S +CONFRONTATION/M/S +CONFUSE/D/R/Z/G/N/X/S +CONFUSINGLY +CONGENIAL/Y +CONGESTED +CONGESTION +CONGRATULATE/D/N/X +CONGREGATE/D/G/N/X/S +CONGRESS/M/S +CONGRESSIONAL/Y +CONGRESSMAN +CONGRUENCE +CONGRUENT +CONIC +CONJECTURE/D/G/S +CONJOINED +CONJUNCT/D/V/S +CONJUNCTION/M/S +CONJUNCTIVELY +CONJURE/D/R/G/S +CONNECT/D/G/S +CONNECTEDNESS +CONNECTICUT +CONNECTION/M/S +CONNECTIONIST +CONNECTIVE/M/S +CONNECTIVITY +CONNECTOR/M/S +CONNOISSEUR/M/S +CONNOTE/D/G/S +CONQUER/D/R/Z/G/S +CONQUERABLE +CONQUEROR/M/S +CONQUEST/M/S +CONS +CONSCIENCE/M/S +CONSCIENTIOUS/Y +CONSCIOUS/P/Y +CONSECRATE/N +CONSECUTIVE/Y +CONSENSUS +CONSENT/D/R/Z/G/S +CONSEQUENCE/M/S +CONSEQUENT/Y/S +CONSEQUENTIAL +CONSEQUENTIALITY/S +CONSERVATION/M/S +CONSERVATIONIST/M/S +CONSERVATISM +CONSERVATIVE/Y/S +CONSERVE/D/G/S +CONSIDER/D/G/S +CONSIDERABLE +CONSIDERABLY +CONSIDERATE/N/X/Y +CONSIGN/D/G/S +CONSIST/D/G/S +CONSISTENCY +CONSISTENT/Y +CONSOLABLE +CONSOLATION/M/S +CONSOLE/D/R/Z/G/S +CONSOLIDATE/D/G/N/S +CONSOLINGLY +CONSONANT/M/S +CONSORT/D/G/S +CONSORTIUM +CONSPICUOUS/Y +CONSPIRACY/M/S +CONSPIRATOR/M/S +CONSPIRE/D/S +CONSTABLE/M/S +CONSTANCY +CONSTANT/Y/S +CONSTELLATION/M/S +CONSTERNATION +CONSTITUENCY/M/S +CONSTITUENT/M/S +CONSTITUTE/D/G/N/X/V/S +CONSTITUTIONAL/Y +CONSTITUTIONALITY +CONSTRAIN/D/G/S +CONSTRAINT/M/S +CONSTRUCT/D/G/V/S +CONSTRUCTIBILITY +CONSTRUCTIBLE +CONSTRUCTION/M/S +CONSTRUCTIVELY +CONSTRUCTOR/M/S +CONSTRUE/D/G +CONSUL/M/S +CONSULATE/M/S +CONSULT/D/G/S +CONSULTANT/M/S +CONSULTATION/M/S +CONSUMABLE +CONSUME/D/R/Z/G/S +CONSUMER'S +CONSUMMATE/D/N/Y +CONSUMPTION/M/S +CONSUMPTIVE/Y +CONTACT/D/G/S +CONTAGION +CONTAGIOUS/Y +CONTAIN/D/R/Z/G/S +CONTAINABLE +CONTAINMENT/M/S +CONTAMINATE/D/G/N/S +CONTEMPLATE/D/G/N/X/V/S +CONTEMPORARY/P/S +CONTEMPT +CONTEMPTIBLE +CONTEMPTUOUS/Y +CONTEND/D/R/Z/G/S +CONTENT/D/G/Y/S +CONTENTION/M/S +CONTENTMENT +CONTEST/D/R/Z/G/S +CONTESTABLE +CONTEXT/M/S +CONTEXTUAL/Y +CONTIGUITY +CONTIGUOUS/Y +CONTINENT/M/S +CONTINENTAL/Y +CONTINGENCY/M/S +CONTINGENT/M/S +CONTINUAL/Y +CONTINUANCE/M/S +CONTINUATION/M/S +CONTINUE/D/G/S +CONTINUITY/S +CONTINUO +CONTINUOUS/Y +CONTINUUM +CONTOUR/D/M/G/S +CONTRACT/D/G/S +CONTRACTION/M/S +CONTRACTOR/M/S +CONTRACTUAL/Y +CONTRADICT/D/G/S +CONTRADICTION/M/S +CONTRADICTORY +CONTRADISTINCTION/S +CONTRAPOSITIVE/S +CONTRAPTION/M/S +CONTRARY/P +CONTRAST/D/R/Z/G/S +CONTRASTINGLY +CONTRIBUTE/D/G/N/X/S +CONTRIBUTOR/M/S +CONTRIBUTORILY +CONTRIBUTORY +CONTRIVANCE/M/S +CONTRIVE/D/R/G/S +CONTROL/M/S +CONTROLLABILITY +CONTROLLABLE +CONTROLLABLY +CONTROLLED +CONTROLLER/M/S +CONTROLLING +CONTROVERSIAL +CONTROVERSY/M/S +CONUNDRUM/M/S +CONVENE/D/G/S +CONVENIENCE/M/S +CONVENIENT/Y +CONVENT/M/S +CONVENTION/M/S +CONVENTIONAL/Y +CONVERGE/D/G/S +CONVERGENCE +CONVERGENT +CONVERSANT/Y +CONVERSATION/M/S +CONVERSATIONAL/Y +CONVERSE/D/G/N/X/Y/S +CONVERT/D/R/Z/G/S +CONVERTIBILITY +CONVERTIBLE +CONVEX +CONVEY/D/R/Z/G/S +CONVEYANCE/M/S +CONVICT/D/G/S +CONVICTION/M/S +CONVINCE/D/R/Z/G/S +CONVINCINGLY +CONVOLUTED +CONVOY/D/G/S +CONVULSION/M/S +COO/G +COOK/D/G/S +COOKERY +COOKIE/M/S +COOKY +COOL/P/D/T/G/Y/S +COOLER/M/S +COOLIE/M/S +COON/M/S +COOP/D/R/Z/S +COOPERATE/D/G/N/X/V/S +COOPERATIVELY +COOPERATIVES +COOPERATOR/M/S +COORDINATE/D/G/N/X/S +COORDINATOR/M/S +COP/M/S +COPE/D/G/J/S +COPIOUS/P/Y +COPPER/M/S +COPSE +COPY/D/R/Z/G/S +COPYRIGHT/M/S +CORAL +CORD/D/R/S +CORDIAL/Y +CORE/D/R/Z/G/S +CORK/D/R/Z/G/S +CORMORANT +CORN/R/Z/G/S +CORNERED +CORNERSTONE/M/S +CORNFIELD/M/S +COROLLARY/M/S +CORONARY/S +CORONATION +CORONET/M/S +COROUTINE/M/S +CORPOCRACY/S +CORPORAL/M/S +CORPORATE/N/X/Y +CORPORATION'S +CORPS +CORPSE/M/S +CORPUS +CORRECT/P/D/G/Y/S +CORRECTABLE +CORRECTION/S +CORRECTIVE/Y/S +CORRECTOR +CORRELATE/D/G/N/X/V/S +CORRESPOND/D/G/S +CORRESPONDENCE/M/S +CORRESPONDENT/M/S +CORRESPONDINGLY +CORRIDOR/M/S +CORROBORATE/D/G/N/X/V/S +CORROSION +CORRUPT/D/R/G/S +CORRUPTION +CORSET +CORTEX +CORTICAL +COSINE/S +COSMETIC/S +COSMOLOGY +COSMOPOLITAN +COST/D/G/Y/S +COSTUME/D/R/G/S +COT/M/S +COTTAGE/R/S +COTTON/S +COTYLEDON/M/S +COUCH/D/G/S +COUGH/D/G +COUGHS +COULD +COULDN'T +COUNCIL/M/S +COUNCILLOR/M/S +COUNSEL/D/G/S +COUNSELLED +COUNSELLING +COUNSELLOR/M/S +COUNSELOR/M/S +COUNT/D/Z/G/S +COUNTABLE +COUNTABLY +COUNTENANCE +COUNTER/D/G/S +COUNTERACT/D/G/V +COUNTERCLOCKWISE +COUNTEREXAMPLE/S +COUNTERFEIT/D/R/G +COUNTERMEASURE/M/S +COUNTERPART/M/S +COUNTERPOINT/G +COUNTERPRODUCTIVE +COUNTERREVOLUTION +COUNTESS +COUNTLESS +COUNTRY/M/S +COUNTRYMAN +COUNTRYSIDE +COUNTY/M/S +COUPLE/D/R/Z/G/J/S +COUPON/M/S +COURAGE +COURAGEOUS/Y +COURIER/M/S +COURSE/D/R/G/S +COURT/D/R/Z/G/Y/S +COURTEOUS/Y +COURTESY/M/S +COURTHOUSE/M/S +COURTIER/M/S +COURTROOM/M/S +COURTSHIP +COURTYARD/M/S +COUSIN/M/S +COVE/Z/S +COVENANT/M/S +COVER/D/G/J/S +COVERABLE +COVERAGE +COVERLET/M/S +COVERT/Y +COVET/D/G/S +COVETOUS/P +COW/D/Z/G/S +COWARD/Y +COWARDICE +COWBOY/M/S +COWER/D/R/Z/G/S +COWERINGLY +COWL/G/S +COWSLIP/M/S +COYOTE/M/S +COZY/P/R +CPU +CRAB/M/S +CRACK/D/R/Z/G/S +CRACKLE/D/G/S +CRADLE/D/S +CRAFT/D/R/G/S +CRAFTSMAN +CRAFTY/P +CRAG/M/S +CRAM/S +CRAMP/M/S +CRANBERRY/M/S +CRANE/M/S +CRANK/D/G/S +CRANKILY +CRANKY/T/R +CRASH/D/R/Z/G/S +CRATE/R/Z/S +CRAVAT/M/S +CRAVE/D/G/S +CRAVEN +CRAWL/D/R/Z/G/S +CRAY +CRAZE/D/G/S +CRAZILY +CRAZY/P/T/R +CREAK/D/G/S +CREAM/D/R/Z/G/S +CREAMY +CREASE/D/G/S +CREATE/D/G/N/X/V/S +CREATIVELY +CREATIVENESS +CREATIVITY +CREATOR/M/S +CREATURE/M/S +CREDENCE +CREDIBILITY +CREDIBLE +CREDIBLY +CREDIT/D/G/S +CREDITABLE +CREDITABLY +CREDITOR/M/S +CREDULITY +CREDULOUS/P +CREED/M/S +CREEK/M/S +CREEP/R/Z/G/S +CREMATE/D/G/N/X/S +CREPE +CREPT +CRESCENT/M/S +CREST/D/S +CREVICE/M/S +CREW/D/G/S +CRIB/M/S +CRICKET/M/S +CRIME/M/S +CRIMINAL/Y/S +CRIMSON/G +CRINGE/D/G/S +CRIPPLE/D/G/S +CRISES +CRISIS +CRISP/P/Y +CRITERIA +CRITERION +CRITIC/M/S +CRITICAL/Y +CRITICISE/D +CRITICISM/M/S +CRITICIZE/D/G/S +CRITIQUE/G/S +CROAK/D/G/S +CROCHET/S +CROOK/D/S +CROP/M/S +CROPPED +CROPPER/M/S +CROPPING +CROSS/D/R/Z/G/Y/J/S +CROSSABLE +CROSSBAR/M/S +CROSSOVER/M/S +CROSSWORD/M/S +CROUCH/D/G +CROW/D/G/S +CROWD/D/R/G/S +CROWN/D/G/S +CRT +CRUCIAL/Y +CRUCIFY/D/G/S +CRUDE/P/T/Y +CRUEL/T/R/Y +CRUELTY +CRUISE/R/Z/G/S +CRUMB/Y/S +CRUMBLE/D/G/S +CRUMPLE/D/G/S +CRUNCH/D/G/S +CRUNCHY/T/R +CRUSADE/R/Z/G/S +CRUSH/D/R/Z/G/S +CRUSHABLE +CRUSHINGLY +CRUST/M/S +CRUSTACEAN/M/S +CRUTCH/M/S +CRUX/M/S +CRY/D/R/Z/G/S +CRYPTANALYSIS +CRYPTOGRAPHIC +CRYPTOGRAPHY +CRYPTOLOGY +CRYSTAL/M/S +CRYSTALLINE +CRYSTALLIZE/D/G/S +CS +CSD +CUB/M/S +CUBE/D/S +CUBIC +CUCKOO/M/S +CUCUMBER/M/S +CUDDLE/D +CUDGEL/M/S +CUE/D/S +CUFF/M/S +CULL/D/R/G/S +CULMINATE/D/G/N/S +CULPRIT/M/S +CULT/M/S +CULTIVATE/D/G/N/X/S +CULTIVATOR/M/S +CULTURAL/Y +CULTURE/D/G/S +CUMBERSOME +CUMULATIVE/Y +CUNNING/Y +CUP/M/S +CUPBOARD/M/S +CUPFUL +CUPPED +CUPPING +CUR/Y/S +CURABLE +CURABLY +CURB/G/S +CURD +CURE/D/G/S +CURFEW/M/S +CURIOSITY/M/S +CURIOUS/T/R/Y +CURL/D/R/Z/G/S +CURRANT/M/S +CURRENCY/M/S +CURRENT/P/Y/S +CURRICULA +CURRICULAR +CURRICULUM/M/S +CURRY/D/G/S +CURSE/D/G/V/S +CURSOR/M/S +CURSORILY +CURSORY +CURT/P/Y +CURTAIL/D/S +CURTAIN/D/S +CURTATE +CURTSY/M/S +CURVATURE +CURVE/D/G/S +CUSHION/D/G/S +CUSP/M/S +CUSTARD +CUSTODIAN/M/S +CUSTODY +CUSTOM/R/Z/S +CUSTOMARILY +CUSTOMARY +CUSTOMIZABLE +CUSTOMIZATION/M/S +CUSTOMIZE/D/R/Z/G/S +CUT/M/S +CUTE/T +CUTOFF +CUTTER/M/S +CUTTING/Y/S +CYBERNETIC +CYCLE/D/G/S +CYCLIC +CYCLICALLY +CYCLOID/M/S +CYCLOIDAL +CYCLONE/M/S +CYLINDER/M/S +CYLINDRICAL +CYMBAL/M/S +CYNICAL/Y +CYPRESS +CYST/S +CYTOLOGY +CZAR +DABBLE/D/R/G/S +DAD/M/S +DADDY +DAEMON/M/S +DAFFODIL/M/S +DAGGER +DAILY/S +DAINTILY +DAINTY/P +DAIRY +DAISY/M/S +DALE/M/S +DAM/M/S +DAMAGE/D/R/Z/G/S +DAMASK +DAME +DAMN/D/G/S +DAMNATION +DAMP/P/R/G/N/X +DAMSEL/M/S +DAN/M +DANCE/D/R/Z/G/S +DANDELION/M/S +DANDY +DANGER/M/S +DANGEROUS/Y +DANGLE/D/G/S +DANIEL/M +DARE/D/R/Z/G/S +DARESAY +DARINGLY +DARK/P/T/R/N/Y +DARLING/M/S +DARN/D/R/G/S +DARPA +DART/D/R/G/S +DASH/D/R/Z/G/S +DASHING/Y +DATA +DATABASE/M/S +DATE/D/R/G/V/S +DATUM +DAUGHTER/Y/S +DAUNT/D +DAUNTLESS +DAVE/M +DAVID/M +DAWN/D/G/S +DAY/M/S +DAYBREAK +DAYDREAM/G/S +DAYLIGHT/M/S +DAYTIME +DAZE/D +DAZZLE/D/R/G/S +DAZZLINGLY +DBMS +DEACON/M/S +DEAD/P/N/Y +DEADLINE/M/S +DEADLOCK/D/G/S +DEAF/P/T/R/N +DEAL/R/Z/G/J/S +DEALLOCATE/D/G/N/X/S +DEALLOCATED +DEALLOCATION +DEALT +DEAN/M/S +DEAR/P/T/R/H/Y +DEARTHS +DEATH/Y +DEATHRATE/M/S +DEATHS +DEBATABLE +DEBATE/D/R/Z/G/S +DEBBIE/M +DEBILITATE/D/G/S +DEBRIS +DEBT/M/S +DEBTOR +DEBUG/S +DEBUGGED +DEBUGGER/M/S +DEBUGGING +DECADE/M/S +DECADENCE +DECADENT/Y +DECAY/D/G/S +DECEASE/D/G/S +DECEIT +DECEITFUL/P/Y +DECEIVE/D/R/Z/G/S +DECELERATE/D/G/N/S +DECEMBER +DECENCY/M/S +DECENT/Y +DECENTRALIZATION +DECENTRALIZED +DECEPTION/M/S +DECEPTIVE/Y +DECIDABILITY +DECIDABLE +DECIDE/D/G/S +DECIDEDLY +DECIMAL/S +DECIMATE/D/G/N/S +DECIPHER/D/R/G/S +DECISION/M/S +DECISIVE/P/Y +DECK/D/G/J/S +DECLARATION/M/S +DECLARATIVE/Y/S +DECLARE/D/R/Z/G/S +DECLINATION/M/S +DECLINE/D/R/Z/G/S +DECODE/D/R/Z/G/J/S +DECOMPOSABILITY +DECOMPOSABLE +DECOMPOSE/D/G/S +DECOMPOSITION/M/S +DECOMPRESSION +DECONSTRUCT/D/G/S +DECONSTRUCTION +DECORATE/D/G/N/X/V/S +DECORUM +DECOUPLE/D/G/S +DECOY/M/S +DECREASE/D/G/S +DECREASINGLY +DECREE/D/S +DECREEING +DECREMENT/D/G/S +DEDICATE/D/G/N/S +DEDUCE/D/R/G/S +DEDUCIBLE +DEDUCT/D/G/V +DEDUCTION/M/S +DEED/D/G/S +DEEM/D/G/S +DEEMPHASIZE/D/G/S +DEEP/T/R/N/Y/S +DEEPEN/D/G/S +DEER +DEFAULT/D/R/G/S +DEFEAT/D/G/S +DEFECT/D/G/V/S +DEFECTION/M/S +DEFEND/D/R/Z/G/S +DEFENDANT/M/S +DEFENESTRATE/D/G/N/S +DEFENSE/V/S +DEFENSELESS +DEFER/S +DEFERENCE +DEFERMENT/M/S +DEFERRABLE +DEFERRED +DEFERRER/M/S +DEFERRING +DEFIANCE +DEFIANT/Y +DEFICIENCY/S +DEFICIENT +DEFICIT/M/S +DEFILE/G +DEFINABLE +DEFINE/D/R/G/S +DEFINITE/P/N/X/Y +DEFINITION/M/S +DEFINITIONAL +DEFINITIVE +DEFORMATION/M/S +DEFORMED +DEFORMITY/M/S +DEFTLY +DEFY/D/G/S +DEGENERATE/D/G/N/V/S +DEGRADABLE +DEGRADATION/M/S +DEGRADE/D/G/S +DEGREE/M/S +DEIGN/D/G/S +DEITY/M/S +DEJECTED/Y +DELAWARE +DELAY/D/G/S +DELEGATE/D/G/N/X/S +DELETE/D/R/G/N/X/S +DELIBERATE/P/D/G/N/X/Y/S +DELIBERATIVE +DELIBERATOR/M/S +DELICACY/M/S +DELICATE/Y +DELICIOUS/Y +DELIGHT/D/G/S +DELIGHTEDLY +DELIGHTFUL/Y +DELIMIT/D/R/Z/G/S +DELINEATE/D/G/N/S +DELIRIOUS/Y +DELIVER/D/R/Z/G/S +DELIVERABLE/S +DELIVERANCE +DELIVERY/M/S +DELL/M/S +DELTA/M/S +DELUDE/D/G/S +DELUGE/D/S +DELUSION/M/S +DELVE/G/S +DEMAND/D/R/G/S +DEMANDINGLY +DEMARCATE/N/D/G/S +DEMEANOR +DEMISE +DEMO/S +DEMOCRACY/M/S +DEMOCRAT/M/S +DEMOCRATIC +DEMOCRATICALLY +DEMOGRAPHIC +DEMOLISH/D/S +DEMOLITION +DEMON/M/S +DEMONSTRABLE +DEMONSTRATE/D/G/N/X/V/S +DEMONSTRATIVELY +DEMONSTRATOR/M/S +DEMORALIZE/D/G/S +DEMUR +DEN/M/S +DENDRITE/S +DENIABLE +DENIAL/M/S +DENIGRATE/D/G/S +DENMARK +DENOMINATION/M/S +DENOMINATOR/M/S +DENOTABLE +DENOTATION/M/S +DENOTATIONAL/Y +DENOTE/D/G/S +DENOUNCE/D/G/S +DENSE/P/T/R/Y +DENSITY/M/S +DENT/D/G/S +DENTAL/Y +DENTIST/M/S +DENY/D/R/G/S +DEPART/D/G/S +DEPARTMENT/M/S +DEPARTMENTAL +DEPARTURE/M/S +DEPEND/D/G/S +DEPENDABILITY +DEPENDABLE +DEPENDABLY +DEPENDENCE +DEPENDENCY/S +DEPENDENT/Y/S +DEPICT/D/G/S +DEPLETE/D/G/N/X/S +DEPLORABLE +DEPLORE/D/S +DEPLOY/D/G/S +DEPLOYABLE +DEPLOYMENT/M/S +DEPORTATION +DEPORTMENT +DEPOSE/D/S +DEPOSIT/D/G/S +DEPOSITION/M/S +DEPOSITOR/M/S +DEPOT/M/S +DEPRAVE/D +DEPRECIATE/N/S +DEPRESS/D/G/S +DEPRESSION/M/S +DEPRIVATION/M/S +DEPRIVE/D/G/S +DEPT +DEPTH +DEPTHS +DEPUTY/M/S +DEQUEUE/D/G/S +DERAIL/D/G/S +DERBY +DERIDE +DERISION +DERIVABLE +DERIVATION/M/S +DERIVATIVE/M/S +DERIVE/D/G/S +DESCEND/D/R/Z/G/S +DESCENDANT/M/S +DESCENT/M/S +DESCRIBABLE +DESCRIBE/D/R/G/S +DESCRIPTION/M/S +DESCRIPTIVE/Y/S +DESCRIPTOR/M/S +DESCRY +DESELECTED +DESERT/D/R/Z/G/S +DESERTION/S +DESERVE/D/G/J/S +DESERVINGLY +DESIDERATA +DESIDERATUM +DESIGN/D/R/Z/G/S +DESIGNATE/D/G/N/X/S +DESIGNATOR/M/S +DESIGNER'S +DESIRABILITY +DESIRABLE +DESIRABLY +DESIRE/D/G/S +DESIROUS +DESK/M/S +DESOLATE/N/X/Y +DESPAIR/D/G/S +DESPAIRINGLY +DESPATCH/D +DESPERATE/N/Y +DESPISE/D/G/S +DESPITE +DESPOT/M/S +DESPOTIC +DESSERT/M/S +DESTINATION/M/S +DESTINE/D +DESTINY/M/S +DESTITUTE/N +DESTROY/D/G/S +DESTROYER/M/S +DESTRUCTION/M/S +DESTRUCTIVE/P/Y +DETACH/D/R/G/S +DETACHMENT/M/S +DETAIL/D/G/S +DETAIN/D/G/S +DETECT/D/G/V/S +DETECTABLE +DETECTABLY +DETECTION/M/S +DETECTIVES +DETECTOR/M/S +DETENTION +DETERIORATE/D/G/N/S +DETERMINABLE +DETERMINACY +DETERMINANT/M/S +DETERMINATE/N/X/V/Y +DETERMINE/D/R/Z/G/S +DETERMINISM +DETERMINISTIC +DETERMINISTICALLY +DETERRENT +DETEST/D +DETESTABLE +DETRACT/S +DETRACTOR/M/S +DETRIMENT +DETRIMENTAL +DEVASTATE/D/G/N/S +DEVELOP/D/R/Z/G/S +DEVELOPMENT/M/S +DEVELOPMENTAL +DEVIANT/M/S +DEVIATE/D/G/N/X/S +DEVICE/M/S +DEVIL/M/S +DEVILISH/Y +DEVISE/D/G/J/S +DEVOID +DEVOTE/D/G/N/X/S +DEVOTEDLY +DEVOTEE/M/S +DEVOUR/D/R/S +DEVOUT/P/Y +DEW +DEWDROP/M/S +DEWY +DEXTERITY +DIADEM +DIAGNOSABLE +DIAGNOSE/D/G/S +DIAGNOSIS +DIAGNOSTIC/M/S +DIAGONAL/Y/S +DIAGRAM/M/S +DIAGRAMMABLE +DIAGRAMMATIC +DIAGRAMMATICALLY +DIAGRAMMED +DIAGRAMMER/M/S +DIAGRAMMING +DIAL/D/G/S +DIALECT/M/S +DIALOG/M/S +DIALOGUE/M/S +DIAMETER/M/S +DIAMETRICALLY +DIAMOND/M/S +DIAPER/M/S +DIAPHRAGM/M/S +DIARY/M/S +DIATRIBE/M/S +DICE +DICHOTOMIZE +DICHOTOMY +DICKENS +DICKY +DICTATE/D/G/N/X/S +DICTATOR/M/S +DICTATORSHIP +DICTION +DICTIONARY/M/S +DICTUM/M/S +DID +DIDN'T +DIE/D/S +DIEGO +DIELECTRIC/M/S +DIET/R/Z/S +DIETITIAN/M/S +DIFFER/D/G/R/S/Z +DIFFERENCE/M/S +DIFFERENT/Y +DIFFERENTIAL/M/S +DIFFERENTIATE/D/G/N/X/S +DIFFERENTIATORS +DIFFICULT/Y +DIFFICULTY/M/S +DIFFUSE/D/R/Z/G/N/X/Y/S +DIG/S +DIGEST/D/G/V/S +DIGESTIBLE +DIGESTION +DIGGER/M/S +DIGGING/S +DIGIT/M/S +DIGITAL/Y +DIGITIZE/S/G/D +DIGNIFY/D +DIGNITY/S +DIGRESS/D/G/V/S +DIGRESSION/M/S +DIKE/M/S +DILATE/D/G/N/S +DILEMMA/M/S +DILIGENCE +DILIGENT/Y +DILUTE/D/G/N/S +DIM/P/Y/S +DIME/M/S +DIMENSION/D/G/S +DIMENSIONAL/Y +DIMENSIONALITY +DIMINISH/D/G/S +DIMINUTION +DIMINUTIVE +DIMMED +DIMMER/M/S +DIMMEST +DIMMING +DIMPLE/D +DIN +DINE/D/R/Z/G/S +DINGY/P +DINNER/M/S +DINT +DIODE/M/S +DIOPHANTINE +DIOXIDE +DIP/S +DIPHTHERIA +DIPLOMA/M/S +DIPLOMACY +DIPLOMAT/M/S +DIPLOMATIC +DIPPED +DIPPER/M/S +DIPPING/S +DIRE +DIRECT/P/D/G/Y/S +DIRECTION/M/S +DIRECTIONAL/Y +DIRECTIONALITY +DIRECTIVE/M/S +DIRECTOR/M/S +DIRECTORY/M/S +DIRGE/M/S +DIRT/S +DIRTILY +DIRTY/P/T/R +DISABILITY/M/S +DISABLE/D/R/Z/G/S +DISADVANTAGE/M/S +DISAGREE/D/S +DISAGREEABLE +DISAGREEING +DISAGREEMENT/M/S +DISALLOW/D/G/S +DISAMBIGUATE/D/G/N/X/S +DISAPPEAR/D/G/S +DISAPPEARANCE/M/S +DISAPPOINT/D/G +DISAPPOINTMENT/M/S +DISAPPROVAL +DISAPPROVE/D/S +DISARM/D/G/S +DISARMAMENT +DISASSEMBLE/D/G/S +DISASTER/M/S +DISASTROUS/Y +DISBAND/D/G/S +DISBURSE/D/G/S +DISBURSEMENT/M/S +DISC/M/S +DISCARD/D/G/S +DISCERN/D/G/S +DISCERNIBILITY +DISCERNIBLE +DISCERNIBLY +DISCERNINGLY +DISCERNMENT +DISCHARGE/D/G/S +DISCIPLE/M/S +DISCIPLINARY +DISCIPLINE/D/G/S +DISCLAIM/D/R/S +DISCLOSE/D/G/S +DISCLOSURE/M/S +DISCOMFORT +DISCONCERT +DISCONCERTING/Y +DISCONNECT/D/G/S +DISCONNECTION +DISCONTENT/D +DISCONTINUANCE +DISCONTINUE/D/S +DISCONTINUITY/M/S +DISCONTINUOUS +DISCORD +DISCOUNT/D/G/S +DISCOURAGE/D/G/S +DISCOURAGEMENT +DISCOURSE/M/S +DISCOVER/D/R/Z/G/S +DISCOVERY/M/S +DISCREDIT/D +DISCREET/Y +DISCREPANCY/M/S +DISCRETE/P/N/Y +DISCRIMINATE/D/G/N/S +DISCRIMINATORY +DISCUSS/D/G/S +DISCUSSION/M/S +DISDAIN/G/S +DISEASE/D/S +DISENGAGE/D/G/S +DISFIGURE/D/G/S +DISGORGE +DISGRACE/D/S +DISGRACEFUL/Y +DISGRUNTLED +DISGUISE/D/S +DISGUST/D/G/S +DISGUSTEDLY +DISGUSTINGLY +DISH/D/G/S +DISHEARTEN/G +DISHONEST/Y +DISHONOR/D/G/S +DISHWASHER/S +DISHWASHING +DISILLUSION/D/G +DISILLUSIONMENT/M/S +DISINTERESTED/P +DISJOINT/P/D +DISJUNCT/V/S +DISJUNCTION/S +DISJUNCTIVELY +DISK/M/S +DISKETTE/S +DISLIKE/D/G/S +DISLOCATE/D/G/N/X/S +DISLODGE/D +DISMAL/Y +DISMAY/D/G +DISMISS/D/R/Z/G/S +DISMISSAL/M/S +DISMOUNT/D/G/S +DISOBEDIENCE +DISOBEY/D/G/S +DISORDER/D/Y/S +DISORGANIZED +DISORIENTED +DISOWN/D/G/S +DISPARATE +DISPARITY/M/S +DISPATCH/D/R/Z/G/S +DISPEL/S +DISPELLED +DISPELLING +DISPENSATION +DISPENSE/D/R/Z/G/S +DISPERSE/D/G/N/X/S +DISPLACE/D/G/S +DISPLACEMENT/M/S +DISPLAY/D/G/S +DISPLEASE/D/G/S +DISPLEASURE +DISPOSABLE +DISPOSAL/M/S +DISPOSE/D/R/G/S +DISPOSITION/M/S +DISPROVE/D/G/S +DISPUTE/D/R/Z/G/S +DISQUALIFY/D/G/N/S +DISQUIET/G +DISREGARD/D/G/S +DISRUPT/D/G/V/S +DISRUPTION/M/S +DISSATISFACTION/M/S +DISSATISFIED +DISSEMINATE/D/G/N/S +DISSENSION/M/S +DISSENT/D/R/Z/G/S +DISSERTATION/M/S +DISSERVICE +DISSIDENT/M/S +DISSIMILAR +DISSIMILARITY/M/S +DISSIPATE/D/G/N/S +DISSOCIATE/D/G/N/S +DISSOLUTION/M/S +DISSOLVE/D/G/S +DISTAL/Y +DISTANCE/S +DISTANT/Y +DISTASTE/S +DISTASTEFUL/Y +DISTEMPER +DISTILL/D/R/Z/G/S +DISTILLATION +DISTINCT/P/Y +DISTINCTION/M/S +DISTINCTIVE/P/Y +DISTINGUISH/D/G/S +DISTINGUISHABLE +DISTORT/D/G/S +DISTORTION/M/S +DISTRACT/D/G/S +DISTRACTION/M/S +DISTRAUGHT +DISTRESS/D/G/S +DISTRIBUTE/D/G/N/V/S +DISTRIBUTION/M/S +DISTRIBUTIONAL +DISTRIBUTIVITY +DISTRIBUTOR/M/S +DISTRICT/M/S +DISTRUST/D +DISTURB/D/R/G/S +DISTURBANCE/M/S +DISTURBINGLY +DITCH/M/S +DITTO +DIVAN/M/S +DIVE/D/R/Z/G/S +DIVERGE/D/G/S +DIVERGENCE/M/S +DIVERGENT +DIVERSE/N/X/Y +DIVERSIFY/D/G/N/S +DIVERSITY/S +DIVERT/D/G/S +DIVEST/D/G/S +DIVIDE/D/R/Z/G/S +DIVIDEND/M/S +DIVINE/R/G/Y +DIVINITY/M/S +DIVISION/M/S +DIVISOR/M/S +DIVORCE/D +DIVULGE/D/G/S +DIZZY/P +DNA +DO/R/Z/G/J +DOCK/D/S +DOCTOR/D/S +DOCTORAL +DOCTORATE/M/S +DOCTRINE/M/S +DOCUMENT/D/R/Z/G/S +DOCUMENTARY/M/S +DOCUMENTATION/M/S +DODGE/D/R/Z/G +DOES +DOESN'T +DOG/M/S +DOGGED/P/Y +DOGGING +DOGMA/M/S +DOGMATISM +DOLE/D/S +DOLEFUL/Y +DOLL/M/S +DOLLAR/S +DOLLY/M/S +DOLPHIN/M/S +DOMAIN/M/S +DOME/D/S +DOMESTIC +DOMESTICALLY +DOMESTICATE/D/G/N/S +DOMINANCE +DOMINANT/Y +DOMINATE/D/G/N/S +DOMINION +DON'T +DON/S +DONALD/M +DONATE/D/G/S +DONE +DONKEY/M/S +DOOM/D/G/S +DOOR/M/S +DOORSTEP/M/S +DOORWAY/M/S +DOPE/D/R/Z/G/S +DORMANT +DORMITORY/M/S +DOSE/D/S +DOT/M/S +DOTE/D/G/S +DOTINGLY +DOTTED +DOTTING +DOUBLE/D/R/Z/G/S +DOUBLET/M/S +DOUBLY +DOUBT/D/R/Z/G/S +DOUBTABLE +DOUBTFUL/Y +DOUBTLESS/Y +DOUG/M +DOUGH +DOUGHNUT/M/S +DOUGLAS +DOVE/R/S +DOWN/D/Z/G/S +DOWNCAST +DOWNFALL/N +DOWNPLAY/D/G/S +DOWNRIGHT +DOWNSTAIRS +DOWNSTREAM +DOWNTOWN/S +DOWNWARD/S +DOWNY +DOZE/D/G/S +DOZEN/H/S +DR +DRAB +DRAFT/D/R/Z/G/S +DRAFTSMAN +DRAFTSMEN +DRAG/S +DRAGGED +DRAGGING +DRAGON/M/S +DRAGOON/D/S +DRAIN/D/R/G/S +DRAINAGE +DRAKE +DRAMA/M/S +DRAMATIC/S +DRAMATICALLY +DRAMATIST/M/S +DRANK +DRAPE/D/R/Z/S +DRAPERY/M/S +DRASTIC +DRASTICALLY +DRAUGHT/M/S +DRAW/R/Z/G/J/S +DRAWBACK/M/S +DRAWBRIDGE/M/S +DRAWL/D/G/S +DRAWN/P/Y +DREAD/D/G/S +DREADFUL/Y +DREAM/D/R/Z/G/S +DREAMILY +DREAMY +DREARY/P +DREGS +DRENCH/D/G/S +DRESS/D/R/Z/G/J/S +DRESSMAKER/M/S +DREW +DRIER/M/S +DRIFT/D/R/Z/G/S +DRILL/D/R/G/S +DRILY +DRINK/R/Z/G/S +DRINKABLE +DRIP/M/S +DRIVE/R/Z/G/S +DRIVEN +DRIVEWAY/M/S +DRONE/M/S +DROOP/D/G/S +DROP/M/S +DROPPED +DROPPER/M/S +DROPPING/M/S +DROUGHT/M/S +DROVE/R/Z/S +DROWN/D/G/J/S +DROWSY/P +DRUDGERY +DRUG/M/S +DRUGGIST/M/S +DRUM/M/S +DRUMMED +DRUMMER/M/S +DRUMMING +DRUNK/R/N/Y/S +DRUNKARD/M/S +DRUNKENNESS +DRY/D/T/G/Y/S +DUAL +DUALITY/M/S +DUANE/M +DUB/S +DUBBED +DUBIOUS/P/Y +DUCHESS/M/S +DUCHY +DUCK/D/G/S +DUE/S +DUEL/G/S +DUG +DUKE/M/S +DULL/P/D/T/R/G/S +DULLY +DULY +DUMB/P/T/R/Y +DUMBBELL/M/S +DUMMY/M/S +DUMP/D/R/G/S +DUMPLING +DUNCE/M/S +DUNE/M/S +DUNGEON/M/S +DUPLICATE/D/G/N/X/S +DUPLICATOR/M/S +DURABILITY/S +DURABLE +DURABLY +DURATION/M/S +DURING +DUSK +DUSKY/P +DUST/D/R/Z/G/S +DUSTY/T/R +DUTIFUL/P/Y +DUTY/M/S +DWARF/D/S +DWELL/D/R/Z/G/J/S +DWINDLE/D/G +DYE/D/R/Z/G/S +DYEING +DYNAMIC/S +DYNAMICAL +DYNAMICALLY +DYNAMITE/D/G/S +DYNASTY/M/S +EACH +EAGER/P/Y +EAGLE/M/S +EAR/D/H/S +EARL/M/S +EARLY/P/T/R +EARMARK/D/G/J/S +EARN/D/T/G/J/S +EARNER/M/S +EARNESTLY +EARNESTNESS +EARRING/M/S +EARTHEN +EARTHENWARE +EARTHLY/P +EARTHQUAKE/M/S +EARTHS +EARTHWORM/M/S +EASE/D/G/S +EASEMENT/M/S +EASILY +EAST/R +EASTERN/R/Z +EASTWARD/S +EASY/P/T/R +EAT/R/Z/G/N/J/S +EAVES +EAVESDROP/S +EAVESDROPPED +EAVESDROPPER/M/S +EAVESDROPPING +EBB/G/S +EBONY +ECCENTRIC/M/S +ECCENTRICITY/S +ECCLESIASTICAL +ECHO/D/G +ECHOES +ECHOIC +ECLIPSE/D/G/S +ECOLOGY +ECONOMIC/S +ECONOMICAL/Y +ECONOMIST/M/S +ECONOMIZE/D/R/Z/G/S +ECONOMY/M/S +ECSTASY +EDDY/M/S +EDGE/D/G/S +EDIBLE +EDICT/M/S +EDIFICE/M/S +EDIT/D/G/S +EDITION/M/S +EDITOR/M/S +EDITORIAL/Y/S +EDUCATE/D/G/N/X/S +EDUCATIONAL/Y +EDUCATOR/M/S +EDWARD/M +EEL/M/S +EERIE +EFFECT/D/G/V/S +EFFECTIVELY +EFFECTIVENESS +EFFECTOR/M/S +EFFECTUALLY +EFFEMINATE +EFFICACY +EFFICIENCY/S +EFFICIENT/Y +EFFIGY +EFFORT/M/S +EFFORTLESS/P/Y +EGG/D/G/S +EGO/S +EIGENVALUE/M/S +EIGHT/S +EIGHTEEN/H/S +EIGHTH/M/S +EIGHTY/H/S +EITHER +EJACULATE/D/G/N/X/S +EJECT/D/G/S +EKE/D/S +EL +ELABORATE/P/D/G/N/X/Y/S +ELABORATORS +ELAPSE/D/G/S +ELASTIC +ELASTICALLY +ELASTICITY +ELBOW/G/S +ELDER/Y/S +ELDEST +ELECT/D/G/V/S +ELECTION/M/S +ELECTIVES +ELECTOR/M/S +ELECTORAL +ELECTRIC +ELECTRICAL/P/Y +ELECTRICITY +ELECTRIFY/G/N +ELECTROCUTE/D/G/N/X/S +ELECTRODE/M/S +ELECTROLYTE/M/S +ELECTROLYTIC +ELECTRON/M/S +ELECTRONIC/S +ELECTRONICALLY +ELEGANCE +ELEGANT/Y +ELEGY +ELEMENT/M/S +ELEMENTAL/S +ELEMENTARY +ELEPHANT/M/S +ELEVATE/D/N/S +ELEVATOR/M/S +ELEVEN/H/S +ELF +ELICIT/D/G/S +ELIGIBILITY +ELIGIBLE +ELIMINATE/D/G/N/X/S +ELIMINATOR/S +ELISION +ELK/M/S +ELLIPSE/M/S +ELLIPSIS +ELLIPSOID/M/S +ELLIPSOIDAL +ELLIPTIC +ELLIPTICAL/Y +ELM/R/S +ELOQUENCE +ELOQUENT/Y +ELSE +ELSEWHERE +ELUCIDATE/D/G/N/S +ELUDE/D/G/S +ELUSIVE/P/Y +ELVES +ELWOOD +EMACIATED +EMACS +EMANATING +EMANCIPATION +EMBARK/D/S +EMBARRASS/D/G/S +EMBARRASSING/Y +EMBARRASSMENT +EMBASSY/M/S +EMBED/S +EMBEDDED +EMBEDDING +EMBELLISH/D/G/S +EMBELLISHMENT/M/S +EMBER +EMBLEM +EMBODIMENT/M/S +EMBODY/D/G/S +EMBRACE/D/G/S +EMBROIDER/D/S +EMBROIDERY/S +EMBRYO/M/S +EMBRYOLOGY +EMERALD/M/S +EMERGE/D/G/S +EMERGENCE +EMERGENCY/M/S +EMERGENT +EMERY +EMIGRANT/M/S +EMIGRATE/D/G/N/S +EMINENCE +EMINENT/Y +EMIT/S +EMITTED +EMOTION/M/S +EMOTIONAL/Y +EMPATHY +EMPEROR/M/S +EMPHASES +EMPHASIS +EMPHASIZE/D/G/S +EMPHATIC +EMPHATICALLY +EMPIRE/M/S +EMPIRICAL/Y +EMPIRICIST/M/S +EMPLOY/D/G/S +EMPLOYABLE +EMPLOYEE/M/S +EMPLOYER/M/S +EMPLOYMENT/M/S +EMPOWER/D/G/S +EMPRESS +EMPTILY +EMPTY/P/D/T/R/G/S +EMULATE/D/N/X/S +EMULATOR/M/S +ENABLE/D/R/Z/G/S +ENACT/D/G/S +ENACTMENT +ENAMEL/D/G/S +ENCAMP/D/G/S +ENCAPSULATE/D/G/N/S +ENCHANT/D/R/G/S +ENCHANTMENT +ENCIPHER/D/G/S +ENCIRCLE/D/S +ENCLOSE/D/G/S +ENCLOSURE/M/S +ENCODE/D/R/G/J/S +ENCOMPASS/D/G/S +ENCOUNTER/D/G/S +ENCOURAGE/D/G/S +ENCOURAGEMENT/S +ENCOURAGINGLY +ENCRYPT/D/G/S +ENCRYPTION +ENCUMBER/D/G/S +ENCYCLOPEDIA/M/S +ENCYCLOPEDIC +END/D/R/Z/G/J/S +ENDANGER/D/G/S +ENDEAR/D/G/S +ENDEAVOR/D/G/S +ENDLESS/P/Y +ENDORSE/D/G/S +ENDORSEMENT +ENDOW/D/G/S +ENDOWMENT/M/S +ENDPOINT/S +ENDURABLE +ENDURABLY +ENDURANCE +ENDURE/D/G/S +ENDURINGLY +ENEMA/M/S +ENEMY/M/S +ENERGETIC +ENERGY/S +ENFORCE/D/R/Z/G/S +ENFORCEMENT +ENGAGE/D/G/S +ENGAGEMENT/M/S +ENGAGINGLY +ENGENDER/D/G/S +ENGINE/M/S +ENGINEER/D/M/G/S +ENGLAND/R/Z +ENGLISH +ENGRAVE/D/R/G/J/S +ENGROSS/D/G +ENHANCE/D/G/S +ENHANCEMENT/M/S +ENIGMATIC +ENJOIN/D/G/S +ENJOY/D/G/S +ENJOYABLE +ENJOYABLY +ENJOYMENT +ENLARGE/D/R/Z/G/S +ENLARGEMENT/M/S +ENLIGHTEN/D/G +ENLIGHTENMENT +ENLIST/D/S +ENLISTMENT +ENLIVEN/D/G/S +ENMITY/S +ENNOBLE/D/G/S +ENNUI +ENORMITY/S +ENORMOUS/Y +ENOUGH +ENQUEUE/D/S +ENQUIRE/D/R/S +ENRAGE/D/G/S +ENRICH/D/G/S +ENROLL/D/G/S +ENROLLMENT/M/S +ENSEMBLE/M/S +ENSIGN/M/S +ENSLAVE/D/G/S +ENSNARE/D/G/S +ENSUE/D/G/S +ENSURE/D/R/Z/G/S +ENTAIL/D/G/S +ENTANGLE +ENTER/D/G/S +ENTERPRISE/G/S +ENTERTAIN/D/R/Z/G/S +ENTERTAININGLY +ENTERTAINMENT/M/S +ENTHUSIASM/S +ENTHUSIAST/M/S +ENTHUSIASTIC +ENTHUSIASTICALLY +ENTICE/D/R/Z/G/S +ENTIRE/Y +ENTIRETY/S +ENTITLE/D/G/S +ENTITY/M/S +ENTRANCE/D/S +ENTREAT/D +ENTREATY +ENTRENCH/D/G/S +ENTREPRENEUR/M/S +ENTROPY +ENTRUST/D/G/S +ENTRY/M/S +ENUMERABLE +ENUMERATE/D/G/N/V/S +ENUMERATOR/S +ENUNCIATION +ENVELOP/S +ENVELOPE/D/R/G/S +ENVIOUS/P/Y +ENVIRON/G/S +ENVIRONMENT/M/S +ENVIRONMENTAL +ENVISAGE/D/S +ENVISION/D/G/S +ENVOY/M/S +ENVY/D/S +EOF +EPAULET/M/S +EPHEMERAL +EPIC/M/S +EPIDEMIC/M/S +EPISCOPAL +EPISODE/M/S +EPISTEMOLOGICAL/Y +EPISTEMOLOGY +EPISTLE/M/S +EPITAPH +EPITAPHS +EPITAXIAL/Y +EPITHET/M/S +EPITOMIZE/D/G/S +EPOCH +EPOCHS +EPSILON +EQUAL/D/G/Y/S +EQUALITY/M/S +EQUALIZE/D/R/Z/G/S +EQUATE/D/G/N/X/S +EQUATOR/M/S +EQUATORIAL +EQUILIBRIUM/S +EQUIP/S +EQUIPMENT +EQUIPPED +EQUIPPING +EQUITABLE +EQUITABLY +EQUITY +EQUIVALENCE/S +EQUIVALENT/Y/S +ERA/M/S +ERADICATE/D/G/N/S +ERASABLE +ERASE/D/R/Z/G/S +ERASURE +ERE +ERECT/D/G/S +ERECTION/M/S +ERECTOR/M/S +ERGO +ERGONOMIC/S +ERMINE/M/S +ERR/D/G/S +ERRAND +ERRATIC +ERRINGLY +ERRONEOUS/P/Y +ERROR/M/S +ERUPTION +ESCALATE/D/G/N/S +ESCAPABLE +ESCAPADE/M/S +ESCAPE/D/G/S +ESCAPEE/M/S +ESCHEW/D/G/S +ESCORT/D/G/S +ESOTERIC +ESPECIAL/Y +ESPERANTO +ESPIONAGE +ESPOUSE/D/G/S +ESPRIT +ESPY +ESQUIRE/S +ESSAY/D/S +ESSENCE/M/S +ESSENTIAL/Y/S +ESTABLISH/D/G/S +ESTABLISHMENT/M/S +ESTATE/M/S +ESTEEM/D/G/S +ESTIMATE/D/G/N/X/S +ETA +ETC +ETERNAL/Y +ETERNITY/S +ETHER/M/S +ETHEREAL/Y +ETHERNET +ETHICAL/Y +ETHICS +ETHNIC +ETHNOCENTRIC +ETIQUETTE +ETYMOLOGICAL +ETYMOLOGY +EUNUCH +EUNUCHS +EUPHEMISM/M/S +EUPHORIA +EUROPE +EUROPEAN/S +EVACUATE/D/N +EVADE/D/G/S +EVALUATE/D/G/N/X/V/S +EVALUATOR/M/S +EVAPORATE/D/G/N/V +EVE/R +EVEN/P/D/Y/S +EVENHANDED/P/Y +EVENING/M/S +EVENT/M/S +EVENTFUL/Y +EVENTUAL/Y +EVENTUALITY/S +EVERGREEN +EVERLASTING/Y +EVERMORE +EVERY +EVERYBODY +EVERYDAY +EVERYONE/M +EVERYTHING +EVERYWHERE +EVICT/D/G/S +EVICTION/M/S +EVIDENCE/D/G/S +EVIDENT/Y +EVIL/Y/S +EVINCE/D/S +EVOKE/D/G/S +EVOLUTE/M/S +EVOLUTION/M/S +EVOLUTIONARY +EVOLVE/D/G/S +EWE/M/S +EXACERBATE/D/G/N/X/S +EXACT/P/D/G/Y/S +EXACTINGLY +EXACTION/M/S +EXACTITUDE +EXAGGERATE/D/G/N/X/S +EXALT/D/G/S +EXAM/M/S +EXAMINATION/M/S +EXAMINE/D/R/Z/G/S +EXAMPLE/M/S +EXASPERATE/D/G/N/S +EXCAVATE/D/G/N/X/S +EXCEED/D/G/S +EXCEEDINGLY +EXCEL/S +EXCELLED +EXCELLENCE/S +EXCELLENCY +EXCELLENT/Y +EXCELLING +EXCEPT/D/G/S +EXCEPTION/M/S +EXCEPTIONAL/Y +EXCERPT/D/S +EXCESS/V/S +EXCESSIVELY +EXCHANGE/D/G/S +EXCHANGEABLE +EXCHEQUER/M/S +EXCISE/D/G/N/S +EXCITABLE +EXCITATION/M/S +EXCITATORY +EXCITE/D/G/S +EXCITEDLY +EXCITEMENT +EXCITINGLY +EXCLAIM/D/R/Z/G/S +EXCLAMATION/M/S +EXCLUDE/D/G/S +EXCLUSION/S +EXCLUSIVE/P/Y +EXCLUSIVITY +EXCOMMUNICATE/D/G/N/S +EXCRETE/D/G/N/X/S +EXCURSION/M/S +EXCUSABLE +EXCUSABLY +EXCUSE/D/G/S +EXECUTABLE +EXECUTE/D/G/N/X/V/S +EXECUTIONAL +EXECUTIVE/M/S +EXECUTOR/M/S +EXEMPLAR +EXEMPLARY +EXEMPLIFY/D/R/Z/G/N/S +EXEMPT/D/G/S +EXERCISE/D/R/Z/G/S +EXERT/D/G/S +EXERTION/M/S +EXHALE/D/G/S +EXHAUST/D/G/V/S +EXHAUSTEDLY +EXHAUSTIBLE +EXHAUSTION +EXHAUSTIVELY +EXHIBIT/D/G/S +EXHIBITION/M/S +EXHIBITOR/M/S +EXHORTATION/M/S +EXILE/D/G/S +EXIST/D/G/S +EXISTENCE +EXISTENT +EXISTENTIAL/Y +EXISTENTIALISM +EXISTENTIALIST/M/S +EXIT/D/G/S +EXORBITANT/Y +EXOTIC +EXPAND/D/G/S +EXPANDABLE +EXPANDER/M/S +EXPANSE/N/X/V/S +EXPANSIONISM +EXPECT/D/G/S +EXPECTANCY +EXPECTANT/Y +EXPECTATION/M/S +EXPECTEDLY +EXPECTINGLY +EXPEDIENT/Y +EXPEDITE/D/G/S +EXPEDITION/M/S +EXPEDITIOUS/Y +EXPEL/S +EXPELLED +EXPELLING +EXPEND/D/G/S +EXPENDABLE +EXPENDITURE/M/S +EXPENSE/V/S +EXPENSIVELY +EXPERIENCE/D/G/S +EXPERIMENT/D/R/Z/G/S +EXPERIMENTAL/Y +EXPERIMENTATION/M/S +EXPERT/P/Y/S +EXPERTISE +EXPIRATION/M/S +EXPIRE/D/S +EXPLAIN/D/R/Z/G/S +EXPLAINABLE +EXPLANATION/M/S +EXPLANATORY +EXPLICIT/P/Y +EXPLODE/D/G/S +EXPLOIT/D/R/Z/G/S +EXPLOITABLE +EXPLOITATION/M/S +EXPLORATION/M/S +EXPLORATORY +EXPLORE/D/R/Z/G/S +EXPLOSION/M/S +EXPLOSIVE/Y/S +EXPONENT/M/S +EXPONENTIAL/Y/S +EXPONENTIATE/D/G/S +EXPONENTIATION/M/S +EXPORT/D/R/Z/G/S +EXPOSE/D/R/Z/G/S +EXPOSITION/M/S +EXPOSITORY +EXPOSURE/M/S +EXPOUND/D/R/G/S +EXPRESS/D/G/V/Y/S +EXPRESSIBILITY +EXPRESSIBLE +EXPRESSIBLY +EXPRESSION/M/S +EXPRESSIVELY +EXPRESSIVENESS +EXPULSION +EXPUNGE/D/G/S +EXQUISITE/P/Y +EXTANT +EXTEND/D/G/S +EXTENDIBLE +EXTENSIBILITY +EXTENSIBLE +EXTENSION/M/S +EXTENSIVE/Y +EXTENT/M/S +EXTENUATE/D/G/N +EXTERIOR/M/S +EXTERMINATE/D/G/N/S +EXTERNAL/Y +EXTINCT +EXTINCTION +EXTINGUISH/D/R/G/S +EXTOL +EXTRA/S +EXTRACT/D/G/S +EXTRACTION/M/S +EXTRACTOR/M/S +EXTRACURRICULAR +EXTRANEOUS/P/Y +EXTRAORDINARILY +EXTRAORDINARY/P +EXTRAPOLATE/D/G/N/X/S +EXTRAVAGANCE +EXTRAVAGANT/Y +EXTREMAL +EXTREME/Y/S +EXTREMIST/M/S +EXTREMITY/M/S +EXTRINSIC +EXUBERANCE +EXULT +EXULTATION +EYE/D/R/Z/G/S +EYEBROW/M/S +EYEGLASS/S +EYEING +EYELID/M/S +EYEPIECE/M/S +EYESIGHT +EYEWITNESS/M/S +FABLE/D/S +FABRIC/M/S +FABRICATE/D/G/N/S +FABULOUS/Y +FACADE/D/S +FACE/D/G/J/S +FACET/D/S +FACIAL +FACILE/Y +FACILITATE/D/G/S +FACILITY/M/S +FACSIMILE/M/S +FACT/M/S +FACTION/M/S +FACTO +FACTOR/D/G/S +FACTORIAL +FACTORIZATION/M/S +FACTORY/M/S +FACTUAL/Y +FACULTY/M/S +FADE/D/R/Z/G/S +FAG/S +FAHLMAN/M +FAHRENHEIT +FAIL/D/G/J/S +FAILURE/M/S +FAIN +FAINT/P/D/T/R/G/Y/S +FAIR/P/T/R/G/Y/S +FAIRY/M/S +FAIRYLAND +FAITH +FAITHFUL/P/Y +FAITHLESS/P/Y +FAITHS +FAKE/D/R/G/S +FALCON/R/S +FALL/G/N/S +FALLACIOUS +FALLACY/M/S +FALLIBILITY +FALLIBLE +FALSE/P/Y +FALSEHOOD/M/S +FALSIFY/D/G/N/S +FALSITY +FALTER/D/S +FAME/D/S +FAMILIAR/P/Y +FAMILIARITY/S +FAMILIARIZATION +FAMILIARIZE/D/G/S +FAMILY/M/S +FAMINE/M/S +FAMISH +FAMOUS/Y +FAN/M/S +FANATIC/M/S +FANCIER/M/S +FANCIFUL/Y +FANCILY +FANCY/P/D/T/G/S +FANG/M/S +FANNED +FANNING +FANTASTIC +FANTASY/M/S +FAR +FARADAY/M +FARAWAY +FARCE/M/S +FARE/D/G/S +FAREWELL/S +FARM/D/R/Z/G/S +FARMHOUSE/M/S +FARMINGTON +FARMYARD/M/S +FARTHER +FARTHEST +FARTHING +FASCINATE/D/G/N/S +FASHION/D/G/S +FASHIONABLE +FASHIONABLY +FAST/P/D/T/R/G/X/S +FASTEN/D/R/Z/G/J/S +FAT/P/S +FATAL/Y/S +FATALITY/M/S +FATE/D/S +FATHER/D/M/Y/S +FATHERLAND +FATHOM/D/G/S +FATIGUE/D/G/S +FATTEN/D/R/Z/G/S +FATTER +FATTEST +FAULT/D/G/S +FAULTLESS/Y +FAULTY +FAVOR/D/R/G/S +FAVORABLE +FAVORABLY +FAVORITE/S +FAWN/D/G/S +FEAR/D/G/S +FEARFUL/Y +FEARLESS/P/Y +FEASIBILITY +FEASIBLE +FEAST/D/G/S +FEAT/M/S +FEATHER/D/R/Z/G/S +FEATHERY +FEATURE/D/G/S +FEBRUARY/M/S +FED +FEDERAL/Y/S +FEDERATION +FEE/S +FEEBLE/P/T/R +FEEBLY +FEED/G/J/R/S/Z +FEEDBACK +FEEL/R/Z/G/J/S +FEELINGLY +FEET +FEIGN/D/G +FELICITY/S +FELINE +FELL/D/G +FELLOW/M/S +FELLOWSHIP/M/S +FELT/S +FEMALE/M/S +FEMININE +FEMININITY +FEMUR/M/S +FEN/S +FENCE/D/R/Z/G/S +FERMENT/D/G/S +FERMENTATION/M/S +FERN/M/S +FEROCIOUS/P/Y +FEROCITY +FERRITE +FERRY/D/S +FERTILE/Y +FERTILITY +FERTILIZATION +FERTILIZE/D/R/Z/G/S +FERVENT/Y +FERVOR/M/S +FESTIVAL/M/S +FESTIVE/Y +FESTIVITY/S +FETCH/D/G/S +FETCHINGLY +FETTER/D/S +FEUD/M/S +FEUDAL +FEUDALISM +FEVER/D/S +FEVERISH/Y +FEW/P/T/R +FIBER/M/S +FIBROSITY/S +FIBROUS/Y +FICKLE/P +FICTION/M/S +FICTIONAL/Y +FICTITIOUS/Y +FIDDLE/R/G/S +FIDELITY +FIELD/D/R/Z/G/S +FIEND +FIERCE/P/T/R/Y +FIERY +FIFE +FIFO +FIFTEEN/H/S +FIFTH +FIFTY/H/S +FIG/M/S +FIGHT/R/Z/G/S +FIGURATIVE/Y +FIGURE/D/G/J/S +FILAMENT/M/S +FILE/D/R/M/G/J/S +FILENAME/M/S +FILIAL +FILL/D/R/Z/G/J/S +FILLABLE +FILM/D/G/S +FILTER/D/M/G/S +FILTH +FILTHY/P/T/R +FIN/M/S +FINAL/Y/S +FINALITY +FINALIZATION +FINALIZE/D/G/S +FINANCE/D/G/S +FINANCIAL/Y +FINANCIER/M/S +FIND/R/Z/G/J/S +FINE/P/D/T/R/G/Y/S +FINGER/D/G/J/S +FINISH/D/R/Z/G/S +FINITE/P/Y +FIR +FIRE/D/R/Z/G/J/S +FIREARM/M/S +FIREFLY/M/S +FIRELIGHT +FIREMAN +FIREPLACE/M/S +FIRESIDE +FIREWOOD +FIREWORKS +FIRM/P/D/T/R/G/Y/S +FIRMAMENT +FIRMWARE +FIRST/Y/S +FIRSTHAND +FISCAL/Y +FISH/D/R/Z/G/S +FISHERMAN +FISHERY +FISSURE/D +FIST/D/S +FIT/P/Y/S +FITFUL/Y +FITTED +FITTER/M/S +FITTING/Y/S +FIVE/S +FIX/D/R/Z/G/J/S +FIXATE/D/G/N/X/S +FIXEDLY +FIXEDNESS +FIXNUM +FIXTURE/M/S +FLAG/M/S +FLAGGED +FLAGGING +FLAGRANT/Y +FLAKE/D/G/S +FLAME/D/R/Z/G/S +FLAMINGO +FLAMMABLE +FLANK/D/R/G/S +FLANNEL/M/S +FLAP/M/S +FLARE/D/G/S +FLASH/D/R/Z/G/S +FLASHLIGHT/M/S +FLASK +FLAT/P/Y/S +FLATTEN/D/G +FLATTER/D/R/G +FLATTERY +FLATTEST +FLAUNT/D/G/S +FLAVOR/D/G/J/S +FLAW/D/S +FLAWLESS/Y +FLAX/N +FLEA/M/S +FLED +FLEDGED +FLEDGLING/M/S +FLEE/S +FLEECE/M/S +FLEECY +FLEEING +FLEET/P/T/G/Y/S +FLESH/D/G/Y/S +FLESHY +FLEW +FLEXIBILITY/S +FLEXIBLE +FLEXIBLY +FLICK/D/R/G/S +FLICKERING +FLIGHT/M/S +FLINCH/D/G/S +FLING/M/S +FLINT +FLIP/S +FLIRT/D/G/S +FLIT +FLOAT/D/R/G/S +FLOCK/D/G/S +FLOOD/D/G/S +FLOOR/D/G/J/S +FLOP/M/S +FLOPPILY +FLOPPY +FLORA +FLORIDA +FLORIN +FLOSS/D/G/S +FLOUNDER/D/G/S +FLOUR/D +FLOURISH/D/G/S +FLOW/D/Z/G/S +FLOWCHART/G/S +FLOWER/D/G/S +FLOWERY/P +FLOWN +FLUCTUATE/G/N/X/S +FLUENT/Y +FLUFFY/T/R +FLUID/Y/S +FLUIDITY +FLUNG +FLURRY/D +FLUSH/D/G/S +FLUTE/D/G +FLUTTER/D/G/S +FLY/R/Z/G/S +FLYABLE +FLYER/M/S +FOAM/D/G/S +FOCAL/Y +FOCI +FOCUS/D/G/S +FODDER +FOE/M/S +FOG/M/S +FOGGED +FOGGILY +FOGGING +FOGGY/T/R +FOIL/D/G/S +FOLD/D/R/Z/G/S +FOLIAGE +FOLK/M/S +FOLKLORE +FOLLOW/D/R/Z/G/J/S +FOLLY/S +FOND/P/R/Y +FONDLE/D/G/S +FONT/M/S +FOOD/M/S +FOODSTUFF/M/S +FOOL/D/G/S +FOOLISH/P/Y +FOOLPROOF +FOOT/D/R/Z/G +FOOTBALL/M/S +FOOTHOLD +FOOTMAN +FOOTNOTE/M/S +FOOTPRINT/M/S +FOOTSTEP/S +FOR/H +FORAGE/D/G/S +FORAY/M/S +FORBADE +FORBEAR/M/S +FORBEARANCE +FORBES +FORBID/S +FORBIDDEN +FORBIDDING +FORCE/D/R/M/G/S +FORCEFUL/P/Y +FORCIBLE +FORCIBLY +FORD/S +FORE/T +FOREARM/M/S +FOREBODING +FORECAST/D/R/Z/G/S +FORECASTLE +FOREFATHER/M/S +FOREFINGER/M/S +FOREGO/G +FOREGOES +FOREGONE +FOREGROUND +FOREHEAD/M/S +FOREIGN/R/Z/S +FOREMAN +FOREMOST +FORENOON +FORESEE/S +FORESEEABLE +FORESEEN +FORESIGHT/D +FOREST/D/R/Z/S +FORESTALL/D/G/S +FORESTALLMENT +FORETELL/G/S +FORETOLD +FOREVER +FOREWARN/D/G/J/S +FORFEIT/D +FORGAVE +FORGE/D/R/G/S +FORGERY/M/S +FORGET/S +FORGETFUL/P +FORGETTABLE +FORGETTABLY +FORGETTING +FORGIVABLE +FORGIVABLY +FORGIVE/P/G/S +FORGIVEN +FORGIVINGLY +FORGOT +FORGOTTEN +FORK/D/G/S +FORLORN/Y +FORM/D/R/G/S +FORMAL/Y +FORMALISM/M/S +FORMALITY/S +FORMALIZATION/M/S +FORMALIZE/D/G/S +FORMANT/S +FORMAT/V/S +FORMATION/M/S +FORMATIVELY +FORMATTED +FORMATTER/M/S +FORMATTING +FORMERLY +FORMIDABLE +FORMULA/M/S +FORMULAE +FORMULATE/D/G/N/X/S +FORMULATOR/M/S +FORNICATION +FORSAKE/G/S +FORSAKEN +FORT/M/S +FORTE +FORTHCOMING +FORTHWITH +FORTIFY/D/G/N/X/S +FORTITUDE +FORTNIGHT/Y +FORTRAN +FORTRESS/M/S +FORTUITOUS/Y +FORTUNATE/Y +FORTUNE/M/S +FORTY/R/H/S +FORUM/M/S +FORWARD/P/D/R/G/S +FOSSIL +FOSTER/D/G/S +FOUGHT +FOUL/P/D/T/G/Y/S +FOUND/D/R/Z/G/S +FOUNDATION/M/S +FOUNDERED +FOUNDRY/M/S +FOUNT/M/S +FOUNTAIN/M/S +FOUR/H/S +FOURIER +FOURSCORE +FOURTEEN/H/S +FOWL/R/S +FOX/M/S +FRACTION/M/S +FRACTIONAL/Y +FRACTURE/D/G/S +FRAGILE +FRAGMENT/D/G/S +FRAGMENTARY +FRAGRANCE/M/S +FRAGRANT/Y +FRAIL/T +FRAILTY +FRAME/D/R/G/S +FRAMEWORK/M/S +FRANC/S +FRANCE/M/S +FRANCHISE/M/S +FRANCISCO +FRANK/P/D/T/R/G/Y/S +FRANTIC +FRANTICALLY +FRATERNAL/Y +FRATERNITY/M/S +FRAUD/M/S +FRAUGHT +FRAY/D/G/S +FREAK/M/S +FRECKLE/D/S +FREE/P/D/T/R/Y/S +FREEDOM/M/S +FREEING/S +FREEMAN +FREEZE/R/Z/G/S +FREIGHT/D/R/Z/G/S +FRENCH +FRENZY/D +FREQUENCY/S +FREQUENT/D/R/Z/G/Y/S +FRESH/P/T/R/X/Y +FRESHEN/D/R/Z/G/S +FRESHMAN +FRESHMEN +FRET +FRETFUL/P/Y +FRIAR/M/S +FRICATIVE/S +FRICTION/M/S +FRICTIONLESS +FRIDAY/M/S +FRIEND/M/S +FRIENDLESS +FRIENDLY/P/T/R +FRIENDSHIP/M/S +FRIEZE/M/S +FRIGATE/M/S +FRIGHT/X +FRIGHTEN/D/G/S +FRIGHTENINGLY +FRIGHTFUL/P/Y +FRILL/M/S +FRINGE/D +FRISK/D/G/S +FRIVOLOUS/Y +FROCK/M/S +FROG/M/S +FROLIC/S +FROM +FRONT/D/G/S +FRONTAL +FRONTIER/M/S +FROST/D/G/S +FROSTY +FROTH/G +FROWN/D/G/S +FROZE +FROZEN/Y +FRUGAL/Y +FRUIT/M/S +FRUITFUL/P/Y +FRUITION +FRUITLESS/Y +FRUSTRATE/D/G/N/X/S +FRY/D/S +FUDGE +FUEL/D/G/S +FUGITIVE/M/S +FUGUE +FULFILL/D/G/S +FULFILLMENT/S +FULL/P/T/R +FULLY +FUMBLE/D/G +FUME/D/G/S +FUN +FUNCTION/D/M/G/S +FUNCTIONAL/Y/S +FUNCTIONALITY/S +FUNCTOR/M/S +FUND/D/R/Z/G/S +FUNDAMENTAL/Y/S +FUNERAL/M/S +FUNGUS +FUNNEL/D/G/S +FUNNILY +FUNNY/P/T/R +FUR/M/S +FURIOUS/R/Y +FURNACE/M/S +FURNISH/D/G/J/S +FURNITURE +FURROW/D/S +FURTHER/D/G/S +FURTHERMORE +FURTIVE/P/Y +FURY/M/S +FUSE/D/G/N/S +FUSS/G +FUTILE +FUTILITY +FUTURE/M/S +FUZZY/P/R +GABARDINE +GABLE/D/R/S +GAD +GADGET/M/S +GAG/G/S +GAGGED +GAGGING +GAIETY/S +GAILY +GAIN/D/R/Z/G/S +GAIT/D/R/Z +GALAXY/M/S +GALE +GALL/D/G/S +GALLANT/Y/S +GALLANTRY +GALLERY/D/S +GALLEY/M/S +GALLON/M/S +GALLOP/D/R/G/S +GALLOWS +GAMBLE/D/R/Z/G/S +GAME/P/D/G/Y/S +GAMMA +GANG/M/S +GANGRENE +GANGSTER/M/S +GAP/M/S +GAPE/D/G/S +GARAGE/D/S +GARB/D +GARBAGE/M/S +GARDEN/D/R/Z/G/S +GARGLE/D/G/S +GARLAND/D +GARLIC +GARMENT/M/S +GARNER/D +GARNET +GARNISH +GARRISON/D +GARTER/M/S +GARY/M +GAS/M/S +GASEOUS/Y +GASH/M/S +GASOLINE +GASP/D/G/S +GASSED +GASSER +GASSING/S +GASTRIC +GASTROINTESTINAL +GATE/D/G/S +GATEWAY/M/S +GATHER/D/R/Z/G/J/S +GAUDY/P +GAUGE/D/S +GAUNT/P +GAUZE +GAVE +GAY/P/T/R/Y +GAZE/D/R/Z/G/S +GAZORCH/D/G +GCD +GEAR/D/G/S +GEESE +GEL/M/S +GELATIN +GELLED +GELLING +GEM/M/S +GENDER/M/S +GENE/M/S +GENERAL/Y/S +GENERALIST/M/S +GENERALITY/S +GENERALIZATION/M/S +GENERALIZE/D/R/Z/G/S +GENERATE/D/G/N/S/V/X +GENERATOR/M/S +GENERIC +GENERICALLY +GENEROSITY/M/S +GENEROUS/P/Y +GENETIC/S +GENETICALLY +GENEVA +GENIAL/Y +GENIUS/M/S +GENRE/M/S +GENTEEL +GENTLE/P/T/R +GENTLEMAN/Y +GENTLEWOMAN +GENTLY +GENTRY +GENUINE/P/Y +GENUS +GEOGRAPHIC +GEOGRAPHICAL/Y +GEOGRAPHY +GEOLOGICAL +GEOLOGIST/M/S +GEOMETRIC +GEOMETRICAL +GEOMETRY/S +GEORGETOWN +GERANIUM +GERM/M/S +GERMAN/M/S +GERMANE +GERMANY +GERMINATE/D/G/N/S +GESTALT +GESTURE/D/G/S +GET/S +GETTER/M/S +GETTING +GHASTLY +GHOST/D/Y/S +GIANT/M/S +GIBBERISH +GIDDY/P +GIFT/D/S +GIG +GIGANTIC +GIGGLE/D/G/S +GILD/D/G/S +GILL/M/S +GILT +GIMMICK/M/S +GIN/M/S +GINGER/Y +GINGERBREAD +GINGHAM/S +GIPSY/M/S +GIRAFFE/M/S +GIRD +GIRDER/M/S +GIRDLE +GIRL/M/S +GIRT +GIRTH +GIVE/R/Z/G/S +GIVEN +GLACIAL +GLACIER/M/S +GLAD/P/Y +GLADDER +GLADDEST +GLADE +GLAMOROUS +GLAMOUR +GLANCE/D/G/S +GLAND/M/S +GLARE/D/G/S +GLARINGLY +GLASS/D/S +GLASSY +GLAZE/D/R/G/S +GLEAM/D/G/S +GLEAN/D/R/G/J/S +GLEE/S +GLEEFUL/Y +GLEN/M/S +GLIDE/D/R/Z/S +GLIMMER/D/G/S +GLIMPSE/D/S +GLINT/D/G/S +GLISTEN/D/G/S +GLITCH/S +GLITTER/D/G/S +GLOBAL/Y +GLOBE/M/S +GLOBULAR +GLOBULARITY +GLOOM +GLOOMILY +GLOOMY +GLORIFY/D/N/S +GLORIOUS/Y +GLORY/G/S +GLOSS/D/G/S +GLOSSARY/M/S +GLOSSY +GLOTTAL +GLOVE/D/R/Z/G/S +GLOW/D/R/Z/G/S +GLOWINGLY +GLUE/D/G/S +GLYPH/S +GNAT/M/S +GNAW/D/G/S +GNU +GO/G/J +GOAD/D +GOAL/M/S +GOAT/M/S +GOATEE/M/S +GOBBLE/D/R/Z/S +GOBLET/M/S +GOBLIN/M/S +GOD/M/Y/S +GODDESS/M/S +GODLIKE +GODMOTHER/M/S +GOES +GOLD/G/N/S +GOLDENLY +GOLDENNESS +GOLDSMITH +GOLF/R/Z/G +GONE/R +GONG/M/S +GOOD/P/Y/S +GOODY/M/S +GOOSE +GORDON/M +GORE +GORGE/G/S +GORGEOUS/Y +GORILLA/M/S +GOSH +GOSLING/M +GOSPEL/Z/S +GOSSIP/D/G/S +GOT +GOTHIC +GOTO +GOTTEN +GOUGE/D/G/S +GOURD +GOVERN/D/G/S +GOVERNESS +GOVERNMENT/M/S +GOVERNMENTAL/Y +GOVERNOR/M/S +GOWN/D/S +GRAB/S +GRABBED +GRABBER/M/S +GRABBING/S +GRACE/D/G/S +GRACEFUL/P/Y +GRACIOUS/P/Y +GRAD +GRADATION/M/S +GRADE/D/R/Z/G/J/S +GRADIENT/M/S +GRADUAL/Y +GRADUATE/D/G/N/X/S +GRAFT/D/R/G/S +GRAHAM/M/S +GRAIN/D/G/S +GRAM/S +GRAMMAR/M/S +GRAMMATICAL/Y +GRANARY/M/S +GRAND/P/T/R/Y/S +GRANDEUR +GRANDFATHER/M/S +GRANDIOSE +GRANDMA +GRANDMOTHER/M/S +GRANDPA +GRANDPARENT/S/M +GRANDSON/M/S +GRANGE +GRANITE +GRANNY +GRANT/D/R/G/S +GRANULARITY +GRANULATE/D/G/S +GRAPE/M/S +GRAPH/D/M/G +GRAPHIC/S +GRAPHICAL/Y +GRAPHITE +GRAPHS +GRAPPLE/D/G +GRASP/D/G/S +GRASPABLE +GRASPING/Y +GRASS/D/Z/S +GRASSY/T/R +GRATE/D/R/G/J/S +GRATEFUL/P/Y +GRATIFY/D/G/N +GRATITUDE +GRATUITOUS/P/Y +GRATUITY/M/S +GRAVE/P/T/R/Y/S +GRAVEL/Y +GRAVITATION +GRAVITATIONAL +GRAVITY +GRAVY +GRAY/P/D/T/R/G +GRAZE/D/R/G +GREASE/D/S +GREASY +GREAT/P/T/R/Y +GREED +GREEDILY +GREEDY/P +GREEK/M/S +GREEN/P/T/R/G/Y/S +GREENHOUSE/M/S +GREENISH +GREET/D/R/G/J/S +GRENADE/M/S +GREW +GREY/T/G +GRID/M/S +GRIEF/M/S +GRIEVANCE/M/S +GRIEVE/D/R/Z/G/S +GRIEVINGLY +GRIEVOUS/Y +GRIFFIN +GRILL/D/G/S +GRIM/P/D/Y +GRIN/S +GRIND/R/Z/G/J/S +GRINDSTONE/M/S +GRIP/D/G/S +GRIPE/D/G/S +GRIPPED +GRIPPING/Y +GRIT/M/S +GRIZZLY +GROAN/D/R/Z/G/S +GROCER/M/S +GROCERY/S +GROOM/D/G/S +GROOVE/D/S +GROPE/D/G/S +GROSS/P/D/T/R/G/Y/S +GROTESQUE/Y/S +GROTTO/M/S +GROUND/D/R/Z/G/S +GROUNDWORK +GROUP/D/G/J/S +GROUSE +GROVE/R/Z/S +GROVEL/D/G/S +GROW/R/Z/G/H/S +GROWL/D/G/S +GROWN +GROWNUP/M/S +GROWTHS +GRUB/M/S +GRUDGE/M/S +GRUESOME +GRUFF/Y +GRUMBLE/D/G/S +GRUNT/D/G/S +GUARANTEE/D/R/Z/S +GUARANTEEING +GUARANTY +GUARD/D/G/S +GUARDEDLY +GUARDIAN/M/S +GUARDIANSHIP +GUERRILLA/M/S +GUESS/D/G/S +GUEST/M/S +GUIDANCE +GUIDE/D/G/S +GUIDEBOOK/M/S +GUIDELINE/M/S +GUILD/R +GUILE +GUILT +GUILTILY +GUILTLESS/Y +GUILTY/P/T/R +GUINEA +GUISE/M/S +GUITAR/M/S +GULCH/M/S +GULF/M/S +GULL/D/G/S +GULLY/M/S +GULP/D/S +GUM/M/S +GUN/M/S +GUNFIRE +GUNNED +GUNNER/M/S +GUNNING +GUNPOWDER +GURGLE +GUSH/D/R/G/S +GUST/M/S +GUT/S +GUTTER/D/S +GUY/D/G/S +GUYER/S +GYMNASIUM/M/S +GYMNAST/M/S +GYMNASTIC/S +GYPSY/M/S +GYROSCOPE/M/S +HA +HABIT/M/S +HABITAT/M/S +HABITATION/M/S +HABITUAL/P/Y +HACK/D/R/Z/G/S +HAD +HADN'T +HAG +HAGGARD/Y +HAIL/D/G/S +HAIR/M/S +HAIRCUT/M/S +HAIRDRYER/M/S +HAIRLESS +HAIRY/P/R +HALE/R +HALF +HALFTONE +HALFWAY +HALL/M/S +HALLMARK/M/S +HALLOW/D +HALLWAY/M/S +HALT/D/R/Z/G/S +HALTINGLY +HALVE/D/Z/G/S +HAM/M/S +HAMBURGER/M/S +HAMLET/M/S +HAMMER/D/G/S +HAMMOCK/M/S +HAMPER/D/S +HAND/D/G/S +HANDBAG/M/S +HANDBOOK/M/S +HANDCUFF/D/G/S +HANDFUL/S +HANDICAP/M/S +HANDICAPPED +HANDILY +HANDIWORK +HANDKERCHIEF/M/S +HANDLE/D/R/Z/G/S +HANDSOME/P/T/R/Y +HANDWRITING +HANDWRITTEN +HANDY/P/T/R +HANG/D/R/Z/G/S +HANGAR/M/S +HANGOVER/M/S +HAP/Y +HAPHAZARD/P/Y +HAPLESS/P/Y +HAPPEN/D/G/J/S +HAPPILY +HAPPY/P/T/R +HARASS/D/G/S +HARASSMENT +HARBOR/D/G/S +HARD/P/T/R/N/Y +HARDCOPY +HARDSHIP/M/S +HARDWARE +HARDWIRED +HARDY/P +HARE/M/S +HARK/N +HARLOT/M/S +HARM/D/G/S +HARMFUL/P/Y +HARMLESS/P/Y +HARMONIOUS/P/Y +HARMONIZE +HARMONY/S +HARNESS/D/G +HARP/R/Z/G +HARROW/D/G/S +HARRY/D/R +HARSH/P/R/Y +HART +HARVARD +HARVEST/D/R/G/S +HAS +HASH/D/R/G/S +HASN'T +HASTE/J +HASTEN/D/G/S +HASTILY +HASTY/P +HAT/M/S +HATCH/D/G +HATCHET/M/S +HATE/D/R/G/S +HATEFUL/P/Y +HATRED +HAUGHTILY +HAUGHTY/P +HAUL/D/R/G/S +HAUNCH/M/S +HAUNT/D/R/G/S +HAVE/G/S +HAVEN'T +HAVEN/M/S +HAVOC +HAWAII +HAWK/D/R/Z/S +HAY/G/S +HAZARD/M/S +HAZARDOUS +HAZE/M/S +HAZEL +HAZY/P +HE'D +HE'LL +HE/D/M/V +HEAD/D/R/Z/G/S +HEADACHE/M/S +HEADGEAR +HEADING/M/S +HEADLAND/M/S +HEADLINE/D/G/S +HEADLONG +HEADQUARTERS +HEADWAY +HEAL/D/R/Z/G/H/S +HEALTHFUL/P/Y +HEALTHILY +HEALTHY/P/T/R +HEALY/M +HEAP/D/G/S +HEAR/R/Z/G/H/J/S +HEARD +HEARKEN +HEARSAY +HEART/N/S +HEARTILY +HEARTLESS +HEARTY/P/T +HEAT/D/R/Z/G/S +HEATABLE +HEATEDLY +HEATH/R/N +HEAVE/D/R/Z/G/S +HEAVEN/Y/S +HEAVILY +HEAVY/P/T/R +HEBREW +HEDGE/D/S +HEDGEHOG/M/S +HEED/D/S +HEEDLESS/P/Y +HEEL/D/Z/G/S +HEIDELBERG +HEIFER +HEIGHT/X/S +HEIGHTEN/D/G/S +HEINOUS/Y +HEIR/M/S +HEIRESS/M/S +HELD +HELL/M/S +HELLO +HELM +HELMET/M/S +HELP/D/R/Z/G/S +HELPFUL/P/Y +HELPLESS/P/Y +HELVETICA +HEM/M/S +HEMISPHERE/M/S +HEMLOCK/M/S +HEMOSTAT/S +HEMP/N +HEN/M/S +HENCE +HENCEFORTH +HENCHMAN +HENCHMEN +HER/S +HERALD/D/G/S +HERB/M/S +HERBERT/M +HERBIVORE +HERBIVOROUS +HERD/D/R/G/S +HERE/M/S +HEREABOUT/S +HEREAFTER +HEREBY +HEREDITARY +HEREDITY +HEREIN +HEREINAFTER +HERESY +HERETIC/M/S +HERETOFORE +HEREWITH +HERITAGE/S +HERMIT/M/S +HERO +HEROES +HEROIC/S +HEROICALLY +HEROIN +HEROINE/M/S +HEROISM +HERON/M/S +HERRING/M/S +HERSELF +HESITANT/Y +HESITATE/D/G/N/X/S +HESITATINGLY +HETEROGENEITY +HETEROGENEOUS/P/Y +HEURISTIC/M/S +HEURISTICALLY +HEW/D/R/S +HEX +HEXAGONAL/Y +HEY +HIATUS +HICKORY +HID +HIDDEN +HIDE/G/S +HIDEOUS/P/Y +HIDEOUT/M/S +HIERARCHICAL/Y +HIERARCHY/M/S +HIGH/T/R/Y +HIGHLAND/R/S +HIGHLIGHT/D/G/S +HIGHNESS/M/S +HIGHWAY/M/S +HIKE/D/R/G/S +HILARIOUS/Y +HILL/M/S +HILLOCK +HILLSIDE +HILLTOP/M/S +HILT/M/S +HIM +HIMSELF +HIND/R/Z +HINDERED +HINDERING +HINDRANCE/S +HINDSIGHT +HINGE/D/S +HINT/D/G/S +HIP/M/S +HIRE/D/R/Z/G/J/S +HIS +HISS/D/G/S +HISTOGRAM/M/S +HISTORIAN/M/S +HISTORIC +HISTORICAL/Y +HISTORY/M/S +HIT/M/S +HITCH/D/G +HITCHHIKE/D/R/Z/G/S +HITHER +HITHERTO +HITTER/M/S +HITTING +HOAR +HOARD/R/G +HOARSE/P/Y +HOARY/P +HOBBLE/D/G/S +HOBBY/M/S +HOBBYIST/M/S +HOCKEY +HOE/M/S +HOG/M/S +HOIST/D/G/S +HOLD/R/Z/G/N/J/S +HOLE/D/S +HOLIDAY/M/S +HOLISTIC +HOLLAND +HOLLOW/P/D/G/Y/S +HOLLY +HOLOCAUST +HOLOGRAM/M/S +HOLY/P/S +HOMAGE +HOME/D/R/Z/G/Y/S +HOMELESS +HOMEMADE +HOMEMAKER/M/S +HOMEOMORPHIC +HOMEOMORPHISM/M/S +HOMESICK/P +HOMESPUN +HOMESTEAD/R/Z/S +HOMEWARD/S +HOMEWORK +HOMOGENEITY/M/S +HOMOGENEOUS/P/Y +HOMOMORPHIC +HOMOMORPHISM/M/S +HONE/D/T/R/G/S +HONESTLY +HONESTY +HONEY +HONEYCOMB/D +HONEYMOON/D/R/Z/G/S +HONEYSUCKLE +HONG +HONOLULU +HONOR/D/R/G/S +HONORABLE/P +HONORABLY +HONORARY/S +HOOD/D/S +HOODWINK/D/G/S +HOOF/M/S +HOOK/D/R/Z/G/S +HOOP/R/S +HOOT/D/R/G/S +HOOVER/M +HOP/S +HOPE/D/G/S +HOPEFUL/P/Y/S +HOPELESS/P/Y +HOPPER/M/S +HORDE/M/S +HORIZON/M/S +HORIZONTAL/Y +HORMONE/M/S +HORN/D/S +HORNET/M/S +HORRENDOUS/Y +HORRIBLE/P +HORRIBLY +HORRID/Y +HORRIFY/D/G/S +HORROR/M/S +HORSE/Y/S +HORSEBACK +HORSEMAN +HORSEPOWER +HORSESHOE/R +HOSE/M/S +HOSPITABLE +HOSPITABLY +HOSPITAL/M/S +HOSPITALITY +HOSPITALIZE/D/G/S +HOST/D/G/S +HOSTAGE/M/S +HOSTESS/M/S +HOSTILE/Y +HOSTILITY/S +HOT/P/Y +HOTEL/M/S +HOTTER +HOTTEST +HOUND/D/G/S +HOUR/Y/S +HOUSE/D/G/S +HOUSEFLY/M/S +HOUSEHOLD/R/Z/S +HOUSEKEEPER/M/S +HOUSEKEEPING +HOUSETOP/M/S +HOUSEWIFE/Y +HOUSEWORK +HOUSTON +HOVEL/M/S +HOVER/D/G/S +HOW +HOWARD +HOWEVER +HOWL/D/R/G/S +HUB/M/S +HUBRIS +HUDDLE/D/G +HUDSON +HUE/M/S +HUG +HUGE/P/Y +HUH +HULL/M/S +HUM/S +HUMAN/P/Y/S +HUMANE/P/Y +HUMANITY/M/S +HUMBLE/P/D/T/R/G +HUMBLY +HUMID/Y +HUMIDIFY/D/R/Z/G/N/S +HUMIDITY +HUMILIATE/D/G/N/X/S +HUMILITY +HUMMED +HUMMING +HUMOR/D/R/Z/G/S +HUMOROUS/P/Y +HUMP/D +HUNCH/D/S +HUNDRED/H/S +HUNG/R/Z +HUNGER/D/G +HUNGRILY +HUNGRY/T/R +HUNK/M/S +HUNT/D/R/Z/G/S +HUNTSMAN +HURL/D/R/Z/G +HURRAH +HURRICANE/M/S +HURRIEDLY +HURRY/D/G/S +HURT/G/S +HUSBAND/M/S +HUSBANDRY +HUSH/D/G/S +HUSK/D/R/G/S +HUSKY/P +HUSTLE/D/R/G/S +HUT/M/S +HYACINTH +HYATT +HYBRID +HYDRAULIC +HYDRODYNAMIC/S +HYDROGEN/M/S +HYGIENE +HYMN/M/S +HYPER +HYPERBOLIC +HYPERCUBE/S +HYPERMEDIA +HYPERTEXT +HYPERTEXTUAL +HYPHEN/M/S +HYPOCRISY/S +HYPOCRITE/M/S +HYPODERMIC/S +HYPOTHESES +HYPOTHESIS +HYPOTHESIZE/D/R/G/S +HYPOTHETICAL/Y +HYSTERESIS +HYSTERICAL/Y +I'D +I'LL +I'M +I'VE +IBM +ICE/D/G/J/S +ICEBERG/M/S +ICON/S +ICONIC +ICONOCLASTIC +ICY/P +IDEA/M/S +IDEAL/Y/S +IDEALISM +IDEALISTIC +IDEALIZATION/M/S +IDEALIZE/D/G/S +IDENTICAL/Y +IDENTIFIABLE +IDENTIFIABLY +IDENTIFY/D/R/Z/G/N/X/S +IDENTITY/M/S +IDEOLOGICAL/Y +IDEOLOGY/S +IDIOM/S +IDIOMATIC +IDIOSYNCRASY/M/S +IDIOSYNCRATIC +IDIOT/M/S +IDIOTIC +IDLE/P/D/T/R/G/S +IDLERS +IDLY +IDOL/M/S +IDOLATRY +IEEE +IF +IGNITION +IGNOBLE +IGNORANCE +IGNORANT/Y +IGNORE/D/G/S +III +ILL/S +ILLEGAL/Y +ILLEGALITY/S +ILLICIT/Y +ILLINOIS +ILLITERATE +ILLNESS/M/S +ILLOGICAL/Y +ILLUMINATE/D/G/N/X/S +ILLUSION/M/S +ILLUSIVE/Y +ILLUSTRATE/D/G/N/X/V/S +ILLUSTRATIVELY +ILLUSTRATOR/M/S +ILLUSTRIOUS/P +ILLY +IMAGE/G/S +IMAGINABLE +IMAGINABLY +IMAGINARY +IMAGINATION/M/S +IMAGINATIVE/Y +IMAGINE/D/G/J/S +IMBALANCE/S +IMITATE/D/G/N/X/V/S +IMMACULATE/Y +IMMATERIAL/Y +IMMATURE +IMMATURITY +IMMEDIACY/S +IMMEDIATE/Y +IMMEMORIAL +IMMENSE/Y +IMMERSE/D/N/S +IMMIGRANT/M/S +IMMIGRATE/D/G/N/S +IMMINENT/Y +IMMORTAL/Y +IMMORTALITY +IMMOVABILITY +IMMOVABLE +IMMOVABLY +IMMUNE +IMMUNITY/M/S +IMMUTABLE +IMP +IMPACT/D/G/S +IMPACTION +IMPACTOR/M/S +IMPAIR/D/G/S +IMPART/D/S +IMPARTIAL/Y +IMPASSE/V +IMPATIENCE +IMPATIENT/Y +IMPEACH +IMPEDANCE/M/S +IMPEDE/D/G/S +IMPEDIMENT/M/S +IMPEL +IMPENDING +IMPENETRABILITY +IMPENETRABLE +IMPENETRABLY +IMPERATIVE/Y/S +IMPERFECT/Y +IMPERFECTION/M/S +IMPERIAL +IMPERIALISM +IMPERIALIST/M/S +IMPERIL/D +IMPERIOUS/Y +IMPERMANENCE +IMPERMANENT +IMPERMISSIBLE +IMPERSONAL/Y +IMPERSONATE/D/G/N/X/S +IMPERTINENT/Y +IMPERVIOUS/Y +IMPETUOUS/Y +IMPETUS +IMPINGE/D/G/S +IMPIOUS +IMPLANT/D/G/S +IMPLAUSIBLE +IMPLEMENT/D/G/S +IMPLEMENTABLE +IMPLEMENTATION/M/S +IMPLEMENTOR/M/S +IMPLICANT/M/S +IMPLICATE/D/G/N/X/S +IMPLICIT/P/Y +IMPLORE/D/G +IMPLY/D/G/N/X/S +IMPORT/D/R/Z/G/S +IMPORTANCE +IMPORTANT/Y +IMPORTATION +IMPOSE/D/G/S +IMPOSITION/M/S +IMPOSSIBILITY/S +IMPOSSIBLE +IMPOSSIBLY +IMPOSTOR/M/S +IMPOTENCE +IMPOTENT +IMPOVERISH/D +IMPOVERISHMENT +IMPRACTICABLE +IMPRACTICAL/Y +IMPRACTICALITY +IMPRECISE/N/Y +IMPREGNABLE +IMPRESS/D/R/G/V/S +IMPRESSION/M/S +IMPRESSIONABLE +IMPRESSIONIST +IMPRESSIONISTIC +IMPRESSIVE/P/Y +IMPRESSMENT +IMPRINT/D/G/S +IMPRISON/D/G/S +IMPRISONMENT/M/S +IMPROBABLE +IMPROMPTU +IMPROPER/Y +IMPROVE/D/G/S +IMPROVEMENT/S +IMPROVISATION/M/S +IMPROVISATIONAL +IMPROVISE/D/R/Z/G/S +IMPUDENT/Y +IMPULSE/N/V/S +IMPUNITY +IMPURE +IMPURITY/M/S +IMPUTE/D +IN +INABILITY +INACCESSIBLE +INACCURACY/S +INACCURATE +INACTIVE +INACTIVITY +INADEQUACY/S +INADEQUATE/P/Y +INADMISSIBILITY +INADVERTENT/Y +INADVISABLE +INANIMATE/Y +INAPPLICABLE +INAPPROPRIATE/P +INASMUCH +INAUGURAL +INAUGURATE/D/G/N +INC +INCAPABLE +INCAPACITATING +INCARNATION/M/S +INCENDIARY/S +INCENSE/D/S +INCENTIVE/M/S +INCEPTION +INCESSANT/Y +INCH/D/G/S +INCIDENCE +INCIDENT/M/S +INCIDENTAL/Y/S +INCIPIENT +INCITE/D/G/S +INCLINATION/M/S +INCLINE/D/G/S +INCLOSE/D/G/S +INCLUDE/D/G/S +INCLUSION/M/S +INCLUSIVE/P/Y +INCOHERENT/Y +INCOME/G/S +INCOMMENSURATE +INCOMPARABLE +INCOMPARABLY +INCOMPATIBILITY/M/S +INCOMPATIBLE +INCOMPATIBLY +INCOMPETENCE +INCOMPETENT/M/S +INCOMPLETE/P/Y +INCOMPREHENSIBILITY +INCOMPREHENSIBLE +INCOMPREHENSIBLY +INCONCEIVABLE +INCONCLUSIVE +INCONSEQUENTIAL/Y +INCONSIDERATE/P/Y +INCONSISTENCY/M/S +INCONSISTENT/Y +INCONVENIENCE/D/G/S +INCONVENIENT/Y +INCORPORATE/D/G/N/S +INCORRECT/P/Y +INCREASE/D/G/S +INCREASINGLY +INCREDIBLE +INCREDIBLY +INCREDULOUS/Y +INCREMENT/D/G/S +INCREMENTAL/Y +INCUBATE/D/G/N/S +INCUBATOR/M/S +INCUR/S +INCURABLE +INCURRED +INCURRING +INDEBTED/P +INDECISION +INDEED +INDEFINITE/P/Y +INDEMNITY +INDENT/D/G/S +INDENTATION/M/S +INDEPENDENCE +INDEPENDENT/Y/S +INDESCRIBABLE +INDETERMINACY/M/S +INDETERMINATE/Y +INDEX/D/G/S +INDEXABLE +INDIA +INDIAN/M/S +INDIANA +INDICATE/D/G/N/X/V/S +INDICATOR/M/S +INDICES +INDICTMENT/M/S +INDIFFERENCE +INDIFFERENT/Y +INDIGENOUS/P/Y +INDIGESTION +INDIGNANT/Y +INDIGNATION +INDIGNITY/S +INDIGO +INDIRECT/D/G/Y/S +INDIRECTION/S +INDISCRIMINATE/Y +INDISPENSABILITY +INDISPENSABLE +INDISPENSABLY +INDISTINGUISHABLE +INDIVIDUAL/M/Y/S +INDIVIDUALISTIC +INDIVIDUALITY +INDIVIDUALIZE/D/G/S +INDIVISIBILITY +INDIVISIBLE +INDOCTRINATE/D/G/N/S +INDOLENT/Y +INDOMITABLE +INDOOR/S +INDUCE/D/R/G/S +INDUCEMENT/M/S +INDUCT/D/G/S +INDUCTANCE/S +INDUCTION/M/S +INDUCTIVE/Y +INDUCTOR/M/S +INDULGE/D/G +INDULGENCE/M/S +INDUSTRIAL/Y/S +INDUSTRIALIST/M/S +INDUSTRIALIZATION +INDUSTRIOUS/P/Y +INDUSTRY/M/S +INEFFECTIVE/P/Y +INEFFICIENCY/S +INEFFICIENT/Y +INELEGANT +INEQUALITY/S +INERT/P/Y +INERTIA +INESCAPABLE +INESCAPABLY +INESSENTIAL +INESTIMABLE +INEVITABILITY/S +INEVITABLE +INEVITABLY +INEXACT +INEXCUSABLE +INEXCUSABLY +INEXORABLE +INEXORABLY +INEXPENSIVE/Y +INEXPERIENCE/D +INEXPLICABLE +INFALLIBILITY +INFALLIBLE +INFALLIBLY +INFAMOUS/Y +INFANCY +INFANT/M/S +INFANTRY +INFEASIBLE +INFECT/D/G/V/S +INFECTION/M/S +INFECTIOUS/Y +INFER/S +INFERENCE/M/S +INFERENTIAL +INFERIOR/M/S +INFERIORITY +INFERNAL/Y +INFERNO/M/S +INFERRED +INFERRING +INFEST/D/G/S +INFIDEL/M/S +INFINITE/P/Y +INFINITESIMAL +INFINITIVE/M/S +INFINITUM +INFINITY +INFIRMITY +INFIX +INFLAME/D +INFLAMMABLE +INFLATABLE +INFLATE/D/G/N/S +INFLATIONARY +INFLEXIBILITY +INFLEXIBLE +INFLICT/D/G/S +INFLUENCE/D/G/S +INFLUENTIAL/Y +INFLUENZA +INFO +INFORM/D/R/Z/G/S +INFORMAL/Y +INFORMALITY +INFORMANT/M/S +INFORMATION +INFORMATIONAL +INFORMATIVE/Y +INFREQUENT/Y +INFRINGE/D/G/S +INFRINGEMENT/M/S +INFURIATE/D/G/N/S +INFUSE/D/G/N/X/S +INGENIOUS/P/Y +INGENUITY +INGRATITUDE +INGREDIENT/M/S +INGRES +INHABIT/D/G/S +INHABITABLE +INHABITANCE +INHABITANT/M/S +INHALE/D/R/G/S +INHERE/S +INHERENT/Y +INHERIT/D/G/S +INHERITABLE +INHERITANCE/M/S +INHERITOR/M/S +INHERITRESS/M/S +INHERITRICES +INHERITRIX +INHIBIT/D/G/S +INHIBITION/M/S +INHIBITORS +INHIBITORY +INHOMOGENEITY/S +INHUMAN +INHUMANE +INIQUITY/M/S +INITIAL/D/G/Y/S +INITIALIZATION/M/S +INITIALIZE/D/R/Z/G/S +INITIATE/D/G/N/X/V/S +INITIATIVE/M/S +INITIATOR/M/S +INJECT/D/G/V/S +INJECTION/M/S +INJUNCTION/M/S +INJURE/D/G/S +INJURIOUS +INJURY/M/S +INJUSTICE/M/S +INK/D/R/Z/G/J/S +INKLING/M/S +INLAID +INLAND +INLET/M/S +INLINE +INMATE/M/S +INN/R/G/J/S +INNARDS +INNATE/Y +INNERMOST +INNOCENCE +INNOCENT/Y/S +INNOCUOUS/P/Y +INNOVATE/N/X/V +INNOVATION/M/S +INNUMERABILITY +INNUMERABLE +INNUMERABLY +INORDINATE/Y +INPUT/M/S +INQUIRE/D/R/Z/G/S +INQUIRY/M/S +INQUISITION/M/S +INQUISITIVE/P/Y +INROAD/S +INSANE/Y +INSANITY +INSCRIBE/D/G/S +INSCRIPTION/M/S +INSECT/M/S +INSECURE/Y +INSENSIBLE +INSENSITIVE/Y +INSENSITIVITY +INSEPARABLE +INSERT/D/G/S +INSERTION/M/S +INSIDE/R/Z/S +INSIDIOUS/P/Y +INSIGHT/M/S +INSIGNIA +INSIGNIFICANCE +INSIGNIFICANT +INSINUATE/D/G/N/X/S +INSIST/D/G/S +INSISTENCE +INSISTENT/Y +INSOFAR +INSOLENCE +INSOLENT/Y +INSOLUBLE +INSPECT/D/G/S +INSPECTION/M/S +INSPECTOR/M/S +INSPIRATION/M/S +INSPIRE/D/R/G/S +INSTABILITY/S +INSTALL/D/R/Z/G/S +INSTALLATION/M/S +INSTALLMENT/M/S +INSTANCE/S +INSTANT/R/Y/S +INSTANTANEOUS/Y +INSTANTIATE/D/G/N/X/S +INSTANTIATION/M/S +INSTEAD +INSTIGATE/D/G/S +INSTIGATOR/M/S +INSTINCT/M/V/S +INSTINCTIVELY +INSTITUTE/D/R/Z/G/N/X/S +INSTITUTIONAL/Y +INSTITUTIONALIZE/D/G/S +INSTRUCT/D/G/V/S +INSTRUCTION/M/S +INSTRUCTIONAL +INSTRUCTIVELY +INSTRUCTOR/M/S +INSTRUMENT/D/G/S +INSTRUMENTAL/Y/S +INSTRUMENTALIST/M/S +INSTRUMENTATION +INSUFFICIENT/Y +INSULATE/D/G/N/S +INSULATOR/M/S +INSULT/D/G/S +INSUPERABLE +INSURANCE +INSURE/D/R/Z/G/S +INSURGENT/M/S +INSURMOUNTABLE +INSURRECTION/M/S +INTACT +INTANGIBLE/M/S +INTEGER/M/S +INTEGRAL/M/S +INTEGRATE/D/G/N/X/V/S +INTEGRITY +INTELLECT/M/S +INTELLECTUAL/Y/S +INTELLIGENCE +INTELLIGENT/Y +INTELLIGIBILITY +INTELLIGIBLE +INTELLIGIBLY +INTEND/D/G/S +INTENSE/V/Y +INTENSIFY/D/R/Z/G/N/S +INTENSITY/S +INTENSIVELY +INTENT/P/Y/S +INTENTION/D/S +INTENTIONAL/Y +INTER +INTERACT/D/G/V/S +INTERACTION/M/S +INTERACTIVELY +INTERACTIVITY +INTERCEPT/D/G/S +INTERCHANGE/D/G/J/S +INTERCHANGEABILITY +INTERCHANGEABLE +INTERCHANGEABLY +INTERCITY +INTERCOMMUNICATE/D/G/N/S +INTERCONNECT/D/G/S +INTERCONNECTION/M/S +INTERCOURSE +INTERDEPENDENCE +INTERDEPENDENCY/S +INTERDEPENDENT +INTERDISCIPLINARY +INTEREST/D/G/S +INTERESTINGLY +INTERFACE/D/R/G/S +INTERFERE/D/G/S +INTERFERENCE/S +INTERFERINGLY +INTERIM +INTERIOR/M/S +INTERLACE/D/G/S +INTERLEAVE/D/G/S +INTERLINK/D/S +INTERLISP +INTERMEDIARY +INTERMEDIATE/M/S +INTERMINABLE +INTERMINGLE/D/G/S +INTERMITTENT/Y +INTERMIXED +INTERMODULE +INTERN/D/S +INTERNAL/Y/S +INTERNALIZE/D/G/S +INTERNATIONAL/Y +INTERNATIONALITY +INTERNET +INTERNIST +INTERPERSONAL +INTERPLAY +INTERPOLATE/D/G/N/X/S +INTERPOSE/D/G/S +INTERPRET/D/R/Z/G/V/S +INTERPRETABLE +INTERPRETATION/M/S +INTERPRETIVELY +INTERPROCESS +INTERRELATE/D/G/N/X/S +INTERRELATIONSHIP/M/S +INTERROGATE/D/G/N/X/V/S +INTERRUPT/D/G/V/S +INTERRUPTIBLE +INTERRUPTION/M/S +INTERSECT/D/G/S +INTERSECTION/M/S +INTERSPERSE/D/G/N/S +INTERSTAGE +INTERSTATE +INTERTEXUALITY +INTERTWINE/D/G/S +INTERVAL/M/S +INTERVENE/D/G/S +INTERVENTION/M/S +INTERVIEW/D/R/Z/G/S +INTERWOVEN +INTESTINAL +INTESTINE/M/S +INTIMACY +INTIMATE/D/G/N/X/Y +INTIMIDATE/D/G/N/S +INTO +INTOLERABLE +INTOLERABLY +INTOLERANCE +INTOLERANT +INTONATION/M/S +INTOXICATE/D/G/N +INTRA +INTRACTABILITY +INTRACTABLE +INTRACTABLY +INTRAMURAL +INTRANSIGENT +INTRANSITIVE/Y +INTRAPROCESS +INTRICACY/S +INTRICATE/Y +INTRIGUE/D/G/S +INTRINSIC +INTRINSICALLY +INTRODUCE/D/G/S +INTRODUCTION/M/S +INTRODUCTORY +INTROSPECT/V +INTROSPECTION/S +INTROVERT/D +INTRUDE/D/R/G/S +INTRUDER/M/S +INTRUSION/M/S +INTRUST +INTUBATE/D/N/S +INTUITION/M/S +INTUITIONIST +INTUITIVE/Y +INTUITIVENESS +INVADE/D/R/Z/G/S +INVALID/Y/S +INVALIDATE/D/G/N/X/S +INVALIDITY/S +INVALUABLE +INVARIABLE +INVARIABLY +INVARIANCE +INVARIANT/Y/S +INVASION/M/S +INVENT/D/G/V/S +INVENTION/M/S +INVENTIVELY +INVENTIVENESS +INVENTOR/M/S +INVENTORY/M/S +INVERSE/N/X/Y/S +INVERT/D/R/Z/G/S +INVERTEBRATE/M/S +INVERTIBLE +INVEST/D/G/S +INVESTIGATE/D/G/N/X/V/S +INVESTIGATOR/M/S +INVESTMENT/M/S +INVESTOR/M/S +INVINCIBLE +INVISIBILITY +INVISIBLE +INVISIBLY +INVITATION/M/S +INVITE/D/G/S +INVOCABLE +INVOCATION/M/S +INVOICE/D/G/S +INVOKE/D/R/G/S +INVOLUNTARILY +INVOLUNTARY +INVOLVE/D/G/S +INVOLVEMENT/M/S +INWARD/P/Y/S +IODINE +ION/S +IPC +IQ +IRATE/P/Y +IRE/M/S +IRELAND/M +IRIS +IRK/D/G/S +IRKSOME +IRON/D/G/J/S +IRONICAL/Y +IRONY/S +IRRATIONAL/Y/S +IRRECOVERABLE +IRREDUCIBLE +IRREDUCIBLY +IRREFLEXIVE +IRREFUTABLE +IRREGULAR/Y/S +IRREGULARITY/S +IRRELEVANCE/S +IRRELEVANT/Y +IRREPRESSIBLE +IRRESISTIBLE +IRRESPECTIVE/Y +IRRESPONSIBLE +IRRESPONSIBLY +IRREVERSIBLE +IRRIGATE/D/G/N/S +IRRITATE/D/G/N/X/S +IS +ISLAND/R/Z/S +ISLE/M/S +ISLET/M/S +ISN'T +ISOLATE/D/G/N/X/S +ISOMETRIC +ISOMORPHIC +ISOMORPHICALLY +ISOMORPHISM/M/S +ISOTOPE/M/S +ISRAEL +ISSUANCE +ISSUE/D/R/Z/G/S +ISTHMUS +IT/M +ITALIAN/M/S +ITALIC/S +ITALICIZE/D +ITALY +ITCH/G/S +ITEM/M/S +ITEMIZATION/M/S +ITEMIZE/D/G/S +ITERATE/D/G/N/X/V/S +ITERATIVE/Y +ITERATOR/M/S +ITS +ITSELF +ITT +IV +IVORY +IVY/M/S +JAB/M/S +JABBED +JABBING +JACK +JACKET/D/S +JADE/D +JAIL/D/R/Z/G/S +JAM/S +JAMES +JAMMED +JAMMING +JANITOR/M/S +JANUARY/M/S +JAPAN +JAPANESE +JAR/M/S +JARGON +JARRED +JARRING/Y +JASMINE/M +JAUNDICE +JAUNT/M/S +JAUNTY/P +JAVELIN/M/S +JAW/M/S +JAY +JAZZ +JEALOUS/Y +JEALOUSY/S +JEAN/M/S +JEEP/M/S +JEER/M/S +JELLY/M/S +JELLYFISH +JENNY +JEOPARDIZE/D/G/S +JERK/D/G/J/S +JERKY/P +JERSEY/M/S +JEST/D/R/G/S +JET/M/S +JETTED +JETTING +JEWEL/D/R/S +JEWELRY/S +JIG/M/S +JILL +JIM/M +JINGLE/D/G +JOAN/M +JOB/M/S +JOCUND +JOE/M +JOG/S +JOHN/M +JOIN/D/R/Z/G/S +JOINT/M/Y/S +JOKE/D/R/Z/G/S +JOLLY +JOLT/D/G/S +JOSE/M +JOSTLE/D/G/S +JOT/S +JOTTED +JOTTING +JOURNAL/M/S +JOURNALISM +JOURNALIST/M/S +JOURNALIZE/D/G/S +JOURNEY/D/G/J/S +JOUST/D/G/S +JOY/M/S +JOYFUL/Y +JOYOUS/P/Y +JOYSTICK +JR +JUBILEE +JUDGE/D/G/S +JUDGMENT/M/S +JUDICABLE +JUDICIAL +JUDICIARY +JUDICIOUS/Y +JUDY/M +JUG/M/S +JUGGLE/R/Z/G/S +JUICE/M/S +JUICY/T +JULY/M/S +JUMBLE/D/S +JUMP/D/R/Z/G/S +JUMPY +JUNCTION/M/S +JUNCTURE/M/S +JUNE +JUNGLE/M/S +JUNIOR/M/S +JUNIPER +JUNK/R/Z/S +JURISDICTION/M/S +JUROR/M/S +JURY/M/S +JUST/P/Y +JUSTICE/M/S +JUSTIFIABLE +JUSTIFIABLY +JUSTIFIER'S +JUSTIFY/D/R/Z/G/N/X/S +JUT +JUVENILE/M/S +JUXTAPOSE/D/G/S +KAISER +KANJI +KEEL/D/G/S +KEEN/P/T/R/Y +KEEP/R/Z/G/S +KEN +KENNEL/M/S +KEPT +KERCHIEF/M/S +KERNEL/M/S +KERNING +KEROSENE +KETCHUP +KETTLE/M/S +KEY/D/G/S +KEYBOARD/M/S +KEYNOTE +KEYPAD/M/S +KEYSTROKE/M/S +KEYWORD/M/S +KICK/D/R/Z/G/S +KID/M/S +KIDDED +KIDDING +KIDNAP/S/R/D/G/M +KIDNAPPED +KIDNAPPER/M/S +KIDNAPPING/M/S +KIDNEY/M/S +KILL/D/R/Z/G/J/S +KILLINGLY +KILOGRAM/S +KILOMETER/S +KIN +KIND/P/T/R/Y/S +KINDERGARTEN +KINDHEARTED +KINDLE/D/G/S +KINDRED +KING/Y/S +KINGDOM/M/S +KINSHIP +KINSMAN +KISS/D/R/Z/G/S +KIT/M/S +KITCHEN/M/S +KITE/D/G/S +KITTEN/M/S +KITTY +KLUDGES +KNACK +KNAPSACK/M/S +KNAVE/M/S +KNEAD/S +KNEE/D/S +KNEEING +KNEEL/D/G/S +KNELL/M/S +KNELT +KNEW +KNICKERBOCKER/M/S +KNIFE/D/G/S +KNIGHT/D/G/Y/S +KNIGHTHOOD +KNIT/S +KNIVES +KNOB/M/S +KNOCK/D/R/Z/G/S +KNOLL/M/S +KNOT/M/S +KNOTTED +KNOTTING +KNOW/R/G/S +KNOWABLE +KNOWHOW +KNOWINGLY +KNOWLEDGE +KNOWLEDGEABLE +KNOWN +KNUCKLE/D/S +KONG +KYOTO +LAB/M/S +LABEL/S/D/R/G/M +LABOR/D/R/Z/G/J/S +LABORATORY/M/S +LABORIOUS/Y +LABYRINTH +LABYRINTHS +LACE/D/G/S +LACERATE/D/G/N/X/S +LACK/D/G/S +LACQUER/D/S +LAD/G/N/S +LADDER +LADLE +LADY/M/S +LAG/R/Z/S +LAGOON/M/S +LAGRANGIAN +LAID +LAIN +LAIR/M/S +LAKE/M/S +LAMB/M/S +LAMBDA +LAME/P/D/G/Y/S +LAMENT/D/G/S +LAMENTABLE +LAMENTATION/M/S +LAMINAR +LAMP/M/S +LANCE/D/R/S +LANCHESTER +LAND/D/R/Z/G/J/S +LANDLADY/M/S +LANDLORD/M/S +LANDMARK/M/S +LANDOWNER/M/S +LANDSCAPE/D/G/S +LANE/M/S +LANGUAGE/M/S +LANGUID/P/Y +LANGUISH/D/G/S +LANSING +LANTERN/M/S +LAP/M/S +LAPEL/M/S +LAPIDARY +LAPSE/D/G/S +LARD/R +LARGE/P/T/R/Y +LARK/M/S +LARVA +LARVAE +LAS +LASER/M/S +LASH/D/G/J/S +LASS/M/S +LAST/D/G/Y/S +LATCH/D/G/S +LATE/P/T/R/Y +LATENCY +LATENT +LATERAL/Y +LATITUDE/M/S +LATRINE/M/S +LATTER/Y +LATTICE/M/S +LAUGH/D/G +LAUGHABLE +LAUGHABLY +LAUGHINGLY +LAUGHS +LAUGHTER +LAUNCH/D/R/G/J/S +LAUNDER/D/R/G/J/S +LAUNDRY +LAURA/M +LAUREL/M/S +LAVA +LAVATORY/M/S +LAVENDER +LAVISH/D/G/Y +LAW/M/S +LAWFUL/Y +LAWLESS/P +LAWN/M/S +LAWRENCE/M +LAWSUIT/M/S +LAWYER/M/S +LAY/G/S +LAYER/D/G/S +LAYMAN +LAYMEN +LAYOFFS +LAYOUT/M/S +LAZED +LAZILY +LAZING +LAZY/P/T/R +LEAD/D/R/Z/G/N/J/S +LEADERSHIP/M/S +LEAF/D/G +LEAFLESS +LEAFLET/M/S +LEAFY/T +LEAGUE/D/R/Z/S +LEAK/D/G/S +LEAKAGE/M/S +LEAN/P/D/T/R/G/S +LEAP/D/G/S +LEAPT +LEARN/D/R/Z/G/S +LEASE/D/G/S +LEASH/M/S +LEAST +LEATHER/D/S +LEATHERN +LEAVE/D/G/J/S +LEAVEN/D/G +LECTURE/D/R/Z/G/S +LED +LEDGE/R/Z/S +LEE/R/S +LEECH/M/S +LEFT +LEFTIST/M/S +LEFTMOST +LEFTOVER/M/S +LEFTWARD +LEG/S +LEGACY/M/S +LEGAL/Y +LEGALITY +LEGALIZATION +LEGALIZE/D/G/S +LEGEND/M/S +LEGENDARY +LEGGED +LEGGINGS +LEGIBILITY +LEGIBLE +LEGIBLY +LEGION/M/S +LEGISLATE/D/G/N/V/S +LEGISLATOR/M/S +LEGISLATURE/M/S +LEGITIMACY +LEGITIMATE/Y +LEGUME/S +LEISURE/Y +LEMMA/M/S +LEMON/M/S +LEMONADE +LEND/R/Z/G/S +LENGTH/N/Y +LENGTHEN/D/G/S +LENGTHS +LENGTHWISE +LENGTHY +LENIENCY +LENIENT/Y +LENS/M/S +LENT/N +LENTIL/M/S +LEOPARD/M/S +LEPROSY +LESS/R +LESSEN/D/G/S +LESSON/M/S +LEST/R +LET/M/S +LETTER/D/R/G/S +LETTING +LETTUCE +LEUKEMIA +LEVEE/M/S +LEVEL/P/D/R/G/Y/S/T +LEVELLED +LEVELLER +LEVELLEST +LEVELLING +LEVER/M/S +LEVERAGE +LEVY/D/G/S +LEWD/P/Y +LEXIA/S +LEXICAL/Y +LEXICOGRAPHIC +LEXICOGRAPHICAL/Y +LEXICON/M/S +LIABILITY/M/S +LIABLE +LIAISON/M/S +LIAR/M/S +LIBERAL/Y/S +LIBERALIZE/D/G/S +LIBERATE/D/G/N/S +LIBERATOR/M/S +LIBERTY/M/S +LIBIDO +LIBRARIAN/M/S +LIBRARY/M/S +LICENSE/D/G/S +LICHEN/M/S +LICK/D/G/S +LID/M/S +LIE/D/S +LIEGE +LIEN/M/S +LIEU +LIEUTENANT/M/S +LIFE/R +LIFELESS/P +LIFELIKE +LIFELONG +LIFESTYLE/S +LIFETIME/M/S +LIFT/D/R/Z/G/S +LIGHT/P/D/T/G/N/X/Y/S +LIGHTER/M/S +LIGHTHOUSE/M/S +LIGHTNING/M/S +LIGHTWEIGHT +LIKE/D/G/S +LIKELIHOOD/S +LIKELY/P/T/R +LIKEN/D/G/S +LIKENESS/M/S +LIKEWISE +LILAC/M/S +LILY/M/S +LIMB/R/S +LIME/M/S +LIMESTONE +LIMIT/D/R/Z/G/S +LIMITABILITY +LIMITABLY +LIMITATION/M/S +LIMITLESS +LIMP/P/D/G/Y/S +LINDA/M +LINDEN +LINE'S +LINE/D/R/Z/G/J/S +LINEAR/Y +LINEARITY/S +LINEARIZABLE +LINEARIZE/D/G/S +LINEFEED +LINEN/M/S +LINGER/D/G/S +LINGUIST/M/S +LINGUISTIC/S +LINGUISTICALLY +LINK/D/R/G/S +LINKAGE/M/S +LINOLEUM +LINSEED +LION/M/S +LIONESS/M/S +LIP/M/S +LIPSTICK +LIQUEFY/D/R/Z/G/S +LIQUID/M/S +LIQUIDATION/M/S +LIQUIDITY +LIQUIFY/D/R/Z/G/S +LISBON +LISP/D/M/G/S +LIST/D/R/Z/G/X/S +LISTEN/D/R/Z/G/S +LISTING/M/S +LIT/R/Z +LITERACY +LITERAL/P/Y/S +LITERARY +LITERATE +LITERATURE/M/S +LITHE +LITTER/D/G/S +LITTLE/P/T/R +LIVABLE +LIVABLY +LIVE/P/D/R/Z/G/Y/S +LIVELIHOOD +LIVERY/D +LIZARD/M/S +LOAD/D/R/Z/G/J/S +LOAF/D/R +LOAN/D/G/S +LOATH/Y +LOATHE/D/G +LOATHSOME +LOAVES +LOBBY/D/S +LOBE/M/S +LOBSTER/M/S +LOCAL/Y/S +LOCALITY/M/S +LOCALIZATION +LOCALIZE/D/G/S +LOCATE/D/G/N/X/V/S +LOCATIVES +LOCATOR/M/S +LOCI +LOCK/D/R/Z/G/J/S +LOCKOUT/M/S +LOCKUP/M/S +LOCOMOTION +LOCOMOTIVE/M/S +LOCUS +LOCUST/M/S +LODGE/D/R/G/J/S +LOFT/M/S +LOFTY/P +LOG/M/S +LOGARITHM/M/S +LOGGED +LOGGER/M/S +LOGGING +LOGIC/M/S +LOGICAL/Y +LOGICIAN/M/S +LOGISTIC/S +LOIN/M/S +LOITER/D/R/G/S +LONDON +LONE/R/Z +LONELY/P/T/R +LONESOME +LONG/D/T/R/G/J/S +LONGITUDE/M/S +LOOK/D/R/Z/G/S +LOOKAHEAD +LOOKOUT +LOOKUP/M/S +LOOM/D/G/S +LOON +LOOP/D/G/S +LOOPHOLE/M/S +LOOSE/P/D/T/R/G/Y/S +LOOSEN/D/G/S +LOOT/D/R/G/S +LORD/Y/S +LORDSHIP +LORE +LORRY +LOSE/R/Z/G/S +LOSS/M/S +LOSSAGE +LOSSY/T/R +LOST +LOT/M/S +LOTTERY +LOUD/P/T/R/Y +LOUDSPEAKER/M/S +LOUNGE/D/G/S +LOUSY +LOVABLE +LOVABLY +LOVE/D/R/Z/G/S +LOVELY/P/T/R/S +LOVINGLY +LOW/P/T/Y/S +LOWER/D/G/S +LOWERCASE +LOWLAND/S +LOWLIEST +LOYAL/Y +LOYALTY/M/S +LTD +LUBRICANT/M +LUBRICATION +LUCID +LUCK/D/S +LUCKILY +LUCKLESS +LUCKY/T/R +LUDICROUS/P/Y +LUGGAGE +LUKEWARM +LULL/D/S +LULLABY +LUMBER/D/G +LUMINOUS/Y +LUMP/D/G/S +LUNAR +LUNATIC +LUNCH/D/G/S +LUNCHEON/M/S +LUNG/D/S +LURCH/D/G/S +LURE/D/G/S +LURK/D/G/S +LUSCIOUS/P/Y +LUST/R/S +LUSTILY +LUSTROUS +LUSTY/P +LUTE/M/S +LUXURIANT/Y +LUXURIOUS/Y +LUXURY/M/S +LYING +LYMPH +LYNCH/D/R/S +LYNX/M/S +LYRE +LYRIC/S +MA'AM +MACE/D/S +MACH +MACHINE/D/M/G/S +MACHINERY +MACLACHLAN/M +MACRO/M/S +MACROECONOMICS +MACROMOLECULAR +MACROMOLECULE/M/S +MACROSCOPIC +MACROSTEP/S +MACROSTRUCTURE +MAD/P/Y +MADAM +MADDEN/G +MADDER +MADDEST +MADE +MADEMOISELLE +MADISON +MADMAN +MADRAS +MAGAZINE/M/S +MAGGOT/M/S +MAGIC +MAGICAL/Y +MAGICIAN/M/S +MAGISTRATE/M/S +MAGNESIUM +MAGNET +MAGNETIC +MAGNETISM/M/S +MAGNIFICENCE +MAGNIFICENT/Y +MAGNIFY/D/R/G/N/S +MAGNITUDE/M/S +MAHOGANY +MAID/N/X/S +MAIL/D/R/G/J/S +MAILABLE +MAILBOX/M/S +MAIM/D/G/S +MAIN/Y/S +MAINE +MAINFRAME/M/S +MAINLAND +MAINSTAY +MAINSTREAM +MAINTAIN/D/R/Z/G/S +MAINTAINABILITY +MAINTAINABLE +MAINTENANCE/M/S +MAIZE +MAJESTIC +MAJESTY/M/S +MAJOR/D/S +MAJORITY/M/S +MAKABLE +MAKE/R/Z/G/J/S +MAKESHIFT +MAKEUP/S +MALADY/M/S +MALARIA +MALE/P/M/S +MALEFACTOR/M/S +MALFUNCTION/D/G/S +MALICE +MALICIOUS/P/Y +MALIGNANT/Y +MALLET/M/S +MALNUTRITION +MALT/D/S +MAMA +MAMMA/M/S +MAMMAL/M/S +MAMMOTH +MAN/M/Y/S +MANAGE/D/R/Z/G/S +MANAGEABLE/P +MANAGEMENT/M/S +MANAGER/M/S +MANAGERIAL +MANDATE/D/G/S +MANDATORY +MANDIBLE +MANE/M/S +MANEUVER/D/G/S +MANGER/M/S +MANGLE/D/R/G/S +MANHOOD +MANIAC/M/S +MANICURE/D/G/S +MANIFEST/D/G/Y/S +MANIFESTATION/M/S +MANIFOLD/M/S +MANILA +MANIPULABILITY +MANIPULABLE +MANIPULATABLE +MANIPULATE/D/G/N/X/V/S +MANIPULATOR/M/S +MANIPULATORY +MANKIND +MANNED +MANNER/D/Y/S +MANNING +MANOMETER/M/S +MANOR/M/S +MANPOWER +MANSION/M/S +MANTEL/M/S +MANTISSA/M/S +MANTLE/M/S +MANUAL/M/Y/S +MANUFACTURE/D/R/Z/G/S +MANUFACTURER/M/S +MANURE +MANUSCRIPT/M/S +MANY +MAP/M/S +MAPLE/M/S +MAPPABLE +MAPPED +MAPPING/M/S +MAR/S +MARBLE/G/S +MARC/M +MARCH/D/R/G/S +MARE/M/S +MARGIN/M/S +MARGINAL/Y +MARIGOLD +MARIJUANA +MARINE/R/S +MARIO/M +MARITAL +MARITIME +MARK/D/R/Z/G/J/S +MARKABLE +MARKEDLY +MARKET/D/G/J/S +MARKETABILITY +MARKETABLE +MARKETPLACE/M/S +MARKOV +MARQUIS +MARRIAGE/M/S +MARROW +MARRY/D/G/S +MARSH/M/S +MARSHAL/D/G/S +MART/N/S +MARTHA/M +MARTIAL +MARTIN/M +MARTYR/M/S +MARTYRDOM +MARVEL/D/S/G +MARVELLED +MARVELLING +MARVELOUS/P/Y +MARVIN/M +MARY/M +MARYLAND +MASCULINE/Y +MASCULINITY +MASH/D/G/S +MASK/D/R/G/J/S +MASOCHIST/M/S +MASON/M/S +MASONRY +MASQUERADE/R/G/S +MASS/D/G/V/S +MASSACHUSETTS +MASSACRE/D/S +MASSAGE/G/S +MASSIVE/Y +MAST/D/Z/S +MASTER/D/M/G/Y/J/S +MASTERFUL/Y +MASTERPIECE/M/S +MASTERY +MASTURBATE/D/G/N/S +MAT/M/S +MATCH/D/R/Z/G/J/S +MATCHABLE +MATCHLESS +MATE/D/R/M/G/J/S +MATERIAL/Y/S +MATERIALIZE/D/G/S +MATERNAL/Y +MATH +MATHEMATICAL/Y +MATHEMATICIAN/M/S +MATHEMATICS +MATRICES +MATRICULATION +MATRIMONY +MATRIX +MATRON/Y +MATTED +MATTER/D/S +MATTRESS/M/S +MATURATION +MATURE/D/G/Y/S +MATURITY/S +MAURICE/M +MAX +MAXIM/M/S +MAXIMAL/Y +MAXIMIZE/D/R/Z/G/S +MAXIMUM/S +MAY +MAYBE +MAYHAP +MAYHEM +MAYONNAISE +MAYOR/M/S +MAYORAL +MAZE/M/S +MCDONALD/M +ME +MEAD +MEADOW/M/S +MEAGER/P/Y +MEAL/M/S +MEAN/P/T/R/Y/S +MEANDER/D/G/S +MEANING/M/S +MEANINGFUL/P/Y +MEANINGLESS/P/Y +MEANT +MEANTIME +MEANWHILE +MEASLES +MEASURABLE +MEASURABLY +MEASURE/D/R/G/S +MEASUREMENT/M/S +MEAT/M/S +MECHANIC/M/S +MECHANICAL/Y +MECHANISM/M/S +MECHANIZATION/M/S +MECHANIZE/D/G/S +MEDAL/M/S +MEDALLION/M/S +MEDDLE/D/R/G/S +MEDIA +MEDIAN/M/S +MEDIATE/D/G/N/X/S +MEDIC/M/S +MEDICAL/Y +MEDICINAL/Y +MEDICINE/M/S +MEDIEVAL +MEDIOCRE +MEDITATE/D/G/N/X/V/S +MEDIUM/M/S +MEDUSA +MEEK/P/T/R/Y +MEET/G/J/S +MELANCHOLY +MELLON/M +MELLOW/P/D/G/S +MELODIOUS/P/Y +MELODRAMA/M/S +MELODY/M/S +MELON/M/S +MELT/D/G/S +MELTINGLY +MEMBER/M/S +MEMBERSHIP/M/S +MEMBRANE +MEMO/M/S +MEMOIR/S +MEMORABLE/P +MEMORANDA +MEMORANDUM +MEMORIAL/Y/S +MEMORIZATION +MEMORIZE/D/R/G/S +MEMORY/M/S +MEMORYLESS +MEN/M/S +MENACE/D/G +MENAGERIE +MEND/D/R/G/S +MENIAL/S +MENTAL/Y +MENTALITY/S +MENTION/D/R/Z/G/S +MENTIONABLE +MENTOR/M/S +MENU/M/S +MERCATOR +MERCENARY/P/M/S +MERCHANDISE/R/G +MERCHANT/M/S +MERCIFUL/Y +MERCILESS/Y +MERCURY +MERCY +MERE/T/Y +MERGE/D/R/Z/G/S +MERIDIAN +MERIT/D/G/S +MERITORIOUS/P/Y +MERRILY +MERRIMENT +MERRY/T +MESH +MESS/D/G/S +MESSAGE/M/S +MESSENGER/M/S +MESSIAH +MESSIAHS +MESSIEURS +MESSILY +MESSY/P/T/R +MET/S +META +METACIRCULAR +METACIRCULARITY +METACLASS/S +METAL/M/S +METALANGUAGE +METALLIC +METALLIZATION/S +METALLURGY +METAMATHEMATICAL +METAMORPHOSIS +METAPHOR/M/S +METAPHORICAL/Y +METAPHYSICAL/Y +METAPHYSICS +METAVARIABLE +METE/D/R/Z/G/S +METEOR/M/S +METEORIC +METEOROLOGY +METERING +METHOD/M/S +METHODICAL/P/Y +METHODIST/M/S +METHODOLOGICAL/Y +METHODOLOGISTS +METHODOLOGY/M/S +METRIC/M/S +METRICAL +METROPOLIS +METROPOLITAN +MEW/D/S +MICA +MICE +MICHAEL/M +MICHIGAN +MICRO +MICROBICIDAL +MICROBICIDE +MICROBIOLOGY +MICROCODE/D/G/S +MICROCOMPUTER/M/S +MICROECONOMICS +MICROFILM/M/S +MICROINSTRUCTION/M/S +MICROPHONE/G/S +MICROPROCESSING +MICROPROCESSOR/M/S +MICROPROGRAM/M/S +MICROPROGRAMMED +MICROPROGRAMMING +MICROSCOPE/M/S +MICROSCOPIC +MICROSECOND/M/S +MICROSOFT +MICROSTEP/S +MICROSTORE +MICROSTRUCTURE +MICROSYSTEM/S +MICROWORD/S +MID +MIDDAY +MIDDLE/G/S +MIDNIGHT/S +MIDPOINT/M/S +MIDST/S +MIDSUMMER +MIDWAY +MIDWEST +MIDWINTER +MIEN +MIGHT +MIGHTILY +MIGHTY/P/T/R +MIGRATE/D/G/N/X/S +MIKE/M +MILANO +MILD/P/T/R/Y +MILDEW +MILE/M/S +MILEAGE +MILESTONE/M/S +MILITANT/Y +MILITARILY +MILITARISM +MILITARY +MILITIA +MILK/D/R/Z/G/S +MILKMAID/M/S +MILKY/P +MILL/D/R/G/S +MILLET +MILLIMETER/S +MILLION/H/S +MILLIONAIRE/M/S +MILLIPEDE/M/S +MILLISECOND/S +MILLSTONE/M/S +MIMIC/S +MIMICKED +MIMICKING +MINCE/D/G/S +MIND/D/G/S +MINDFUL/P/Y +MINDLESS/Y +MINE/D/R/Z/G/N/S +MINERAL/M/S +MINGLE/D/G/S +MINI +MINIATURE/M/S +MINIATURIZATION +MINIATURIZE/D/G/S +MINICOMPUTER/M/S +MINIMA +MINIMAL/Y +MINIMIZATION/M/S +MINIMIZE/D/R/Z/G/S +MINIMUM +MINISTER/D/M/G/S +MINISTRY/M/S +MINK/M/S +MINNEAPOLIS +MINNESOTA/M +MINNOW/M/S +MINOR/M/S +MINORITY/M/S +MINSKY/M +MINSTREL/M/S +MINT/D/R/G/S +MINUS +MINUTE/P/R/Y/S +MIRACLE/M/S +MIRACULOUS/Y +MIRAGE +MIRE/D/S +MIRROR/D/G/S +MIRTH +MISBEHAVING +MISCALCULATION/M/S +MISCELLANEOUS/P/Y +MISCHIEF +MISCHIEVOUS/P/Y +MISCONCEPTION/M/S +MISCONSTRUE/D/S +MISER/Y/S +MISERABLE/P +MISERABLY +MISERY/M/S +MISFIT/M/S +MISFORTUNE/M/S +MISGIVING/S +MISHAP/M/S +MISINTERPRETATION +MISJUDGMENT +MISLEAD/G/S +MISLED +MISMATCH/D/G/S +MISNOMER +MISPLACE/D/G/S +MISREPRESENTATION/M/S +MISS/D/G/V/S +MISSILE/M/S +MISSION/R/S +MISSIONARY/M/S +MISSPELL/D/G/J/S +MIST/D/R/Z/G/S +MISTAKABLE +MISTAKE/G/S +MISTAKEN/Y +MISTRESS +MISTRUST/D +MISTY/P +MISTYPE/D/G/S +MISUNDERSTAND/R/Z/G +MISUNDERSTANDING/M/S +MISUNDERSTOOD +MISUSE/D/G/S +MIT/R/M +MITIGATE/D/G/N/V/S +MITTEN/M/S +MIX/D/R/Z/G/S +MIXTURE/M/S +MNEMONIC/M/S +MNEMONICALLY +MOAN/D/S +MOAT/M/S +MOB/M/S +MOCCASIN/M/S +MOCK/D/R/G/S +MOCKERY +MODAL/Y +MODALITY/M/S +MODE/T/S +MODEL/D/G/J/S/M +MODEM +MODERATE/P/D/G/N/Y/S +MODERATOR/M/S +MODERN/P/Y/S +MODERNISM +MODERNITY +MODERNIZE/D/R/G +MODESTLY +MODESTY +MODIFIABILITY +MODIFIABLE +MODIFY/D/R/Z/G/N/X/S +MODULAR/Y +MODULARITY +MODULARIZATION +MODULARIZE/D/G/S +MODULATE/D/G/N/X/S +MODULATOR/M/S +MODULE/M/S +MODULO +MODULUS +MODUS +MOHAWK +MOIST/P/N/Y +MOISTURE +MOLASSES +MOLD/D/R/G/S +MOLE/T/S +MOLECULAR +MOLECULE/M/S +MOLEST/D/G/S +MOLTEN +MOMENT/M/S +MOMENTARILY +MOMENTARY/P +MOMENTOUS/P/Y +MOMENTUM +MONARCH +MONARCHS +MONARCHY/M/S +MONASTERY/M/S +MONASTIC +MONDAY/M/S +MONETARY +MONEY/D/S +MONITOR/D/G/S +MONK/M/S +MONKEY/D/G/S +MONOCHROME +MONOGRAM/M/S +MONOGRAPH/M/S +MONOGRAPHS +MONOLITHIC +MONOPOLY/M/S +MONOTHEISM +MONOTONE +MONOTONIC +MONOTONICALLY +MONOTONICITY +MONOTONOUS/P/Y +MONOTONY +MONSTER/M/S +MONSTROUS/Y +MONTANA/M +MONTH/Y +MONTHS +MONUMENT/M/S +MONUMENTAL/Y +MOOD/M/S +MOODY/P +MOON/D/G/S +MOONLIGHT/R/G +MOONLIT +MOONSHINE +MOOR/D/G/J/S +MOOSE +MOOT +MOP/D/S +MORAL/Y/S +MORALE +MORALITY/S +MORASS +MORBID/P/Y +MORE/S +MOREOVER +MORN/G/J +MORPHISM/S +MORPHOLOGICAL +MORPHOLOGY +MORROW +MORSEL/M/S +MORTAL/Y/S +MORTALITY +MORTAR/D/G/S +MORTGAGE/M/S +MORTIFY/D/G/N/S +MOSAIC/M/S +MOSQUITO/S +MOSQUITOES +MOSS/M/S +MOSSY +MOST/Y +MOTEL/M/S +MOTH/Z +MOTHER'S +MOTHER/D/R/Z/G/Y/S +MOTIF/M/S +MOTION/D/G/S +MOTIONLESS/P/Y +MOTIVATE/D/G/N/X/S +MOTIVATIONAL +MOTIVE/S +MOTLEY +MOTOR/G/S +MOTORCAR/M/S +MOTORCYCLE/M/S +MOTORIST/M/S +MOTORIZE/D/G/S +MOTOROLA/M +MOTTO/S +MOTTOES +MOULD/G +MOUND/D/S +MOUNT/D/R/G/J/S +MOUNTAIN/M/S +MOUNTAINEER/G/S +MOUNTAINOUS/Y +MOURN/D/R/Z/G/S +MOURNFUL/P/Y +MOUSE/R/S +MOUTH/D/G +MOUTHFUL +MOUTHS +MOVABLE +MOVE/D/R/Z/G/J/S +MOVEMENT/M/S +MOVIE/M/S +MOW/D/R/S +MR +MRS +MS +MUCH +MUCK/R/G +MUD +MUDDLE/D/R/Z/G/S +MUDDY/P/D +MUFF/M/S +MUFFIN/M/S +MUFFLE/D/R/G/S +MUG/M/S +MULBERRY/M/S +MULE/M/S +MULTI +MULTICELLULAR +MULTIDIMENSIONAL +MULTILEVEL +MULTINATIONAL +MULTIPLE/M/S +MULTIPLEX/D/G/S +MULTIPLEXOR/M/S +MULTIPLICAND/M/S +MULTIPLICATIVE/S +MULTIPLICITY +MULTIPLY/D/R/Z/G/N/X/S +MULTIPROCESS/G +MULTIPROCESSOR/M/S +MULTIPROGRAM +MULTIPROGRAMMED +MULTIPROGRAMMING +MULTIPURPOSE +MULTISTAGE +MULTITUDE/M/S +MULTIVARIATE +MUMBLE/D/R/Z/G/J/S +MUMMY/M/S +MUNCH/D/G +MUNDANE/Y +MUNICIPAL/Y +MUNICIPALITY/M/S +MUNITION/S +MURAL +MURDER/D/R/Z/G/S +MURDEROUS/Y +MURKY +MURMUR/D/R/G/S +MUSCLE/D/G/S +MUSCULAR +MUSE/D/G/J/S +MUSEUM/M/S +MUSHROOM/D/G/S +MUSHY +MUSIC +MUSICAL/Y/S +MUSICIAN/Y/S +MUSK/S +MUSKET/M/S +MUSKRAT/M/S +MUSLIN +MUSSEL/M/S +MUST/R/S +MUSTACHE/D/S +MUSTARD +MUSTY/P +MUTABILITY +MUTABLE/P +MUTATE/D/G/N/X/V/S +MUTE/P/D/Y +MUTILATE/D/G/N/S +MUTINY/M/S +MUTTER/D/R/Z/G/S +MUTTON +MUTUAL/Y +MUZZLE/M/S +MY +MYRIAD +MYRTLE +MYSELF +MYSTERIOUS/P/Y +MYSTERY/M/S +MYSTIC/M/S +MYSTICAL +MYTH +MYTHICAL +MYTHOLOGY/M/S +NAG/M/S +NAIL/D/G/S +NAIVE/P/Y +NAIVETE +NAKED/P/Y +NAME/D/R/Z/G/Y/S +NAMEABLE +NAMELESS/Y +NAMESAKE/M/S +NANOSECOND/S +NAP/M/S +NAPKIN/M/S +NARCISSUS +NARCOTIC/S +NARRATIVE/M/S +NARROW/P/D/T/R/G/Y/S +NASAL/Y +NASTILY +NASTY/P/T/R +NATHANIEL/M +NATION/M/S +NATIONAL/Y/S +NATIONALIST/M/S +NATIONALITY/M/S +NATIONALIZATION +NATIONALIZE/D/G/S +NATIONWIDE +NATIVE/Y/S +NATIVITY +NATURAL/P/Y/S +NATURALISM +NATURALIST +NATURALIZATION +NATURE/D/M/S +NAUGHT +NAUGHTY/P/R +NAVAL/Y +NAVIGABLE +NAVIGATE/D/G/N/S +NAVIGATOR/M/S +NAVY/M/S +NAY +NAZI/M/S +NEAR/P/D/T/R/G/Y/S +NEARBY +NEAT/P/T/R/Y +NEBRASKA +NEBULA +NECESSARILY +NECESSARY/S +NECESSITATE/D/G/N/S +NECESSITY/S +NECK/G/S +NECKLACE/M/S +NECKTIE/M/S +NEE +NEED/D/G/S +NEEDFUL +NEEDLE/D/R/Z/G/S +NEEDLESS/P/Y +NEEDLEWORK +NEEDN'T +NEEDY +NEGATE/D/G/N/X/V/S +NEGATIVELY +NEGATIVES +NEGATOR/S +NEGLECT/D/G/S +NEGLIGENCE +NEGLIGIBLE +NEGOTIATE/D/G/N/X/S +NEGRO +NEGROES +NEIGH +NEIGHBOR/G/Y/S +NEIGHBORHOOD/M/S +NEITHER +NEOPHYTE/S +NEPAL +NEPHEW/M/S +NERVE/M/S +NERVOUS/P/Y +NEST/D/R/G/S +NESTLE/D/G/S +NET/M/S +NETHER +NETHERLANDS +NETMAIL +NETNEWS +NETTED +NETTING +NETTLE/D +NETWORK/D/M/G/S +NEUMANN/M +NEURAL +NEUROLOGICAL +NEUROLOGISTS +NEURON/M/S +NEUROPHYSIOLOGY +NEUROSCIENCE/S +NEUTRAL/Y +NEUTRALITY/S +NEUTRALIZE/D/G +NEUTRINO/M/S +NEVER +NEVERTHELESS +NEW/P/T/R/Y/S +NEWBORN +NEWCOMER/M/S +NEWLINE +NEWSMAN +NEWSMEN +NEWSPAPER/M/S +NEWTONIAN +NEXT +NIBBLE/D/R/Z/G/S +NICE/P/T/R/Y +NICHE/S +NICK/D/R/G/S +NICKEL/M/S +NICKNAME/D/S +NIECE/M/S +NIFTY +NIGH +NIGHT/Y/S +NIGHTFALL +NIGHTGOWN +NIGHTINGALE/M/S +NIGHTMARE/M/S +NIL +NIMBLE/P/R +NIMBLY +NINE/S +NINETEEN/H/S +NINETY/H/S +NINTH +NIP/S +NITROGEN +NO +NOBILITY +NOBLE/P/T/R/S +NOBLEMAN +NOBLY +NOBODY +NOCTURNAL/Y +NOD/M/S +NODDED +NODDING +NODE/M/S +NOISE/S +NOISELESS/Y +NOISILY +NOISY/P/R +NOMENCLATURE +NOMINAL/Y +NOMINATE/D/G/N/V +NON +NONBLOCKING +NONCONSERVATIVE +NONCYCLIC +NONDECREASING +NONDESCRIPT/Y +NONDESTRUCTIVELY +NONDETERMINACY +NONDETERMINATE/Y +NONDETERMINISM +NONDETERMINISTIC +NONDETERMINISTICALLY +NONE +NONEMPTY +NONETHELESS +NONEXISTENCE +NONEXISTENT +NONEXTENSIBLE +NONFUNCTIONAL +NONINTERACTING +NONINTERFERENCE +NONINTUITIVE +NONLINEAR/Y +NONLINEARITY/M/S +NONLOCAL +NONNEGATIVE +NONORTHOGONAL +NONORTHOGONALITY +NONPERISHABLE +NONPROCEDURAL/Y +NONPROGRAMMABLE +NONPROGRAMMER +NONSENSE +NONSENSICAL +NONSPECIALIST/M/S +NONTECHNICAL +NONTERMINAL/M/S +NONTERMINATING +NONTERMINATION +NONTRIVIAL +NONUNIFORM +NONZERO +NOODLE/S +NOOK/M/S +NOON/S +NOONDAY +NOONTIDE +NOR/H +NORM/M/S +NORMAL/Y/S +NORMALCY +NORMALITY +NORMALIZATION +NORMALIZE/D/G/S +NORTHEAST/R +NORTHEASTERN +NORTHERN/R/Z/Y +NORTHWARD/S +NORTHWEST +NORTHWESTERN +NOSE/D/G/S +NOSTRIL/M/S +NOT +NOTABLE/S +NOTABLY +NOTARIZE/D/G/S +NOTATION/M/S +NOTATIONAL +NOTCH/D/G/S +NOTE/D/G/N/X/S +NOTEBOOK/M/S +NOTEWORTHY +NOTHING/P/S +NOTICE/D/G/S +NOTICEABLE +NOTICEABLY +NOTIFY/D/R/Z/G/N/X/S +NOTORIOUS/Y +NOTWITHSTANDING +NOUN/M/S +NOURISH/D/G/S +NOURISHMENT +NOVEL/M/S +NOVELIST/M/S +NOVELTY/M/S +NOVEMBER +NOVICE/M/S +NOW +NOWADAYS +NOWHERE +NSF +NUANCES +NUCLEAR +NUCLEOTIDE/M/S +NUCLEUS +NUISANCE/M/S +NULL/D/S +NULLARY +NULLIFY/D/Z/G/S +NUMB/P/D/Z/G/Y/S +NUMBER/D/R/G/S +NUMBERLESS +NUMERAL/M/S +NUMERATOR/M/S +NUMERIC/S +NUMERICAL/Y +NUMEROUS +NUN/M/S +NUPTIAL +NURSE/D/G/S +NURSERY/M/S +NURTURE/D/G/S +NUT/M/S +NUTRITION +NYMPH +NYMPHS +O'CLOCK +OAK/N/S +OAR/M/S +OASIS +OAT/N/S +OATH +OATHS +OATMEAL +OBEDIENCE/S +OBEDIENT/Y +OBEY/D/G/S +OBJECT/D/G/M/S/V +OBJECTION/M/S +OBJECTIONABLE +OBJECTIVELY +OBJECTIVES +OBJECTOR/M/S +OBLIGATION/M/S +OBLIGATORY +OBLIGE/D/G/S +OBLIGINGLY +OBLIQUE/P/Y +OBLITERATE/D/G/N/S +OBLIVION +OBLIVIOUS/P/Y +OBLONG +OBSCENE +OBSCURE/D/R/G/Y/S +OBSCURITY/S +OBSERVABILITY +OBSERVABLE +OBSERVANCE/M/S +OBSERVANT +OBSERVATION/M/S +OBSERVATORY +OBSERVE/D/R/Z/G/S +OBSESSION/M/S +OBSOLESCENCE +OBSOLETE/D/G/S +OBSTACLE/M/S +OBSTINACY +OBSTINATE/Y +OBSTRUCT/D/G/V +OBSTRUCTION/M/S +OBTAIN/D/G/S +OBTAINABLE +OBTAINABLY +OBVIATE/D/G/N/X/S +OBVIOUS/P/Y +OCCASION/D/G/J/S +OCCASIONAL/Y +OCCLUDE/D/S +OCCLUSION/M/S +OCCUPANCY/S +OCCUPANT/M/S +OCCUPATION/M/S +OCCUPATIONAL/Y +OCCUPY/D/R/G/S +OCCUR/S +OCCURRED +OCCURRENCE/M/S +OCCURRING +OCEAN/M/S +OCTAL +OCTAVE/S +OCTOBER +OCTOPUS +ODD/P/T/R/Y/S +ODDITY/M/S +ODE/M/S +ODIOUS/P/Y +ODOR/M/S +ODOROUS/P/Y +ODYSSEY +OEDIPUS +OF +OFF/G +OFFEND/D/R/Z/G/S +OFFENSE/V/S +OFFENSIVELY +OFFENSIVENESS +OFFER/D/R/Z/G/J/S +OFFICE/R/Z/S +OFFICER'S +OFFICIAL/Y/S +OFFICIO +OFFICIOUS/P/Y +OFFSET/M/S +OFFSPRING +OFT/N +OFTENTIMES +OH +OHIO/M +OIL/D/R/Z/G/S +OILCLOTH +OILY/T/R +OINTMENT +OK +OKAY +OLD/P/T/R/N +OLIVE/M/S +OLIVETTI +OMEN/M/S +OMINOUS/P/Y +OMISSION/M/S +OMIT/S +OMITTED +OMITTING +OMNIPRESENT +OMNISCIENT/Y +OMNIVORE +ON/Y +ONANISM +ONBOARD +ONCE +ONCOLOGY +ONE/P/M/N/X/S +ONEROUS +ONESELF +ONGOING +ONLINE +ONSET/M/S +ONTO +ONWARD/S +OOZE/D +OPACITY +OPAL/M/S +OPAQUE/P/Y +OPCODE +OPEN/P/D/R/Z/Y/S +OPENING/M/S +OPERA/M/S +OPERABLE +OPERAND/M/S +OPERANDI +OPERATE/D/G/N/X/V/S +OPERATIONAL/Y +OPERATIVES +OPERATOR/M/S +OPINION/M/S +OPIUM +OPPONENT/M/S +OPPORTUNE/Y +OPPORTUNISM +OPPORTUNISTIC +OPPORTUNITY/M/S +OPPOSE/D/G/S +OPPOSITE/P/N/Y/S +OPPRESS/D/G/V/S +OPPRESSION +OPPRESSOR/M/S +OPT/D/G/S +OPTIC/S +OPTICAL/Y +OPTIMAL/Y +OPTIMALITY +OPTIMISM +OPTIMISTIC +OPTIMISTICALLY +OPTIMIZATION/M/S +OPTIMIZE/D/R/Z/G/S +OPTIMUM +OPTION/M/S +OPTIONAL/Y +OR/M/Y +ORACLE/M/S +ORAL/Y +ORANGE/M/S +ORATION/M/S +ORATOR/M/S +ORATORY/M/S +ORB +ORBIT/D/R/Z/G/S +ORBITAL/Y +ORCHARD/M/S +ORCHESTRA/M/S +ORCHID/M/S +ORDAIN/D/G/S +ORDEAL +ORDER/D/G/Y/J/S +ORDERLIES +ORDINAL +ORDINANCE/M/S +ORDINARILY +ORDINARY/P +ORDINATE/N/S +ORE/M/S +ORGAN/M/S +ORGANIC +ORGANISM/M/S +ORGANIST/M/S +ORGANIZABLE +ORGANIZATION/M/S +ORGANIZATIONAL/Y +ORGANIZE/D/R/Z/G/S +ORGY/M/S +ORIENT/D/G/S +ORIENTAL +ORIENTATION/M/S +ORIFICE/M/S +ORIGIN/M/S +ORIGINAL/Y/S +ORIGINALITY +ORIGINATE/D/G/N/S +ORIGINATOR/M/S +ORLEANS +ORNAMENT/D/G/S +ORNAMENTAL/Y +ORNAMENTATION +ORPHAN/D/S +ORTHODOX +ORTHOGONAL/Y +ORTHOGONALITY +ORTHOGRAPHIC +OSAKA +OSCILLATE/D/G/N/X/S +OSCILLATION/M/S +OSCILLATOR/M/S +OSCILLATORY +OSCILLOSCOPE/M/S +OSTRICH/M/S +OTHER/S +OTHERWISE +OTTER/M/S +OUGHT +OUNCE/S +OUR/S +OURSELF +OURSELVES +OUT/R/G/S +OUTBREAK/M/S +OUTBURST/M/S +OUTCAST/M/S +OUTCOME/M/S +OUTCRY/S +OUTDOOR/S +OUTERMOST +OUTFIT/M/S +OUTGOING +OUTGREW +OUTGROW/G/H/S +OUTGROWN +OUTLAST/S +OUTLAW/D/G/S +OUTLAY/M/S +OUTLET/M/S +OUTLINE/D/G/S +OUTLIVE/D/G/S +OUTLOOK +OUTPERFORM/D/G/S +OUTPOST/M/S +OUTPUT/M/S +OUTPUTTING +OUTRAGE/D/S +OUTRAGEOUS/Y +OUTRIGHT +OUTRUN/S +OUTSET +OUTSIDE/R +OUTSIDER/M/S +OUTSKIRTS +OUTSTANDING/Y +OUTSTRETCHED +OUTSTRIP/S +OUTSTRIPPED +OUTSTRIPPING +OUTVOTE/D/G/S +OUTWARD/Y +OUTWEIGH/D/G +OUTWEIGHS +OUTWIT/S +OUTWITTED +OUTWITTING +OVAL/M/S +OVARY/M/S +OVEN/M/S +OVER/Y +OVERALL/M/S +OVERBOARD +OVERCAME +OVERCOAT/M/S +OVERCOME/G/S +OVERCROWD/D/G/S +OVERDONE +OVERDRAFT/M/S +OVERDUE +OVEREMPHASIS +OVEREMPHASIZED +OVERESTIMATE/D/G/N/S +OVERFLOW/D/G/S +OVERHANG/G/S +OVERHAUL/G +OVERHEAD/S +OVERHEAR/G/S +OVERHEARD +OVERJOY/D +OVERLAND +OVERLAP/M/S +OVERLAPPED +OVERLAPPING +OVERLAY/G/S +OVERLOAD/D/G/S +OVERLOOK/D/G/S +OVERNIGHT/R/Z +OVERPOWER/D/G/S +OVERPRINT/D/G/S +OVERPRODUCTION +OVERRIDDEN +OVERRIDE/G/S +OVERRODE +OVERRULE/D/S +OVERRUN/S +OVERSEAS +OVERSEE/R/Z/S +OVERSEEING +OVERSHADOW/D/G/S +OVERSHOOT +OVERSHOT +OVERSIGHT/M/S +OVERSIMPLIFY/D/G/S +OVERSTATE/D/G/S +OVERSTATEMENT/M/S +OVERSTOCKS +OVERT/Y +OVERTAKE/R/Z/G/S +OVERTAKEN +OVERTHREW +OVERTHROW +OVERTHROWN +OVERTIME +OVERTONE/M/S +OVERTOOK +OVERTURE/M/S +OVERTURN/D/G/S +OVERUSE +OVERVIEW/M/S +OVERWHELM/D/G/S +OVERWHELMINGLY +OVERWORK/D/G/S +OVERWRITE/G/S +OVERWRITTEN +OVERZEALOUS +OWE/D/G/S +OWL/M/S +OWN/D/R/Z/G/S +OWNERSHIP/S +OX/N +OXFORD +OXIDE/M/S +OXIDIZE/D +OXYGEN +OYSTER/M/S +PA/H +PACE/D/R/Z/G/S +PACHELBEL +PACIFIC +PACIFY/R/N/S +PACK/D/R/Z/G/S +PACKAGE/D/R/Z/G/J/S +PACKET/M/S +PACT/M/S +PAD/M/S +PADDED +PADDING +PADDLE +PADDY +PAGAN/M/S +PAGE'S +PAGE/D/R/Z/G/S +PAGEANT/M/S +PAGINATE/D/G/N/S +PAID +PAIL/M/S +PAIN/D/S +PAINFUL/Y +PAINSTAKING/Y +PAINT/D/R/Z/G/J/S +PAIR/D/G/J/S +PAIRWISE +PAJAMA/S +PAL/M/S +PALACE/M/S +PALATE/M/S +PALE/P/D/T/R/G/Y/S +PALETTE +PALFREY +PALL +PALLIATE/V +PALLID +PALM/D/R/G/S +PALPATION +PAMPHLET/M/S +PAN/M/S +PANACEA/M/S +PANCAKE/M/S +PANDEMONIUM +PANE/M/S +PANEL/D/G/S +PANELIST/M/S +PANG/M/S +PANIC/M/S +PANNED +PANNING +PANSY/M/S +PANT/D/G/S +PANTHER/M/S +PANTRY/M/S +PANTY/S +PAPA +PAPAL +PAPER'S +PAPER/D/R/Z/G/J/S +PAPERBACK/M/S +PAPERWORK +PAPRIKA +PAR/S +PARACHUTE/M/S +PARADE/D/G/S +PARADIGM/M/S +PARADISE +PARADOX/M/S +PARADOXICAL/Y +PARAFFIN +PARAGON/M/S +PARAGRAPH/G +PARAGRAPHS +PARALLEL/D/G/S +PARALLELISM +PARALLELIZE/D/G/S +PARALLELLED +PARALLELLING +PARALLELOGRAM/M/S +PARALYSIS +PARALYZE/D/G/S +PARAMETER/M/S +PARAMETERIZABLE +PARAMETERIZATION/M/S +PARAMETERIZE/D/G/S +PARAMETERLESS +PARAMETRIC +PARAMILITARY +PARAMOUNT +PARANOIA +PARANOID +PARAPET/M/S +PARAPHRASE/D/G/S +PARASITE/M/S +PARASITIC/S +PARCEL/D/G/S +PARCH/D +PARCHMENT +PARDON/D/R/Z/G/S +PARDONABLE +PARDONABLY +PARE/G/J/S +PARENT/M/S +PARENTAGE +PARENTAL +PARENTHESES +PARENTHESIS +PARENTHESIZED +PARENTHETICAL/Y +PARENTHOOD +PARISH/M/S +PARITY +PARK/D/R/Z/G/S +PARLIAMENT/M/S +PARLIAMENTARY +PARLOR/M/S +PAROLE/D/G/S +PARROT/G/S +PARRY/D +PARSE/D/R/Z/G/J/S +PARSIMONY +PARSLEY +PARSON/M/S +PART/D/R/Z/G/Y/J/S +PARTAKE/R/G/S +PARTIAL/Y +PARTIALITY +PARTICIPANT/M/S +PARTICIPATE/D/G/N/S +PARTICLE/M/S +PARTICULAR/Y/S +PARTISAN/M/S +PARTITION/D/G/S +PARTNER/D/S +PARTNERSHIP +PARTRIDGE/M/S +PARTY/M/S +PASCAL +PASS +PASSAGE/M/S +PASSAGEWAY +PASSE/D/R/Z/G/N/X/S +PASSENGER/M/S +PASSIONATE/Y +PASSIVE/P/Y +PASSIVITY +PASSPORT/M/S +PASSWORD/M/S +PAST/P/M/S +PASTE/D/G/S +PASTEBOARD +PASTIME/M/S +PASTOR/M/S +PASTORAL +PASTRY +PASTURE/M/S +PAT/S +PATCH/D/G/S +PATCHWORK +PATENT/D/R/Z/G/Y/S +PATENTABLE +PATERNAL/Y +PATHETIC +PATHOLOGICAL +PATHOLOGY +PATHOS +PATHS +PATHWAY/M/S +PATIENCE +PATIENT/Y/S +PATRIARCH +PATRIARCHS +PATRICIAN/M/S +PATRIOT/M/S +PATRIOTIC +PATRIOTISM +PATROL/M/S +PATRON/M/S +PATRONAGE +PATRONIZE/D/G/S +PATTER/D/G/J/S +PATTERN/D/G/S +PATTY/M/S +PAUCITY +PAUL/M +PAUSE/D/G/S +PAVE/D/G/S +PAVEMENT/M/S +PAVILION/M/S +PAW/G/S +PAWN/M/S +PAY/G/S +PAYABLE +PAYCHECK/M/S +PAYER/M/S +PAYMENT/M/S +PAYOFF/M/S +PAYROLL +PC +PDP +PEA/M/S +PEACE +PEACEABLE +PEACEFUL/P/Y +PEACH/M/S +PEACOCK/M/S +PEAK/D/S +PEAL/D/G/S +PEANUT/M/S +PEAR/Y/S +PEARL/M/S +PEASANT/M/S +PEASANTRY +PEAT +PEBBLE/M/S +PECK/D/G/S +PECULIAR/Y +PECULIARITY/M/S +PEDAGOGIC +PEDAGOGICAL +PEDANTIC +PEDDLER/M/S +PEDESTAL +PEDESTRIAN/M/S +PEDIATRIC/S +PEEK/D/G/S +PEEL/D/G/S +PEEP/D/R/G/S +PEER/D/G/S +PEERLESS +PEG/M/S +PELT/G/S +PEN +PENALIZE/D/G/S +PENALTY/M/S +PENANCE +PENCE +PENCIL/D/S +PEND/D/G/S +PENDULUM/M/S +PENETRATE/D/G/N/X/V/S +PENETRATINGLY +PENETRATOR/M/S +PENGUIN/M/S +PENINSULA/M/S +PENITENT +PENITENTIARY +PENNED +PENNILESS +PENNING +PENNSYLVANIA +PENNY/M/S +PENS/V +PENSION/R/S +PENT +PENTAGON/M/S +PEOPLE/D/M/S +PEP +PEPPER/D/G/S +PER +PERCEIVABLE +PERCEIVABLY +PERCEIVE/D/R/Z/G/S +PERCENT/S +PERCENTAGE/S +PERCENTILE/S +PERCEPTIBLE +PERCEPTIBLY +PERCEPTION/S +PERCEPTIVE/Y +PERCEPTRON/S +PERCEPTUAL/Y +PERCH/D/G/S +PERCHANCE +PERCUSSION +PERCUTANEOUS +PEREMPTORY +PERENNIAL/Y +PERFECT/P/D/G/Y/S +PERFECTION +PERFECTIONIST/M/S +PERFORCE +PERFORM/D/R/Z/G/S +PERFORMANCE/M/S +PERFUME/D/G/S +PERHAPS +PERIL/M/S +PERILOUS/Y +PERIMETER/S +PERIOD/M/S +PERIODIC +PERIODICAL/Y/S +PERIPHERAL/Y/S +PERIPHERY/M/S +PERISH/D/R/Z/G/S +PERISHABLE/M/S +PERMANENCE +PERMANENT/Y +PERMEATE/D/G/N/S +PERMISSIBILITY +PERMISSIBLE +PERMISSIBLY +PERMISSION/S +PERMISSIVE/Y +PERMIT/M/S +PERMITTED +PERMITTING +PERMUTATION/M/S +PERMUTE/D/G/S +PERPENDICULAR/Y/S +PERPETRATE/D/G/N/X/S +PERPETRATOR/M/S +PERPETUAL/Y +PERPETUATE/D/G/N/S +PERPLEX/D/G +PERPLEXITY +PERSECUTE/D/G/N/S +PERSECUTOR/M/S +PERSEVERANCE +PERSEVERE/D/G/S +PERSIST/D/G/S +PERSISTENCE +PERSISTENT/Y +PERSON/M/S +PERSONAGE/M/S +PERSONAL/Y +PERSONALITY/M/S +PERSONALIZATION +PERSONALIZE/D/G/S +PERSONIFY/D/G/N/S +PERSONNEL +PERSPECTIVE/M/S +PERSPICUOUS/Y +PERSPIRATION +PERSUADABLE +PERSUADE/D/R/Z/G/S +PERSUASION/M/S +PERSUASIVE/P/Y +PERTAIN/D/G/S +PERTINENT +PERTURB/D +PERTURBATION/M/S +PERUSAL +PERUSE/D/R/Z/G/S +PERVADE/D/G/S +PERVASIVE/Y +PERVERT/D/S +PESSIMISTIC +PEST/R/S +PESTILENCE +PET/R/Z/S +PETAL/M/S +PETITION/D/R/G/S +PETROLEUM +PETTED +PETTER/M/S +PETTICOAT/M/S +PETTING +PETTY/P +PEW/M/S +PEWTER +PHANTOM/M/S +PHASE/D/R/Z/G/S +PHEASANT/M/S +PHENOMENA +PHENOMENAL/Y +PHENOMENOLOGICAL/Y +PHENOMENOLOGY/S +PHENOMENON +PHILADELPHIA +PHILOSOPHER/M/S +PHILOSOPHIC +PHILOSOPHICAL/Y +PHILOSOPHIZE/D/R/Z/G/S +PHILOSOPHY/M/S +PHONE/D/G/S +PHONEME/M/S +PHONEMIC +PHONETIC/S +PHONOGRAPH +PHONOGRAPHS +PHOSPHATE/M/S +PHOSPHORIC +PHOTO/M/S +PHOTOCOPY/D/G/S +PHOTOGRAPH/D/R/Z/G +PHOTOGRAPHIC +PHOTOGRAPHS +PHOTOGRAPHY +PHOTOTYPESETTER/S +PHRASE/D/G/J/S +PHYLA +PHYLUM +PHYSIC/S +PHYSICAL/P/Y/S +PHYSICIAN/M/S +PHYSICIST/M/S +PHYSIOLOGICAL/Y +PHYSIOLOGY +PHYSIQUE +PI +PIANO/M/S +PIAZZA/M/S +PICAYUNE +PICK/D/R/Z/G/J/S +PICKET/D/R/Z/G/S +PICKLE/D/G/S +PICKUP/M/S +PICKY +PICNIC/M/S +PICTORIAL/Y +PICTURE/D/G/S +PICTURESQUE/P +PIE/R/Z/S +PIECE/D/G/S +PIECEMEAL +PIECEWISE +PIERCE/D/G/S +PIETY +PIG/M/S +PIGEON/M/S +PIGMENT/D/S +PIKE/R/S +PILE/D/Z/G/J/S +PILFERAGE +PILGRIM/M/S +PILGRIMAGE/M/S +PILL/M/S +PILLAGE/D +PILLAR/D/S +PILLOW/M/S +PILOT/G/S +PIN/M/S +PINCH/D/G/S +PINE/D/G/N/S +PINEAPPLE/M/S +PING +PINK/P/T/R/Y/S +PINNACLE/M/S +PINNED +PINNING/S +PINPOINT/G/S +PINT/M/S +PIONEER/D/G/S +PIOUS/Y +PIPE/D/R/Z/G/S +PIPELINE/D/G/S +PIQUE +PIRATE/M/S +PISTIL/M/S +PISTOL/M/S +PISTON/M/S +PIT/M/S +PITCH/D/R/Z/G/S +PITEOUS/Y +PITFALL/M/S +PITH/D/G/S +PITHY/P/T/R +PITIABLE +PITIFUL/Y +PITILESS/Y +PITTED +PITTSBURGH/M +PITY/D/R/Z/G/S +PITYINGLY +PIVOT/G/S +PIVOTAL +PIXEL/S +PLACARD/M/S +PLACE/D/R/G/S +PLACEMENT/M/S +PLACID/Y +PLAGUE/D/G/S +PLAID/M/S +PLAIN/P/T/R/Y/S +PLAINTIFF/M/S +PLAINTIVE/P/Y +PLAIT/M/S +PLAN/M/S +PLANAR +PLANARITY +PLANE'S +PLANE/D/R/Z/G/S +PLANET/M/S +PLANETARY +PLANK/G/S +PLANNED +PLANNER/M/S +PLANNING +PLANT/D/R/Z/G/J/S +PLANTATION/M/S +PLASMA +PLASTER/D/R/G/S +PLASTIC/S +PLASTICITY +PLATE/D/G/S +PLATEAU/M/S +PLATELET/M/S +PLATEN/M/S +PLATFORM/M/S +PLATINUM +PLATO +PLATTER/M/S +PLAUSIBILITY +PLAUSIBLE +PLAY/D/G/S +PLAYABLE +PLAYER/M/S +PLAYFUL/P/Y +PLAYGROUND/M/S +PLAYMATE/M/S +PLAYTHING/M/S +PLAYWRIGHT/M/S +PLAZA +PLEA/M/S +PLEAD/D/R/G/S +PLEASANT/P/Y +PLEASE/D/G/S +PLEASINGLY +PLEASURE/S +PLEBEIAN +PLEBISCITE/M/S +PLEDGE/D/S +PLENARY +PLENTEOUS +PLENTIFUL/Y +PLENTY +PLEURISY +PLIGHT +PLOD +PLOT/M/S +PLOTTED +PLOTTER/M/S +PLOTTING +PLOUGH +PLOUGHMAN +PLOW/D/R/G/S +PLOWMAN +PLOY/M/S +PLUCK/D/G +PLUCKY +PLUG/M/S +PLUGGED +PLUGGING +PLUM/M/S +PLUMAGE +PLUMB/D/M/G/S +PLUME/D/S +PLUMMETING +PLUMP/P/D +PLUNDER/D/R/Z/G/S +PLUNGE/D/R/Z/G/S +PLURAL/S +PLURALITY +PLUS +PLUSH +PLY/D/Z/S +PNEUMONIA +POACH/R/S +POCKET/D/G/S +POCKETBOOK/M/S +POD/M/S +POEM/M/S +POET/M/S +POETIC/S +POETICAL/Y +POETRY/M/S +POINT/D/R/Z/G/S +POINTEDLY +POINTLESS +POINTY +POISE/D/S +POISON/D/R/G/S +POISONOUS/P +POKE/D/R/G/S +POLAND +POLAR +POLARITY/M/S +POLE/D/G/S +POLEMIC/S +POLICE/D/M/G/S +POLICEMAN +POLICEMEN +POLICY/M/S +POLISH/D/R/Z/G/S +POLITE/P/T/R/Y +POLITIC/S +POLITICAL/Y +POLITICIAN/M/S +POLL/D/G/N/S +POLLUTANT/S +POLLUTE/D/G/N/S +POLO +POLYGON/S +POLYGONAL +POLYHEDRA +POLYHEDRON +POLYLINE +POLYMER/M/S +POLYMORPHIC +POLYMORPHISM +POLYNOMIAL/M/S +POLYTECHNIC +POMP +POMPOUS/P/Y +POND/R/S +PONDER/D/G/S +PONDEROUS +PONY/M/S +POOL/D/G/S +POOR/P/T/R/Y +POP/M/S +POPLAR +POPPED +POPPING +POPPY/M/S +POPULACE +POPULAR/Y +POPULARITY +POPULARIZATION +POPULARIZE/D/G/S +POPULATE/D/G/N/X/S +POPULOUS/P +PORCELAIN +PORCH/M/S +PORCUPINE/M/S +PORE/D/G/S +PORK/R +PORNOGRAPHIC +PORRIDGE +PORT/R/Z/Y/S/D/G +PORTABILITY +PORTABLE +PORTAL/M/S +PORTEND/D/G/S +PORTION/M/S +PORTRAIT/M/S +PORTRAY/D/G/S +PORTUGUESE +POSE/D/R/Z/G/S +POSIT/D/G/S +POSITION/D/G/S +POSITIONAL +POSITIVE/P/Y/S +POSSESS/D/G/V/S +POSSESSION/M/S +POSSESSIONAL +POSSESSIVE/P/Y +POSSESSOR/M/S +POSSIBILITY/M/S +POSSIBLE +POSSIBLY +POSSUM/M/S +POST/D/R/Z/G/S +POSTAGE +POSTAL +POSTCONDITION +POSTDOCTORAL +POSTERIOR +POSTERITY +POSTMAN +POSTMASTER/M/S +POSTMODERNISM +POSTOFFICE/M/S +POSTPONE/D/G +POSTSCRIPT/M/S +POSTSTRUCTURALISM +POSTSTRUCTURALIST +POSTULATE/D/G/N/X/S +POSTURE/M/S +POT/M/S +POTASH +POTASSIUM +POTATO +POTATOES +POTENT +POTENTATE/M/S +POTENTIAL/Y/S +POTENTIALITY/S +POTENTIATING +POTENTIOMETER/M/S +POTTED +POTTER/M/S +POTTERY +POTTING +POUCH/M/S +POUGHKEEPSIE +POULTRY +POUNCE/D/G/S +POUND/D/R/Z/G/S +POUR/D/R/Z/G/S +POUT/D/G/S +POVERTY +POWDER/D/G/S +POWER/D/G/S +POWERFUL/P/Y +POWERLESS/P/Y +POWERSET/M/S +POX +PRACTICABLE +PRACTICABLY +PRACTICAL/Y +PRACTICALITY +PRACTICE/D/G/S +PRACTISE/D/G +PRACTITIONER/M/S +PRAGMATIC/S +PRAGMATICALLY +PRAIRIE +PRAISE/D/R/Z/G/S +PRAISINGLY +PRANCE/D/R/G +PRANK/M/S +PRATE +PRAY/D/G +PRAYER/M/S +PRE +PREACH/D/R/Z/G/S +PREAMBLE +PREASSIGN/D/G/S +PRECARIOUS/P/Y +PRECAUTION/M/S +PRECEDE/D/G/S +PRECEDENCE/M/S +PRECEDENT/D/S +PRECEPT/M/S +PRECINCT/M/S +PRECIOUS/P/Y +PRECIPICE +PRECIPITATE/P/D/G/N/Y/S +PRECIPITOUS/Y +PRECISE/P/N/X/Y +PRECLUDE/D/G/S +PRECOCIOUS/Y +PRECONCEIVE/D +PRECONCEPTION/M/S +PRECONDITION/D/S +PRECURSOR/M/S +PREDATE/D/G/S +PREDECESSOR/M/S +PREDEFINE/D/G/S +PREDEFINITION/M/S +PREDETERMINE/D/G/S +PREDICAMENT +PREDICATE/D/G/N/X/S +PREDICT/D/G/V/S +PREDICTABILITY +PREDICTABLE +PREDICTABLY +PREDICTION/M/S +PREDISPOSE/D/G +PREDOMINANT/Y +PREDOMINATE/D/G/N/Y/S +PREEMPT/D/G/V/S +PREEMPTION +PREFACE/D/G/S +PREFER/S +PREFERABLE +PREFERABLY +PREFERENCE/M/S +PREFERENTIAL/Y +PREFERRED +PREFERRING +PREFIX/D/S +PREGNANT +PREHISTORIC +PREINITIALIZE/D/G/S +PREJUDGE/D +PREJUDICE/D/S +PRELATE +PRELIMINARY/S +PRELUDE/M/S +PREMATURE/Y +PREMATURITY +PREMEDITATED +PREMIER/M/S +PREMISE/M/S +PREMIUM/M/S +PREOCCUPATION +PREOCCUPY/D/S +PREPARATION/M/S +PREPARATIVE/M/S +PREPARATORY +PREPARE/D/G/S +PREPOSITION/M/S +PREPOSITIONAL +PREPOSTEROUS/Y +PREPROCESS/D/G +PREPRODUCTION +PREPROGRAMMED +PREREQUISITE/M/S +PREROGATIVE/M/S +PRESBYTERIAN +PRESCRIBE/D/S +PRESCRIPTION/M/S +PRESCRIPTIVE +PRESELECT/D/G/S +PRESENCE/M/S +PRESENT/P/D/R/G/Y/S +PRESENTATION/M/S +PRESERVATION/S +PRESERVE/D/R/Z/G/S +PRESET +PRESIDE/D/G/S +PRESIDENCY +PRESIDENT/M/S +PRESIDENTIAL +PRESS/D/R/G/J/S +PRESSURE/D/G/S +PRESSURIZE/D +PRESTIGE +PRESTO +PRESUMABLY +PRESUME/D/G/S +PRESUMPTION/M/S +PRESUMPTUOUS/P +PRESUPPOSE/D/G/S +PRESYNAPTIC +PRETEND/D/R/Z/G/S +PRETENSE/N/X/S +PRETENTIOUS/P/Y +PRETEXT/M/S +PRETTILY +PRETTY/P/T/R +PREVAIL/D/G/S +PREVAILINGLY +PREVALENCE +PREVALENT/Y +PREVENT/D/G/V/S +PREVENTABLE +PREVENTABLY +PREVENTION +PREVENTIVES +PREVIEW/D/G/S +PREVIOUS/Y +PREY/D/G/S +PRICE/D/R/Z/G/S +PRICELESS +PRICK/D/G/Y/S +PRIDE/D/G/S +PRIMACY +PRIMARILY +PRIMARY/M/S +PRIME/P/D/R/Z/G/S +PRIMEVAL +PRIMITIVE/P/Y/S +PRIMROSE +PRINCE/Y/S +PRINCESS/M/S +PRINCETON +PRINCIPAL/Y/S +PRINCIPALITY/M/S +PRINCIPLE/D/S +PRINT/D/R/Z/G/S +PRINTABLE +PRINTABLY +PRINTOUT +PRIOR +PRIORI +PRIORITY/M/S +PRIORY +PRISM/M/S +PRISON/R/Z/S +PRISONER'S +PRIVACY/S +PRIVATE/N/X/Y/S +PRIVILEGE/D/S +PRIVY/M/S +PRIZE/D/R/Z/G/S +PRO/M/S +PROBABILISTIC +PROBABILISTICALLY +PROBABILITY/S +PROBABLE +PROBABLY +PROBATE/D/G/N/V/S +PROBE/D/G/J/S +PROBLEM/M/S +PROBLEMATIC +PROBLEMATICAL/Y +PROCEDURAL/Y +PROCEDURE/M/S +PROCEED/D/G/J/S +PROCESS/D/M/G/S +PROCESSION +PROCESSOR/M/S +PROCLAIM/D/R/Z/G/S +PROCLAMATION/M/S +PROCLIVITY/M/S +PROCRASTINATE/D/G/N/S +PROCURE/D/R/Z/G/S +PROCUREMENT/M/S +PRODIGAL/Y +PRODIGIOUS +PRODIGY +PRODUCE/D/R/Z/G/S +PRODUCIBLE +PRODUCT/M/V/S +PRODUCTION/M/S +PRODUCTIVELY +PRODUCTIVITY +PROFANE/Y +PROFESS/D/G/S +PROFESSION/M/S +PROFESSIONAL/Y/S +PROFESSIONALISM +PROFESSOR/M/S +PROFFER/D/S +PROFICIENCY +PROFICIENT/Y +PROFILE/D/G/S +PROFIT/D/G/S/R/M/Z +PROFITABILITY +PROFITABLE +PROFITABLY +PROFITEER/M/S +PROFOUND/T/Y +PROG +PROGENY +PROGRAM/M/S +PROGRAMMABILITY +PROGRAMMABLE +PROGRAMMED +PROGRAMMER/M/S +PROGRAMMING +PROGRESS/D/G/V/S +PROGRESSION/M/S +PROGRESSIVE/Y +PROHIBIT/D/G/V/S +PROHIBITION/M/S +PROHIBITIVELY +PROJECT/D/G/V/S/M +PROJECTION/M/S +PROJECTIVELY +PROJECTOR/M/S +PROLEGOMENA +PROLETARIAT +PROLIFERATE/D/G/N/S +PROLIFIC +PROLOG +PROLOGUE +PROLONG/D/G/S +PROMENADE/M/S +PROMINENCE +PROMINENT/Y +PROMISE/D/G/S +PROMONTORY +PROMOTE/D/R/Z/G/N/X/S +PROMOTIONAL +PROMPT/P/D/T/R/Y/S +PROMPTING/S +PROMULGATE/D/G/N/S +PRONE/P +PRONG/D/S +PRONOUN/M/S +PRONOUNCE/D/G/S +PRONOUNCEABLE +PRONOUNCEMENT/M/S +PRONUNCIATION/M/S +PROOF/M/S +PROP/R/S +PROPAGANDA +PROPAGATE/D/G/N/X/S +PROPEL/S +PROPELLED +PROPELLER/M/S +PROPENSITY +PROPERLY +PROPERNESS +PROPERTY/D/S +PROPHECY/M/S +PROPHESY/D/R/S +PROPHET/M/S +PROPHETIC +PROPITIOUS +PROPONENT/M/S +PROPORTION/D/G/S +PROPORTIONAL/Y +PROPORTIONATELY +PROPORTIONMENT +PROPOSAL/M/S +PROPOSE/D/R/G/S +PROPOSITION/D/G/S +PROPOSITIONAL/Y +PROPOUND/D/G/S +PROPRIETARY +PROPRIETOR/M/S +PROPRIETY +PROPULSION/M/S +PROSE +PROSECUTE/D/G/N/X/S +PROSELYTIZE/D/G/S +PROSODIC/S +PROSPECT/D/G/V/S +PROSPECTION/M/S +PROSPECTIVELY +PROSPECTIVES +PROSPECTOR/M/S +PROSPECTUS +PROSPER/D/G/S +PROSPERITY +PROSPEROUS +PROSTITUTION +PROSTRATE/N +PROTECT/D/G/V/S +PROTECTION/M/S +PROTECTIVELY +PROTECTIVENESS +PROTECTOR/M/S +PROTECTORATE +PROTEGE/M/S +PROTEIN/M/S +PROTEST/D/G/S/R/Z/M +PROTESTATION/S +PROTESTER'S +PROTESTINGLY +PROTESTOR/M/S +PROTOCOL/M/S +PROTON/M/S +PROTOPLASM +PROTOTYPE/D/G/S +PROTOTYPICAL/Y +PROTRUDE/D/G/S +PROTRUSION/M/S +PROVABILITY +PROVABLE +PROVABLY +PROVE/D/R/Z/G/S +PROVEN +PROVERB/M/S +PROVIDE/D/R/Z/G/S +PROVIDENCE +PROVINCE/M/S +PROVINCIAL +PROVINCIALISM +PROVISION/D/G/S +PROVISIONAL/Y +PROVOCATION +PROVOKE/D/S +PROW/M/S +PROWESS +PROWL/D/R/Z/G +PROXIMAL +PROXIMATE +PROXIMITY +PRUDENCE +PRUDENT/Y +PRUNE/D/R/Z/G/S +PRY/T/G +PSALM/M/S +PSEUDO +PSYCHE/M/S +PSYCHIATRIST/M/S +PSYCHIATRY +PSYCHOLOGICAL/Y +PSYCHOLOGIST/M/S +PSYCHOLOGY +PSYCHOMETRIC +PSYCHOSOCIAL +PUB/M/S +PUBLIC/Y +PUBLICATION/M/S +PUBLICITY +PUBLICIZE/D/G/S +PUBLISH/D/R/Z/G/S +PUCKER/D/G/S +PUDDING/M/S +PUDDLE/G/S +PUFF/D/G/S +PULL/D/R/G/J/S +PULLEY/M/S +PULMONARY +PULP/G +PULPIT/M/S +PULSE/D/G/S +PUMP/D/G/S +PUMPKIN/M/S +PUN/M/S +PUNCH/D/R/G/S +PUNCTUAL/Y +PUNCTUATION +PUNCTURE/D/M/G/S +PUNISH/D/G/S +PUNISHABLE +PUNISHMENT/M/S +PUNITIVE +PUNT/D/G/S +PUNY +PUP/M/S +PUPA +PUPIL/M/S +PUPPET/M/S +PUPPY/M/S +PURCHASABLE +PURCHASE/D/R/Z/G/S +PURCHASEABLE +PURE/T/R/Y +PURGE/D/G/S +PURIFY/D/R/Z/G/N/X/S +PURITY +PURPLE/T/R +PURPORT/D/R/Z/G/S +PURPORTEDLY +PURPOSE/D/V/Y/S +PURPOSEFUL/Y +PURR/D/G/S +PURSE/D/R/S +PURSUE/D/R/Z/G/S +PURSUIT/M/S +PURVIEW +PUSHDOWN +PUSS +PUSSY +PUT/S +PUTRID +PUTTER/G/S +PUTTING +PUZZLE/D/R/Z/G/J/S +PUZZLEMENT +PYGMY/M/S +PYRAMID/M/S +QUACK/D/S +QUADRANT/M/S +QUADRATIC/S +QUADRATICAL/Y +QUADRATURE/M/S +QUADRUPLE/D/G/S +QUAGMIRE/M/S +QUAIL/M/S +QUAINT/P/Y +QUAKE/D/R/Z/G/S +QUALIFY/D/R/Z/G/N/X/S +QUALITATIVE/Y +QUALITY/M/S +QUANDARY/M/S +QUANTA +QUANTIFIABLE +QUANTIFY/D/R/Z/G/N/X/S +QUANTITATIVE/Y +QUANTITY/M/S +QUANTIZATION +QUANTIZE/D/G/S +QUANTUM +QUARANTINE/M/S +QUARREL/D/G/S +QUARRELSOME +QUARRY/M/S +QUART/Z/S +QUARTER/D/G/Y/S +QUARTET/M/S +QUARTZ +QUASH/D/G/S +QUASI +QUAVER/D/G/S +QUAY +QUEEN/M/Y/S +QUEER/P/T/R/Y +QUELL/G +QUENCH/D/G/S +QUERY/D/G/S +QUEST/D/R/Z/G/S +QUESTION/D/R/Z/G/J/S +QUESTIONABLE +QUESTIONABLY +QUESTIONINGLY +QUESTIONNAIRE/M/S +QUEUE/D/R/Z/G/S +QUICK/P/T/R/N/X/Y +QUICKENED +QUICKENING +QUICKSILVER +QUIESCENT +QUIET/P/D/T/R/G/Y/S +QUIETUDE +QUILL +QUILT/D/G/S +QUININE +QUIT/S +QUITE +QUITTER/M/S +QUITTING +QUIVER/D/G/S +QUIXOTE +QUIZ +QUIZZED +QUIZZES +QUIZZING +QUO/H +QUOTA/M/S +QUOTATION/M/S +QUOTE/D/G/S +QUOTIENT +RABBIT/M/S +RABBLE +RACCOON/M/S +RACE/D/R/Z/G/S +RACIAL/Y +RACK/D/G/S +RACKET/M/S +RACKETEER/G/S +RADAR/M/S +RADIAL/Y +RADIAN/S +RADIANCE +RADIANT/Y +RADIATE/D/G/N/X/S +RADIATOR/M/S +RADICAL/Y/S +RADII +RADIO/D/G/S +RADIOLOGY +RADISH/M/S +RADIUS +RADIX +RAFT/R/Z/S +RAG/M/S +RAGE/D/G/S +RAGGED/P/Y +RAID/D/R/Z/G/S +RAIL/D/R/Z/G/S +RAILROAD/D/R/Z/G/S +RAILWAY/M/S +RAIMENT +RAIN/D/G/S +RAINBOW +RAINCOAT/M/S +RAINDROP/M/S +RAINFALL +RAINY/T/R +RAISE/D/R/Z/G/S +RAISIN +RAKE/D/G/S +RALLY/D/G/S +RAM/M/S +RAMBLE/R/G/J/S +RAMIFICATION/M/S +RAMP/M/S +RAMPART +RAN +RANCH/D/R/Z/G/S +RANDOLPH/M +RANDOM/P/Y +RANDY/M +RANG +RANGE/D/R/Z/G/S +RANK/P/D/T/Y/S +RANKER/M/S +RANKING/M/S +RANSACK/D/G/S +RANSOM/R/G/S +RANT/D/R/Z/G/S +RAP/M/S +RAPE/D/R/G/S +RAPID/Y/S +RAPIDITY +RAPT/Y +RAPTURE/M/S +RAPTUROUS +RARE/P/T/R/Y +RARITY/M/S +RASCAL/Y/S +RASH/P/R/Y +RASP/D/G/S +RASPBERRY +RASTER +RASTEROP +RAT/M/S +RATE/D/R/Z/G/N/X/J/S +RATHER +RATIFY/D/G/N/S +RATIO/M/S +RATIONAL/Y +RATIONALE/M/S +RATIONALITY/S +RATIONALIZE/D/G/S +RATTLE/D/R/Z/G/S +RATTLESNAKE/M/S +RAVAGE/D/R/Z/G/S +RAVE/D/G/J/S +RAVEN/G/S +RAVENOUS/Y +RAVINE/M/S +RAW/P/T/R/Y +RAY/M/S +RAZOR/M/S +RE/D/Y/J +REABBREVIATE/D/G/S +REACH/D/R/G/S +REACHABLE +REACHABLY +REACT/D/G/V/S +REACTION/M/S +REACTIONARY/M/S +REACTIVATE/D/G/N/S +REACTIVELY +REACTIVITY +REACTOR/M/S +READ/R/Z/G/J/S +READABILITY +READABLE +READILY +READJUSTED +READJUSTMENT +READOUT/M/S +READY/P/D/T/R/G/S +REAL/P/S/T/Y +REALIGN/D/G/S +REALISM +REALIST/M/S +REALISTIC +REALISTICALLY +REALITY/S +REALIZABLE +REALIZABLY +REALIZATION/M/S +REALIZE/D/G/S +REALM/M/S +REANALYZE/G/S +REAP/D/R/G/S +REAPPEAR/D/G/S +REAPPRAISAL/S +REAR/D/G/S +REARRANGE/D/G/S +REARRANGEABLE +REARRANGEMENT/M/S +REARREST/D +REASON/D/R/G/J/S +REASONABLE/P +REASONABLY +REASSEMBLE/D/G/S +REASSESSMENT/M/S +REASSIGN/D/G/S +REASSIGNMENT/M/S +REASSURE/D/G/S +REAWAKEN/D/G/S +REBATE/M/S +REBEL/M/S +REBELLION/M/S +REBELLIOUS/P/Y +REBOUND/D/G/S +REBROADCAST +REBUFF/D +REBUILD/G/S +REBUILT +REBUKE/D/G/S +REBUTTAL +RECALCULATE/D/G/N/X/S +RECALL/D/G/S +RECAPITULATE/D/N/S +RECAPTURE/D/G/S +RECAST/G/S +RECEDE/D/G/S +RECEIPT/M/S +RECEIVABLE +RECEIVE/D/R/Z/G/S +RECENT/P/Y +RECEPTACLE/M/S +RECEPTION/M/S +RECEPTIVE/P/Y +RECEPTIVITY +RECESS/D/V/S +RECESSION +RECIPE/M/S +RECIPIENT/M/S +RECIPROCAL/Y +RECIPROCATE/D/G/N/S +RECIPROCITY +RECIRCULATE/D/G/S +RECITAL/M/S +RECITATION/M/S +RECITE/D/R/G/S +RECKLESS/P/Y +RECKON/D/R/G/J/S +RECLAIM/D/R/Z/G/S +RECLAIMABLE +RECLAMATION/S +RECLASSIFY/D/G/N/S +RECLINE/G +RECODE/D/G/S +RECOGNITION/M/S +RECOGNIZABILITY +RECOGNIZABLE +RECOGNIZABLY +RECOGNIZE/D/R/Z/G/S +RECOIL/D/G/S +RECOLLECT/D/G +RECOLLECTION/M/S +RECOMBINE/D/G/S +RECOMMEND/D/R/G/S +RECOMMENDATION/M/S +RECOMPENSE +RECOMPILATION +RECOMPILE/D/G +RECOMPUTE/D/G/S +RECONCILE/D/R/G/S +RECONCILIATION +RECONFIGURABLE +RECONFIGURATION/M/S +RECONFIGURE/D/R/G/S +RECONNECT/D/G/S +RECONNECTION +RECONSIDER/D/G/S +RECONSIDERATION +RECONSTRUCT/D/G/S +RECONSTRUCTION +RECORD/D/R/Z/G/J/S +RECOUNT/D/G/S +RECOURSE +RECOVER/D/G/S +RECOVERABLE +RECOVERY/M/S +RECREATE/D/G/N/X/V/S +RECREATION/S +RECREATIONAL +RECRUIT/D/R/M/G/S +RECRUITMENT +RECTA +RECTANGLE/M/S +RECTANGULAR +RECTIFY +RECTOR/M/S +RECTUM/M/S +RECUR/S +RECURRENCE/M/S +RECURRENT/Y +RECURRING +RECURSE/D/G/N/S +RECURSION/M/S +RECURSIVE/Y +RECYCLABLE +RECYCLE/D/G/S +RED/P/Y/S +REDBREAST +REDDEN/D +REDDER +REDDEST +REDDISH/P +REDECLARE/D/G/S +REDEEM/D/R/Z/G/S +REDEFINE/D/G/S +REDEFINITION/M/S +REDEMPTION +REDESIGN/D/G/S +REDEVELOPMENT +REDIRECT/D/G +REDIRECTING +REDIRECTION/S +REDISPLAY/D/G/S +REDISTRIBUTE/D/G/S +REDONE +REDOUBLE/D +REDRAW/G +REDRAWN +REDRESS/D/G/S +REDUCE/D/R/Z/G/S +REDUCIBILITY +REDUCIBLE +REDUCIBLY +REDUCTION/M/S +REDUNDANCY/S +REDUNDANT/Y +REED/M/S +REEDUCATION +REEF/R/S +REEL/D/R/G/S +REELECT/D/G/S +REEMPHASIZE/D/G/S +REENFORCEMENT +REENTER/D/G/S +REENTRANT +REESTABLISH/D/G/S +REEVALUATE/D/G/N/S +REEXAMINE/D/G/S +REFER/S +REFEREE/D/S +REFEREEING +REFERENCE/D/R/G/S +REFERENDUM +REFERENT/M/S +REFERENTIAL/Y +REFERENTIALITY +REFERRAL/M/S +REFERRED +REFERRING +REFILL/D/G/S +REFILLABLE +REFINE/D/R/G/S +REFINEMENT/M/S +REFLECT/D/G/V/S +REFLECTION/M/S +REFLECTIVELY +REFLECTIVITY +REFLECTOR/M/S +REFLEX/M/S +REFLEXIVE/P/Y +REFLEXIVITY +REFORM/D/R/Z/G/S +REFORMABLE +REFORMAT/S +REFORMATION +REFORMATTED +REFORMATTING +REFORMULATE/D/G/N/S +REFRACTORY +REFRAIN/D/G/S +REFRESH/D/R/Z/G/S +REFRESHINGLY +REFRESHMENT/M/S +REFRIGERATOR/M/S +REFUEL/D/G/S +REFUGE +REFUGEE/M/S +REFUSAL +REFUSE/D/G/S +REFUTABLE +REFUTATION +REFUTE/D/R/G/S +REGAIN/D/G/S +REGAL/D/Y +REGARD/D/G/S +REGARDLESS +REGENERATE/D/G/N/V/S +REGENT/M/S +REGIME/M/S +REGIMEN +REGIMENT/D/S +REGION/M/S +REGIONAL/Y +REGISTER/D/G/S +REGISTRATION/M/S +REGRESS/D/G/V/S +REGRESSION/M/S +REGRET/S +REGRETFUL/Y +REGRETTABLE +REGRETTABLY +REGRETTED +REGRETTING +REGROUP/D/G +REGULAR/Y/S +REGULARITY/S +REGULATE/D/G/N/X/V/S +REGULATOR/M/S +REHABILITATE/D/G/N +REHEARSAL/M/S +REHEARSE/D/R/G/S +REIGN/D/G/S +REIMBURSED +REIMBURSEMENT/M/S +REIMPLEMENT/D/G +REIN/D/S +REINCARNATE/D/N +REINDEER +REINFORCE/D/R/G/S +REINFORCEMENT/M/S +REINITIALIZE/D/G +REINSERT/D/G/S +REINSTATE/D/G/S +REINSTATEMENT +REINTERPRET/D/G/S +REINTRODUCE/D/G/S +REINVENT/D/G/S +REITERATE/D/G/N/S +REJECT/D/G/S +REJECTION/M/S +REJECTOR/M/S +REJOICE/D/R/G/S +REJOIN/D/G/S +RELABEL/S/D/G/R/Z +RELAPSE +RELATE/D/R/G/N/X/S +RELATIONAL/Y +RELATIONSHIP/M/S +RELATIVE/P/Y/S +RELATIVISM +RELATIVISTIC +RELATIVISTICALLY +RELATIVITY +RELAX/D/R/G/S +RELAXATION/M/S +RELAY/D/G/S +RELEARN/D/G +RELEASE/D/G/S +RELEGATE/D/G/S +RELENT/D/G/S +RELENTLESS/P/Y +RELEVANCE/S +RELEVANT/Y +RELIABILITY +RELIABLE/P +RELIABLY +RELIANCE +RELIC/M/S +RELIEF +RELIEVE/D/R/Z/G/S +RELIGION/M/S +RELIGIOUS/P/Y +RELINQUISH/D/G/S +RELISH/D/G/S +RELIVE/G/S +RELOAD/D/R/G/S +RELOCATE/D/G/N/X/S +RELUCTANCE +RELUCTANT/Y +RELY/D/G/S +REMAIN/D/G/S +REMAINDER/M/S +REMARK/D/G/S +REMARKABLE/P +REMARKABLY +REMEDIAL +REMEDY/D/G/S +REMEMBER/D/G/S +REMEMBRANCE/M/S +REMIND/D/R/Z/G/S +REMINISCENCE/M/S +REMINISCENT/Y +REMITTANCE +REMNANT/M/S +REMODEL/D/G/S +REMONSTRATE/D/G/N/V/S +REMORSE +REMOTE/P/T/Y +REMOVABLE +REMOVAL/M/S +REMOVE/D/R/G/S +RENAISSANCE +RENAL +RENAME/D/G/S +REND/Z/G/S +RENDER/D/G/J/S +RENDEZVOUS +RENDITION/M/S +RENEW/D/R/G/S +RENEWAL +RENOUNCE/G/S +RENOWN/D +RENT/D/G/S +RENTAL/M/S +RENUMBER/G/S +REOPEN/D/G/S +REORDER/D/G/S +REORGANIZATION/M/S +REORGANIZE/D/G/S +REPAID +REPAIR/D/R/G/S +REPAIRMAN +REPARATION/M/S +REPAST/M/S +REPAY/G/S +REPEAL/D/R/G/S +REPEAT/D/R/Z/G/S +REPEATABLE +REPEATEDLY +REPEL/S +REPENT/D/G/S +REPENTANCE +REPERCUSSION/M/S +REPERTOIRE +REPETITION/M/S +REPETITIVE/P/Y +REPHRASE/D/G/S +REPINE +REPLACE/D/R/G/S +REPLACEABLE +REPLACEMENT/M/S +REPLAY/D/G/S +REPLENISH/D/G/S +REPLETE/P/N +REPLICA +REPLICATE/D/G/N/S +REPLY/D/G/N/X/S +REPORT/D/R/Z/G/S +REPORTEDLY +REPOSE/D/G/S +REPOSITION/D/G/S +REPOSITORY/M/S +REPRESENT/D/G/S +REPRESENTABLE +REPRESENTABLY +REPRESENTATION/M/S +REPRESENTATIONAL/Y +REPRESENTATIVE/P/Y/S +REPRESS/D/G/V/S +REPRESSION/M/S +REPRIEVE/D/G/S +REPRINT/D/G/S +REPRISAL/M/S +REPROACH/D/G/S +REPRODUCE/D/R/Z/G/S +REPRODUCIBILITY/S +REPRODUCIBLE +REPRODUCIBLY +REPRODUCTION/M/S +REPROGRAM/S +REPROGRAMMED +REPROGRAMMING +REPROOF +REPROVE/R +REPTILE/M/S +REPUBLIC/M/S +REPUBLICAN/M/S +REPUDIATE/D/G/N/X/S +REPULSE/D/G/N/X/V/S +REPUTABLE +REPUTABLY +REPUTATION/M/S +REPUTE/D/S +REPUTEDLY +REQUEST/D/R/Z/G/S +REQUIRE/D/G/S +REQUIREMENT/M/S +REQUISITE/X/S +REQUISITION/D/G/S +REREAD +REROUTE/D/G/S +RESCUE/D/R/Z/G/S +RESEARCH/D/R/Z/G/S +RESELECT/D/G/S +RESEMBLANCE/M/S +RESEMBLE/D/G/S +RESENT/D/G/S +RESENTFUL/Y +RESENTMENT +RESERVATION/M/S +RESERVE/D/R/G/S +RESERVOIR/M/S +RESET/S +RESETTING/S +RESHAPE/D/G +RESIDE/D/G/S +RESIDENCE/M/S +RESIDENT/M/S +RESIDENTIAL/Y +RESIDUE/M/S +RESIGN/D/G/S +RESIGNATION/M/S +RESIN/M/S +RESIST/D/G/V/S +RESISTANCE/S +RESISTANT/Y +RESISTIBLE +RESISTIBLY +RESISTIVITY +RESISTOR/M/S +RESIZE/D/G +RESOLUTE/P/N/X/Y +RESOLVABLE +RESOLVE/D/R/Z/G/S +RESONANCE/S +RESONANT +RESORT/D/G/S +RESOUND/G/S +RESOURCE/M/S +RESOURCEFUL/P/Y +RESPECT/D/R/G/V/S +RESPECTABILITY +RESPECTABLE +RESPECTABLY +RESPECTFUL/P/Y +RESPECTIVELY +RESPIRATION +RESPITE +RESPLENDENT/Y +RESPOND/D/R/G/S +RESPONDENT/M/S +RESPONSE/V/S +RESPONSIBILITY/S +RESPONSIBLE/P +RESPONSIBLY +RESPONSIVELY +RESPONSIVENESS +REST/D/G/V/S +RESTART/D/G/S +RESTATE/D/G/S +RESTATEMENT +RESTAURANT/M/S +RESTFUL/P/Y +RESTLESS/P/Y +RESTORATION/M/S +RESTORE/D/R/Z/G/S +RESTRAIN/D/R/Z/G/S +RESTRAINT/M/S +RESTRICT/D/G/V/S +RESTRICTION/M/S +RESTRICTIVELY +RESTRUCTURE/D/G/S +RESULT/D/G/S +RESULTANT/Y/S +RESUMABLE +RESUME/D/G/S +RESUMPTION/M/S +RESURRECT/D/G/S +RESURRECTION/M/S +RESURRECTOR/S +RETAIL/R/Z/G +RETAIN/D/R/Z/G/S +RETAINMENT +RETALIATION +RETARD/D/R/G +RETENTION/S +RETENTIVE/P/Y +RETHINK +RETICLE/M/S +RETICULAR +RETICULATE/D/G/N/Y/S +RETINA/M/S +RETINAL +RETINUE +RETIRE/D/G/S +RETIREMENT/M/S +RETORT/D/S +RETRACE/D/G +RETRACT/D/G/S +RETRACTION/S +RETRAIN/D/G/S +RETRANSMISSION/M/S +RETRANSMIT/S +RETRANSMITTED +RETRANSMITTING +RETREAT/D/G/S +RETRIEVABLE +RETRIEVAL/M/S +RETRIEVE/D/R/Z/G/S +RETROACTIVE +RETROACTIVELY +RETROSPECT/V +RETROSPECTION +RETRY/D/R/Z/G/S +RETURN/D/R/G/S +RETURNABLE +RETYPE/D/G/S +REUNION/M/S +REUNITE/D/G +REUSABILITY +REUSABLE +REUSE/D/G/S +REVAMP/D/G/S +REVEAL/D/G/S +REVEL/D/R/G/S +REVELATION/M/S +REVELRY +REVENGE/R +REVENUE/Z/S +REVERE/D/G/S +REVERENCE +REVEREND/M/S +REVERENTLY +REVERIFY/D/G/S +REVERSAL/M/S +REVERSE/D/R/G/N/Y/S +REVERSIBLE +REVERT/D/G/S +REVIEW/D/R/Z/G/S +REVILE/D/R/G +REVISE/D/R/G/N/X/S +REVISION/M/S +REVISIT/D/G/S +REVIVAL/M/S +REVIVE/D/R/G/S +REVOCATION +REVOKE/D/R/G/S +REVOLT/D/R/G/S +REVOLTINGLY +REVOLUTION/M/S +REVOLUTIONARY/M/S +REVOLUTIONIZE/D/R +REVOLVE/D/R/Z/G/S +REWARD/D/G/S +REWARDINGLY +REWIND/G/S +REWORK/D/G/S +REWOUND +REWRITE/G/S +REWRITTEN +RHETORIC +RHEUMATISM +RHEUMATOLOGY +RHINOCEROS +RHUBARB +RHYME/D/G/S +RHYTHM/M/S +RHYTHMIC +RHYTHMICALLY +RIB/M/S +RIBBED +RIBBING +RIBBON/M/S +RICE +RICH/P/T/R/Y/S +RICHARD/M +RICK/M +RICKSHAW/M/S +RID +RIDDEN +RIDDLE/D/G/S +RIDE/R/Z/G/S +RIDGE/M/S +RIDICULE/D/G/S +RIDICULOUS/P/Y +RIFLE/D/R/G/S +RIFLEMAN +RIFT +RIG/M/S +RIGGING +RIGHT/P/D/R/G/Y/S +RIGHTEOUS/P/Y +RIGHTFUL/P/Y +RIGHTMOST +RIGHTWARD +RIGID/Y +RIGIDITY +RIGOR/S +RIGOROUS/Y +RILL +RIM/M/S +RIME +RIND/M/S +RING/D/R/Z/G/J/S +RINGINGLY +RINSE/D/R/G/S +RIOT/D/R/Z/G/S +RIOTOUS +RIP/N/S +RIPE/P/Y +RIPPED +RIPPING +RIPPLE/D/G/S +RISE/R/Z/G/J/S +RISEN +RISK/D/G/S +RITE/M/S +RITUAL/Y/S +RIVAL/D/S/G +RIVALLED +RIVALLING +RIVALRY/M/S +RIVER/M/S +RIVERSIDE +RIVET/R/S +RIVULET/M/S +ROAD/M/S +ROADSIDE +ROADSTER/M/S +ROADWAY/M/S +ROAM/D/G/S +ROAR/D/R/G/S +ROAST/D/R/G/S +ROB/S/M +ROBBED +ROBBER/M/S +ROBBERY/M/S +ROBBING +ROBE/D/G/S +ROBERT/M +ROBIN/M/S +ROBOT/M/S +ROBOTIC +ROBOTICS +ROBUST/P/Y +ROCK/D/R/Z/G/S +ROCKET/D/G/S +ROCKY/S +ROD/M/S +RODE +ROE +ROGER/M +ROGUE/M/S +ROLE/M/S +ROLL/D/R/Z/G/S +ROMAN +ROMANCE/R/Z/G/S +ROMANTIC/M/S +ROMP/D/R/G/S +ROOF/D/R/G/S +ROOK +ROOM/D/R/Z/G/S +ROOST/R/Z +ROOT/D/R/M/G/S +ROPE/D/R/Z/G/S +ROSE/M/S +ROSEBUD/M/S +ROSY/P +ROT/S +ROTARY +ROTATE/D/G/N/X/S +ROTATOR +ROTTEN/P +ROUGE +ROUGH/P/D/T/R/N/Y +ROUND/P/D/T/R/G/Y/S +ROUNDABOUT +ROUNDEDNESS +ROUNDOFF +ROUSE/D/G/S +ROUT +ROUTE/D/R/Z/G/J/S +ROUTINE/Y/S +ROVE/D/R/G/S +ROW/D/R/G/S +ROY/M +ROYAL/Y +ROYALIST/M/S +ROYALTY/M/S +RUB/X/S +RUBBED +RUBBER/M/S +RUBBING +RUBBISH +RUBBLE +RUBLE/M/S +RUBOUT +RUBY/M/S +RUDDER/M/S +RUDDY/P +RUDE/P/Y +RUDIMENT/M/S +RUDIMENTARY +RUE +RUEFULLY +RUFFIAN/Y/S +RUFFLE/D/S +RUG/M/S +RUGGED/P/Y +RUIN/D/G/S +RUINATION/M/S +RUINOUS/Y +RULE/D/R/Z/G/J/S +RUM/N +RUMBLE/D/R/G/S +RUMOR/D/S +RUMP/Y +RUMPLE/D +RUN/S +RUNAWAY +RUNG/M/S +RUNNER/M/S +RUNNING +RUNTIME +RUPTURE/D/G/S +RURAL/Y +RUSH/D/R/G/S +RUSSELL/M +RUSSET +RUSSIAN/M/S +RUST/D/G/S +RUSTIC +RUSTICATE/D/G/N/S +RUSTLE/D/R/Z/G +RUSTY +RUT/M/S +RUTGERS +RUTH/M +RUTHLESS/P/Y +RYE +SABER/M/S +SABLE/M/S +SABOTAGE +SACK/R/G/S +SACRED/P/Y +SACRIFICE/D/R/Z/G/S +SACRIFICIAL/Y +SAD/P/Y +SADDEN/D/S +SADDER +SADDEST +SADDLE/D/S +SADISM +SADIST/M/S +SADISTIC +SADISTICALLY +SAFE/P/T/R/Y/S +SAFEGUARD/D/G/S +SAFETY/S +SAG/S +SAGACIOUS +SAGACITY +SAGE/Y/S +SAID +SAIL/D/G/S +SAILOR/Y/S +SAINT/D/Y/S +SAKE/S +SALABLE +SALAD/M/S +SALARY/D/S +SALE/M/S +SALESMAN +SALESMEN +SALIENT +SALINE +SALIVA +SALLOW +SALLY/G/S +SALMON +SALON/M/S +SALOON/M/S +SALT/D/R/Z/G/S +SALTY/P/T/R +SALUTARY +SALUTATION/M/S +SALUTE/D/G/S +SALVAGE/D/R/G/S +SALVATION +SALVE/R/S +SAM/M +SAME/P +SAMPLE/D/R/Z/G/J/S +SAN +SANCTIFY/D/N +SANCTION/D/G/S +SANCTITY +SANCTUARY/M/S +SAND/D/R/Z/G/S +SANDAL/M/S +SANDPAPER +SANDSTONE +SANDWICH/S +SANDY +SANE/T/R/Y +SANG +SANGUINE +SANITARIUM +SANITARY +SANITATION +SANITY +SANK +SANTA/M +SAP/M/S +SAPLING/M/S +SAPPHIRE +SARCASM/M/S +SARCASTIC +SASH +SAT +SATCHEL/M/S +SATE/D/G/S +SATELLITE/M/S +SATIN +SATIRE/M/S +SATISFACTION/M/S +SATISFACTORILY +SATISFACTORY +SATISFIABILITY +SATISFIABLE +SATISFY/D/G/S +SATURATE/D/G/N/S +SATURDAY/M/S +SATYR +SAUCE/R/Z/S +SAUCEPAN/M/S +SAUCY +SAUL/M +SAUNA +SAUNTER +SAUSAGE/M/S +SAVAGE/P/D/R/Z/G/Y/S +SAVE/D/R/Z/G/J/S +SAVIOR/M/S +SAVOR/D/G/S +SAVORY +SAW/D/G/S +SAWMILL/M/S +SAWTOOTH +SAY/R/Z/G/J/S +SCABBARD/M/S +SCAFFOLD/G/J/S +SCALABLE +SCALAR/M/S +SCALD/D/G +SCALE/D/G/J/S +SCALLOP/D/S +SCALP/M/S +SCALY +SCAMPER/G/S +SCAN/S +SCANDAL/M/S +SCANDALOUS +SCANNED +SCANNER/M/S +SCANNING +SCANT/Y +SCANTILY +SCANTY/P/T/R +SCAR/M/S +SCARCE/P/Y +SCARCITY +SCARE/D/G/S +SCARF +SCARLET +SCARY +SCATTER/D/G/S +SCENARIO/M/S +SCENE/M/S +SCENERY +SCENIC +SCENT/D/S +SCEPTER/M/S +SCHEDULE/D/R/Z/G/S +SCHEMA/M/S +SCHEMATA +SCHEMATIC/S +SCHEMATICALLY +SCHEME'S +SCHEME/D/R/Z/G/S +SCHENLEY +SCHIZOPHRENIA +SCHOLAR/Y/S +SCHOLARSHIP/M/S +SCHOLASTIC/S +SCHOLASTICALLY +SCHOOL/D/R/Z/G/S +SCHOOLBOY/M/S +SCHOOLHOUSE/M/S +SCHOOLMASTER/M/S +SCHOOLMATE +SCHOOLROOM/M/S +SCHOONER +SCIENCE/M/S +SCIENTIFIC +SCIENTIFICALLY +SCIENTIST/M/S +SCISSOR/D/G/S +SCOFF/D/R/G/S +SCOLD/D/G/S +SCOOP/D/G/S +SCOPE/D/G/S +SCORCH/D/R/G/S +SCORE/D/R/Z/G/J/S +SCORN/D/R/G/S +SCORNFUL/Y +SCORPION/M/S +SCOTLAND +SCOTT/M +SCOUNDREL/M/S +SCOUR/D/G/S +SCOURGE +SCOUT/D/G/S +SCOW +SCOWL/D/G/S +SCRAMBLE/D/R/G/S +SCRAP/M/S +SCRAPE/D/R/Z/G/J/S +SCRAPPED +SCRATCH/D/R/Z/G/S +SCRATCHPAD/M/S +SCRAWL/D/G/S +SCREAM/D/R/Z/G/S +SCREECH/D/G/S +SCREEN/D/G/J/S +SCREW/D/G/S +SCRIBBLE/D/R/S +SCRIBE/G/S +SCRIPT/M/S +SCRIPTURE/S +SCROLL/D/G/S +SCRUB +SCRUPLE +SCRUPULOUS/Y +SCRUTINIZE/D/G +SCRUTINY +SCS +SCUFFLE/D/G/S +SCULPT/D/S +SCULPTOR/M/S +SCULPTURE/D/S +SCURRY/D +SCUTTLE/D/G/S +SCYTHE/M/S +SEA/Y/S +SEABOARD +SEACOAST/M/S +SEAL/D/R/G/S +SEALEVEL +SEAM/D/G/N/S +SEAMAN +SEAN/M +SEAPORT/M/S +SEAR/D/G/S +SEARCH/D/R/Z/G/J/S +SEARCHINGLY +SEARING/Y +SEASHORE/M/S +SEASIDE +SEASON/D/R/Z/G/J/S +SEASONABLE +SEASONABLY +SEASONAL/Y +SEAT/D/G/S +SEAWARD +SEAWEED +SECEDE/D/G/S +SECLUDED +SECLUSION +SECOND/D/R/Z/G/Y/S +SECONDARILY +SECONDARY +SECONDHAND +SECRECY +SECRET/Y/S +SECRETARIAL +SECRETARY/M/S +SECRETE/D/G/N/X/V/S +SECRETIVELY +SECT/M/S +SECTION/D/G/S +SECTIONAL +SECTOR/M/S +SECULAR +SECURE/D/G/Y/J/S +SECURITY/S +SEDGE +SEDIMENT/M/S +SEDUCE/D/R/Z/G/S +SEDUCTIVE +SEE/R/Z/S +SEED/D/R/Z/G/J/S +SEEDLING/M/S +SEEING +SEEK/R/Z/G/S +SEEM/D/G/Y/S +SEEMINGLY +SEEN +SEEP/D/G/S +SEETHE/D/G/S +SEGMENT/D/G/S +SEGMENTATION/M/S +SEGREGATE/D/G/N/S +SEISMIC +SEIZE/D/G/S +SEIZURE/M/S +SELDOM +SELECT/D/G/V/S +SELECTABLE +SELECTION/M/S +SELECTIVE/Y +SELECTIVITY +SELECTOR/M/S +SELF +SELFISH/P/Y +SELFSAME +SELL/R/Z/G/S +SELVES +SEMANTIC/S +SEMANTICAL/Y +SEMANTICIST/M/S +SEMAPHORE/M/S +SEMBLANCE +SEMESTER/M/S +SEMI +SEMIAUTOMATED +SEMIAUTOMATIC +SEMICOLON/M/S +SEMICONDUCTOR/M/S +SEMINAL +SEMINAR/M/S +SEMINARY/M/S +SEMIPERMANENT/Y +SENATE/M/S +SENATOR/M/S +SEND/R/Z/G/S +SENIOR/M/S +SENIORITY +SENSATION/M/S +SENSATIONAL/Y +SENSE/D/G/S +SENSELESS/P/Y +SENSIBILITY/S +SENSIBLE +SENSIBLY +SENSITIVE/P/Y/S +SENSITIVITY/S +SENSOR/M/S +SENSORY +SENT +SENTENCE/D/G/S +SENTENTIAL +SENTIMENT/M/S +SENTIMENTAL/Y +SENTINEL/M/S +SENTRY/M/S +SEPARABLE +SEPARATE/P/D/G/N/X/Y/S +SEPARATOR/M/S +SEPTEMBER +SEPULCHER/M/S +SEQUEL/M/S +SEQUENCE/D/R/Z/G/J/S +SEQUENTIAL/Y +SEQUENTIALITY +SEQUENTIALIZE/D/G/S +SEQUESTER +SERENDIPITOUS +SERENDIPITY +SERENE/Y +SERENITY +SERF/M/S +SERGEANT/M/S +SERIAL/Y/S +SERIALIZATION/M/S +SERIALIZE/D/G/S +SERIES +SERIOUS/P/Y +SERMON/M/S +SERPENT/M/S +SERPENTINE +SERUM/M/S +SERVANT/M/S +SERVE/D/R/Z/G/J/S +SERVICE/D/G/S +SERVICEABLE +SERVILE +SERVITUDE +SESAME +SESSION/M/S +SET/M/S +SETTER/M/S +SETTING/S +SETTLE/D/R/Z/G/S +SETTLEMENT/M/S +SETUP/S +SEVEN/H/S +SEVENTEEN/H/S +SEVENTY/H/S +SEVER/S +SEVERAL/Y +SEVERANCE +SEVERE/D/T/R/G/Y +SEVERITY/M/S +SEW/D/R/Z/G/S +SEX/D/S +SEXUAL/Y +SEXUALITY +SHABBY +SHACK/D/S +SHACKLE/D/G/S +SHADE/D/G/J/S +SHADILY +SHADOW/D/G/S +SHADOWY +SHADY/P/T/R +SHAFT/M/S +SHAGGY +SHAKABLE +SHAKABLY +SHAKE/R/Z/G/S +SHAKEN +SHAKY/P +SHALE +SHALL +SHALLOW/P/R/Y +SHAM/M/S +SHAMBLES +SHAME/D/G/S +SHAMEFUL/Y +SHAMELESS/Y +SHAN'T +SHANGHAI +SHANTY/M/S +SHAPE/D/R/Z/G/Y/S +SHAPELESS/P/Y +SHARABLE +SHARE/D/R/Z/G/S +SHARECROPPER/M/S +SHAREHOLDER/M/S +SHARK/M/S +SHARON/M +SHARP/P/T/R/N/X/Y +SHARPENED +SHARPENING +SHATTER/D/G/S +SHAVE/D/G/J/S +SHAVEN +SHAWL/M/S +SHE'LL +SHE/M +SHEAF +SHEAR/D/R/G/S +SHEATH/G +SHEATHS +SHEAVES +SHED/S +SHEEP +SHEER/D +SHEET/D/G/S +SHELF +SHELL/D/R/G/S +SHELTER/D/G/S +SHELVE/D/G/S +SHEPHERD/M/S +SHERIFF/M/S +SHIELD/D/G/S +SHIFT/D/R/Z/G/S +SHIFTILY +SHIFTY/P/T/R +SHILLING/S +SHIMMER/G +SHIN +SHINE/D/R/Z/G/S +SHINGLE/M/S +SHININGLY +SHINY +SHIP/M/S +SHIPBOARD +SHIPBUILDING +SHIPMENT/M/S +SHIPPED +SHIPPER/M/S +SHIPPING +SHIPWRECK/D/S +SHIRK/R/G/S +SHIRT/G/S +SHIVER/D/R/G/S +SHOAL/M/S +SHOCK/D/R/Z/G/S +SHOCKINGLY +SHOD +SHOE/D/S +SHOEING +SHOEMAKER +SHONE +SHOOK +SHOOT/R/Z/G/J/S +SHOP/M/S +SHOPKEEPER/M/S +SHOPPED +SHOPPER/M/S +SHOPPING +SHORE/M/S +SHORN +SHORT/P/D/T/R/G/Y/S +SHORTAGE/M/S +SHORTCOMING/M/S +SHORTCUT/M/S +SHORTEN/D/G/S +SHORTHAND/D +SHOT/M/S +SHOTGUN/M/S +SHOULD/Z +SHOULDER/D/G/S +SHOULDN'T +SHOUT/D/R/Z/G/S +SHOVE/D/G/S +SHOVEL/D/S +SHOW/D/R/Z/G/J/S +SHOWER/D/G/S +SHOWN +SHRANK +SHRED/M/S +SHREW/M/S +SHREWD/P/T/Y +SHRIEK/D/G/S +SHRILL/P/D/G +SHRILLY +SHRIMP +SHRINE/M/S +SHRINK/G/S +SHRINKABLE +SHRIVEL/D +SHROUD/D +SHRUB/M/S +SHRUBBERY +SHRUG/S +SHRUNK/N +SHUDDER/D/G/S +SHUFFLE/D/G/S +SHUN/S +SHUT/S +SHUTDOWN/M/S +SHUTTER/D/S +SHUTTING +SHUTTLE/D/G/S +SHY/D/Y/S +SHYNESS +SIBLING/M/S +SICK/T/R/N/Y +SICKLE +SICKNESS/M/S +SIDE/D/G/J/S +SIDEBOARD/M/S +SIDEBURN/M/S +SIDELIGHT/M/S +SIDEWALK/M/S +SIDEWAYS +SIDEWISE +SIEGE/M/S +SIEMENS +SIERRA +SIEVE/M/S +SIFT/D/R/G +SIGH/D/G +SIGHS +SIGHT/D/G/Y/J/S +SIGMA +SIGN/D/R/Z/G/S +SIGNAL/D/G/Y/S/R +SIGNALLED +SIGNALLER +SIGNALLING +SIGNATURE/M/S +SIGNET +SIGNIFICANCE +SIGNIFICANT/Y/S +SIGNIFY/D/G/N/S +SIGNOR +SIKKIM +SILENCE/D/R/Z/G/S +SILENT/Y +SILHOUETTE/D/S +SILICON +SILICONE +SILK/N/S +SILKILY +SILKINE +SILKY/T/R +SILL/M/S +SILLY/P/T +SILT/D/G/S +SILVER/D/G/S +SILVERY +SIMILAR/Y +SIMILARITY/S +SIMILITUDE +SIMMER/D/G/S +SIMON/M +SIMPLE/P/T/R +SIMPLEX +SIMPLICITY/M/S +SIMPLIFY/D/R/Z/G/N/X/S +SIMPLISTIC +SIMPLY +SIMULATE/D/G/N/X/S +SIMULATOR/M/S +SIMULTANEITY +SIMULTANEOUS/Y +SIN/M/S +SINCE +SINCERE/T/Y +SINCERITY +SINE/S +SINEW/M/S +SINFUL/P/Y +SING/D/R/Z/G/Y/S +SINGABLE +SINGAPORE +SINGINGLY +SINGLE/P/D/G/S +SINGLETON/M/S +SINGULAR/Y +SINGULARITY/M/S +SINISTER +SINK/D/R/Z/G/S +SINNED +SINNER/M/S +SINNING +SINUSITIS +SINUSOIDAL +SINUSOIDS +SIP/S +SIR/N/X/S +SIRE/D/S +SIRUP +SISTER/Y/S +SIT/S +SITE/D/G/S +SITTER/M/S +SITTING/S +SITUATE/D/G/N/X/S +SITUATIONAL/Y +SIX/H/S +SIXPENCE +SIXTEEN/H/S +SIXTY/H/S +SIZABLE +SIZE/D/G/J/S +SKATE/D/R/Z/G/S +SKELETAL +SKELETON/M/S +SKEPTIC/M/S +SKEPTICAL/Y +SKETCH/D/G/S +SKETCHILY +SKETCHY +SKEW/D/R/Z/G/S +SKI/G/S +SKILL/D/S +SKILLFUL/P/Y +SKIM/M/S +SKIMP/D/G/S +SKIN/M/S +SKINNED +SKINNER/M/S +SKINNING +SKIP/S +SKIPPED +SKIPPER/M/S +SKIPPING +SKIRMISH/D/R/Z/G/S +SKIRT/D/G/S +SKULK/D/R/G/S +SKULL/M/S +SKUNK/M/S +SKY/M/S +SKYLARK/G/S +SKYLIGHT/M/S +SKYSCRAPER/M/S +SLAB +SLACK/P/R/G/N/Y/S +SLAIN +SLAM/S +SLAMMED +SLAMMING +SLANDER/R/S +SLANG +SLANT/D/G/S +SLAP/S +SLAPPED +SLAPPING +SLASH/D/G/S +SLAT/M/S +SLATE/D/R/S +SLAUGHTER/D/G/S +SLAVE/R/S +SLAVERY +SLAY/R/Z/G/S +SLED/M/S +SLEDGE/M/S +SLEEK +SLEEP/R/Z/G/S +SLEEPILY +SLEEPLESS/P/Y +SLEEPY/P +SLEET +SLEEVE/M/S +SLEIGH +SLEIGHS +SLENDER/R +SLEPT +SLEW/G +SLICE/D/R/Z/G/S +SLICK/R/Z/S +SLID +SLIDE/R/Z/G/S +SLIGHT/P/D/T/R/G/Y/S +SLIM/Y +SLIME/D +SLIMY +SLING/G/S +SLIP/M/S +SLIPPAGE +SLIPPED +SLIPPER/M/S +SLIPPERY/P +SLIPPING +SLIT/M/S +SLOGAN/M/S +SLOP/S +SLOPE/D/R/Z/G/S +SLOPPED +SLOPPING +SLOPPY/P +SLOT/M/S +SLOTH +SLOTHS +SLOTTED +SLOUCH/D/G/S +SLOW/P/D/T/R/G/Y/S +SLUG/S +SLUGGISH/P/Y +SLUM/M/S +SLUMBER/D +SLUMP/D/S +SLUNG +SLUR/M/S +SLY/Y +SMACK/D/G/S +SMALL/P/T/R +SMALLPOX +SMALLTALK +SMART/P/D/T/R/Y +SMASH/D/R/Z/G/S +SMASHINGLY +SMEAR/D/G/S +SMELL/D/G/S +SMELLY +SMELT/R/S +SMILE/D/G/S +SMILINGLY +SMITE +SMITH +SMITHS +SMITHY +SMITTEN +SMOCK/G/S +SMOG +SMOKABLE +SMOKE/D/R/Z/G/S +SMOKY/S +SMOLDER/D/G/S +SMOOTH/P/D/T/R/G/Y/S +SMOTE +SMOTHER/D/G/S +SMUGGLE/D/R/Z/G/S +SNAIL/M/S +SNAKE/D/S +SNAP/S +SNAPPED +SNAPPER/M/S +SNAPPILY +SNAPPING +SNAPPY +SNAPSHOT/M/S +SNARE/D/G/S +SNARL/D/G +SNATCH/D/G/S +SNEAK/D/R/Z/G/S +SNEAKILY +SNEAKY/P/T/R +SNEER/D/G/S +SNEEZE/D/G/S +SNIFF/D/G/S +SNOOP/D/G/S +SNORE/D/G/S +SNORT/D/G/S +SNOUT/M/S +SNOW/D/G/S +SNOWILY +SNOWMAN +SNOWMEN +SNOWSHOE/M/S +SNOWY/T/R +SNUFF/D/R/G/S +SNUG/P/Y +SNUGGLE/D/G/S +SO +SOAK/D/G/S +SOAP/D/G/S +SOAR/D/G/S +SOB/R/S +SOBER/P/D/G/Y/S +SOCCER +SOCIABILITY +SOCIABLE +SOCIABLY +SOCIAL/Y +SOCIALISM +SOCIALIST/M/S +SOCIALIZATION +SOCIALIZE/D/G/S +SOCIETAL +SOCIETY/M/S +SOCIOLOGICAL/Y +SOCIOLOGY +SOCK/D/G/S +SOCKET/M/S +SOD/M/S +SODA +SODIUM +SODOMY +SOFA/M/S +SOFT/P/T/R/X/Y +SOFTEN/D/G/S +SOFTWARE/M/S +SOIL/D/G/S +SOJOURN/R/Z +SOLACE/D +SOLAR +SOLD/R +SOLDIER/G/Y/S +SOLE/Y/S +SOLEMN/P/Y +SOLEMNITY +SOLICIT/D/G/S +SOLICITOR +SOLID/P/Y/S +SOLIDIFY/D/G/N/S +SOLIDITY +SOLITAIRE +SOLITARY +SOLITUDE/M/S +SOLO/M/S +SOLUBILITY +SOLUBLE +SOLUTION/M/S +SOLVABLE +SOLVE/D/R/Z/G/S +SOLVENT/M/S +SOMBER/Y +SOME +SOMEBODY +SOMEDAY +SOMEHOW +SOMEONE/M +SOMETHING +SOMETIME/S +SOMEWHAT +SOMEWHERE +SON/M/S +SONAR +SONG/M/S +SONNET/M/S +SOON/T/R +SOOT +SOOTH +SOOTHE/D/R/G/S +SOPHIE/M +SOPHISTICATED +SOPHISTICATION +SOPHOMORE/M/S +SORCERER/M/S +SORCERY +SORDID/P/Y +SORE/P/T/R/Y/S +SORROW/M/S +SORROWFUL/Y +SORRY/T/R +SORT/D/R/Z/G/S +SOUGHT +SOUL/M/S +SOUND/P/D/T/R/Y/S +SOUNDING/M/S +SOUP/M/S +SOUR/P/D/T/R/G/Y/S +SOURCE/M/S +SOUTH +SOUTHERN/R/Z +SOVEREIGN/M/S +SOVIET/M/S +SOY +SPACE/D/R/Z/G/J/S +SPACECRAFT/S +SPACESHIP/M/S +SPADE/D/G/S +SPAGHETTI +SPAIN +SPAN/M/S +SPANISH +SPANK/D/G/S +SPANKINGLY +SPANNED +SPANNER/M/S +SPANNING +SPARE/P/D/T/R/G/Y/S +SPARINGLY +SPARK/D/G/S +SPARROW/M/S +SPARSE/P/T/R/Y +SPAT +SPATE/M/S +SPATIAL/Y +SPATTER/D +SPAWN/D/G/S +SPEAK/R/Z/G/S +SPEAKABLE +SPEAR/D/S +SPECIAL/Y/S +SPECIALIST/M/S +SPECIALIZATION/M/S +SPECIALIZE/D/G/S +SPECIALTY/M/S +SPECIES +SPECIFIABLE +SPECIFIC/S +SPECIFICALLY +SPECIFICITY +SPECIFY/D/R/Z/G/N/X/S +SPECIMEN/M/S +SPECK/M/S +SPECKLE/D/S +SPECTACLE/D/S +SPECTACULAR/Y +SPECTATOR/M/S +SPECTER/M/S +SPECTRA +SPECTROGRAM/M/S +SPECTRUM +SPECULATE/D/G/N/X/V/S +SPECULATOR/M/S +SPED +SPEECH/M/S +SPEECHLESS/P +SPEED/D/R/Z/G/S +SPEEDILY +SPEEDUP/M/S +SPEEDY +SPELL/D/R/Z/G/J/S +SPENCER +SPEND/R/Z/G/S +SPENT +SPHERE/M/S +SPHERICAL/Y +SPICE/D/S +SPICY/P +SPIDER/M/S +SPIKE/D/S +SPILL/D/R/G/S +SPIN/S +SPINACH +SPINAL/Y +SPINDLE/G +SPINE +SPINNER/M/S +SPINNING +SPIRAL/D/G/Y +SPIRE/M/S +SPIRIT/D/G/S +SPIRITEDLY +SPIRITUAL/Y/S +SPIT/S +SPITE/D/G/S +SPITEFUL/P/Y +SPITTING +SPLASH/D/G/S +SPLEEN +SPLENDID/Y +SPLENDOR +SPLICE/D/R/Z/G/J/S +SPLINE/M/S +SPLINTER/D/S +SPLIT/M/S +SPLITTER/M/S +SPLITTING +SPOIL/D/R/Z/G/S +SPOKE/D/S +SPOKEN +SPOKESMAN +SPOKESMEN +SPONGE/D/R/Z/G/S +SPONSOR/D/G/S +SPONSORSHIP +SPONTANEOUS/Y +SPOOK +SPOOKY +SPOOL/D/R/G/S +SPOON/D/G/S +SPORE/M/S +SPORT/D/G/V/S +SPORTINGLY +SPORTSMAN +SPOT/M/S +SPOTLESS/Y +SPOTTED +SPOTTER/M/S +SPOTTING +SPOUSE/M/S +SPOUT/D/G/S +SPRANG +SPRAWL/D/G/S +SPRAY/D/R/G/S +SPREAD/R/Z/G/J/S +SPREE/M/S +SPRIG +SPRIGHTLY +SPRING/R/Z/G/S +SPRINGTIME +SPRINGY/P/T/R +SPRINKLE/D/R/G/S +SPRINT/D/R/Z/G/S +SPRITE +SPROUT/D/G +SPRUCE/D +SPRUNG +SPUN +SPUR/M/S +SPURIOUS +SPURN/D/G/S +SPURT/D/G/S +SPUTTER/D +SPY/G/S +SQUABBLE/D/G/S +SQUAD/M/S +SQUADRON/M/S +SQUALL/M/S +SQUARE/P/D/T/R/G/Y/S +SQUASH/D/G +SQUAT/S +SQUAWK/D/G/S +SQUEAK/D/G/S +SQUEAL/D/G/S +SQUEEZE/D/R/G/S +SQUID +SQUINT/D/G +SQUIRE/M/S +SQUIRM/D/S +SQUIRREL/D/G/S +SR +STAB/Y/S +STABBED +STABBING +STABILITY/M/S +STABILIZE/D/R/Z/G/S +STABLE/D/R/G/S +STACK/D/M/G/S +STAFF/D/R/Z/G/S +STAG/M/S +STAGE/D/R/Z/G/S +STAGECOACH +STAGGER/D/G/S +STAGNANT +STAID +STAIN/D/G/S +STAINLESS +STAIR/M/S +STAIRCASE/M/S +STAIRWAY/M/S +STAKE/D/S +STALE +STALK/D/G +STALL/D/G/J/S +STALWART/Y +STAMEN/M/S +STAMINA +STAMMER/D/R/G/S +STAMP/D/R/Z/G/S +STAMPEDE/D/G/S +STANCH/T +STAND/G/J/S +STANDARD/Y/S +STANDARDIZATION +STANDARDIZE/D/G/S +STANDBY +STANDPOINT/M/S +STANDSTILL +STANFORD +STANZA/M/S +STAPLE/R/G/S +STAR/M/S +STARBOARD +STARCH/D +STARE/D/R/G/S +STARFISH +STARK/Y +STARLIGHT +STARRED +STARRING +STARRY +START/D/R/Z/G/S +STARTLE/D/G/S +STARTUP/M/S +STARVATION +STARVE/D/G/S +STATE/D/M/G/X/Y/S +STATEMENT/M/S +STATESMAN +STATIC +STATICALLY +STATION/D/R/G/S +STATIONARY +STATISTIC/S +STATISTICAL/Y +STATISTICIAN/M/S +STATUE/M/S +STATUESQUE/P/Y +STATURE +STATUS/S +STATUTE/M/S +STATUTORILY +STATUTORY/P +STAUNCH/T/Y +STAVE/D/S +STAY/D/G/S +STEAD +STEADFAST/P/Y +STEADILY +STEADY/P/D/T/R/G/S +STEAK/M/S +STEAL/R/G/H/S +STEALTHILY +STEALTHY +STEAM/D/R/Z/G/S +STEAMBOAT/M/S +STEAMSHIP/M/S +STEED +STEEL/D/Z/G/S +STEEP/P/D/T/R/G/Y/S +STEEPLE/M/S +STEER/D/G/S +STELLAR +STEM/M/S +STEMMED +STEMMING +STENCH/M/S +STENCIL/M/S +STENOGRAPHER/M/S +STEP/M/S +STEPHEN/M +STEPMOTHER/M/S +STEPPED +STEPPING +STEPWISE +STEREO/M/S +STEREOGRAPHIC +STEREOTYPE/D/S +STEREOTYPICAL +STERILE +STERILIZATION/M/S +STERILIZE/D/R/G/S +STERLING +STERN/P/Y/S +STEVE/M +STEW/D/S +STEWARD/M/S +STICK/G/R/S/Z +STICKILY +STICKY/P/T/R +STIFF/P/T/R/N/X/Y/S +STIFLE/D/G/S +STIGMA +STILE/M/S +STILL/P/D/T/R/G/S +STIMULANT/M/S +STIMULATE/D/G/N/X/V/S +STIMULI +STIMULUS +STING/G/S +STINK/R/Z/G/S +STINT +STIPEND/M/S +STIPULATE/D/G/N/X/S +STIR/S +STIRRED +STIRRER/M/S +STIRRING/Y/S +STIRRUP +STITCH/D/G/S +STOCHASTIC +STOCHASTICALLY +STOCK/D/R/Z/G/J/S +STOCKADE/M/S +STOCKHOLDER/M/S +STOLE/M/S +STOLEN +STOMACH/D/R/G/S +STONE/D/G/S +STONY +STOOD +STOOL +STOOP/D/G/S +STOP/S +STOPCOCK/S +STOPPABLE +STOPPAGE +STOPPED +STOPPER/M/S +STOPPING +STORAGE/M/S +STORE/D/G/S +STOREHOUSE/M/S +STORK/M/S +STORM/D/G/S +STORMY/P/T/R +STORY/D/S +STOUT/P/T/R/Y +STOVE/M/S +STOW/D +STRAGGLE/D/R/Z/G/S +STRAIGHT/P/T/R/N/X +STRAIGHTFORWARD/P/Y +STRAIGHTWAY +STRAIN/D/R/Z/G/S +STRAIT/N/S +STRAND/D/G/S +STRANGE/P/R/Z/Y +STRANGEST +STRANGLE/D/R/Z/G/J/S +STRANGULATION/M/S +STRAP/M/S +STRATAGEM/M/S +STRATEGIC +STRATEGY/M/S +STRATIFY/D/N/X/S +STRATUM +STRAW/M/S +STRAWBERRY/M/S +STRAY/D/S +STREAK/D/S +STREAM/D/R/Z/G/S +STREAMLINE/D/R/G/S +STREET/Z/S +STREETCAR/M/S +STRENGTH/N +STRENGTHEN/D/R/G/S +STRENGTHS +STRENUOUS/Y +STRESS/D/G/S +STRETCH/D/R/Z/G/S +STREW/S +STREWN +STRICT/P/T/R/Y +STRIDE/R/G/S +STRIFE +STRIKE/R/Z/G/S +STRIKINGLY +STRING'S +STRING/D/R/Z/G/S +STRINGENT/Y +STRINGY/P/T/R +STRIP/M/S +STRIPE/D/S +STRIPPED +STRIPPER/M/S +STRIPPING +STRIVE/G/J/S +STRODE +STROKE/D/R/Z/G/S +STROLL/D/R/G/S +STRONG/T/R/Y +STRONGHOLD +STROVE +STRUCK +STRUCTURAL/Y +STRUCTURE/D/R/G/S +STRUGGLE/D/G/S +STRUNG +STRUT/S +STUB/M/S +STUBBLE +STUBBORN/P/Y +STUCK +STUD/M/S +STUDENT/M/S +STUDIO/M/S +STUDIOUS/Y +STUDY/D/G/S +STUFF/D/G/S +STUFFY/T/R +STUMBLE/D/G/S +STUMP/D/G/S +STUN +STUNG +STUNNING/Y +STUNT/M/S +STUPEFY/G +STUPENDOUS/Y +STUPID/T/Y +STUPIDITY/S +STUPOR +STURDY/P +STYLE/D/R/Z/G/S +STYLISH/P/Y +STYLISTIC +STYLISTICALLY +STYLIZED +SUB/S +SUBATOMIC +SUBCLASS/M/S +SUBCOMPONENT/M/S +SUBCOMPUTATION/M/S +SUBCONSCIOUS/Y +SUBCULTURE/M/S +SUBDIVIDE/D/G/S +SUBDIVISION/M/S +SUBDUE/D/G/S +SUBEXPRESSION/M/S +SUBFIELD/M/S +SUBFILE/M/S +SUBGOAL/M/S +SUBGRAPH +SUBGRAPHS +SUBGROUP/M/S +SUBINTERVAL/M/S +SUBJECT/D/G/V/S +SUBJECTION +SUBJECTIVELY +SUBJECTIVITY +SUBLIMATION/S +SUBLIME/D +SUBLIST/M/S +SUBMARINE/R/Z/S +SUBMERGE/D/G/S +SUBMISSION/M/S +SUBMIT/S +SUBMITTED +SUBMITTING +SUBMODE/S +SUBMODULE/M/S +SUBNETWORK/M/S +SUBORDINATE/D/N/S +SUBPROBLEM/M/S +SUBPROGRAM/M/S +SUBPROJECT +SUBPROOF/M/S +SUBRANGE/M/S +SUBROUTINE/M/S +SUBSCHEMA/M/S +SUBSCRIBE/D/R/Z/G/S +SUBSCRIPT/D/G/S +SUBSCRIPTION/M/S +SUBSECTION/M/S +SUBSEGMENT/M/S +SUBSEQUENCE/M/S +SUBSEQUENT/Y +SUBSET/M/S +SUBSIDE/D/G/S +SUBSIDIARY/M/S +SUBSIDIZE/D/G/S +SUBSIDY/M/S +SUBSIST/D/G/S +SUBSISTENCE +SUBSPACE/M/S +SUBSTANCE/M/S +SUBSTANTIAL/Y +SUBSTANTIATE/D/G/N/X/S +SUBSTANTIVE/Y +SUBSTANTIVITY +SUBSTITUTABILITY +SUBSTITUTABLE +SUBSTITUTE/D/G/N/X/S +SUBSTRATE/M/S +SUBSTRING/S +SUBSTRUCTURE/M/S +SUBSUME/D/G/S +SUBSYSTEM/M/S +SUBTASK/M/S +SUBTERRANEAN +SUBTITLE/S +SUBTLE/P/T/R +SUBTLETY/S +SUBTLY +SUBTRACT/D/G/S/R/Z +SUBTRACTER'S +SUBTRACTION/S +SUBTRAHEND/M/S +SUBTREE/M/S +SUBTYPE/S +SUBUNIT/M/S +SUBURB/M/S +SUBURBAN +SUBVERSION +SUBVERT/D/R/G/S +SUBWAY/M/S +SUCCEED/D/G/S +SUCCESS/V/S +SUCCESSFUL/Y +SUCCESSION/M/S +SUCCESSIVELY +SUCCESSOR/M/S +SUCCINCT/P/Y +SUCCOR +SUCCUMB/D/G/S +SUCH +SUCK/D/R/Z/G/S +SUCKLE/G +SUCTION +SUDDEN/P/Y +SUDS/G +SUE/D/G/S +SUFFER/D/R/Z/G/J/S +SUFFERANCE +SUFFICE/D/G/S +SUFFICIENCY +SUFFICIENT/Y +SUFFIX/D/R/G/S +SUFFOCATE/D/G/N/S +SUFFRAGE +SUGAR/D/G/J/S +SUGGEST/D/G/V/S +SUGGESTIBLE +SUGGESTION/M/S +SUGGESTIVELY +SUICIDAL/Y +SUICIDE/M/S +SUIT/M/S +SUITABILITY +SUITABLE/P +SUITABLY +SUITCASE/M/S +SUITE/D/Z/G/S +SUITOR/M/S +SULK/D/G/S +SULKY/P +SULLEN/P/Y +SULPHATE +SULPHUR/D +SULPHURIC +SULTAN/M/S +SULTRY +SUM/M/S +SUMMAND/M/S +SUMMARIZATION/M/S +SUMMARIZE/D/G/S +SUMMARY/M/S +SUMMATION/M/S +SUMMED +SUMMER/M/S +SUMMING +SUMMIT +SUMMON/D/R/Z/G/S +SUMMONSES +SUMPTUOUS +SUN/M/S +SUNBEAM/M/S +SUNBURN +SUNDAY/M/S +SUNDOWN +SUNDRY/S +SUNG +SUNGLASS/S +SUNK/N +SUNLIGHT +SUNNED +SUNNING +SUNNY +SUNNYVALE +SUNRISE +SUNSET +SUNSHINE +SUP/R +SUPERB/Y +SUPERCLASS/S +SUPERCOMPUTER/M/S +SUPERCOMPUTING +SUPEREGO/M/S +SUPERFICIAL/Y +SUPERFLUITY/M/S +SUPERFLUOUS/Y +SUPERHUMAN/Y +SUPERIMPOSE/D/G/S +SUPERINTEND +SUPERINTENDENT/M/S +SUPERIOR/M/S +SUPERIORITY +SUPERLATIVE/Y/S +SUPERMARKET/M/S +SUPERPOSE/D/G/S +SUPERSCRIPT/D/G/S +SUPERSEDE/D/G/S +SUPERSET/M/S +SUPERSTITION/M/S +SUPERSTITIOUS +SUPERVISE/D/G/N/S +SUPERVISOR/M/S +SUPERVISORY +SUPPER/M/S +SUPPLANT/D/G/S +SUPPLE/P +SUPPLEMENT/D/G/S +SUPPLEMENTAL +SUPPLEMENTARY +SUPPLY/D/R/Z/G/N/S +SUPPORT/D/R/Z/G/V/S +SUPPORTABLE +SUPPORTINGLY +SUPPORTIVELY +SUPPOSE/D/G/S +SUPPOSEDLY +SUPPOSITION/M/S +SUPPRESS/D/G/S +SUPPRESSION +SUPREMACY +SUPREME/Y/P +SURE/P/Y +SURETY/S +SURF +SURFACE/P/D/G/S +SURGE/D/G/S +SURGEON/M/S +SURGERY +SURGICAL/Y +SURLY/P +SURMISE/D/S +SURMOUNT/D/G/S +SURNAME/M/S +SURPASS/D/G/S +SURPLUS/M/S +SURPRISE/D/G/S +SURPRISINGLY +SURRENDER/D/G/S +SURROGATE/M/S +SURROUND/D/G/J/S +SURVEY/D/G/S +SURVEYOR/M/S +SURVIVAL/S +SURVIVE/D/G/S +SURVIVOR/M/S +SUSCEPTIBLE +SUSPECT/D/G/S +SUSPEND/D/G/S +SUSPENDER/M/S +SUSPENSE/N/X/S +SUSPICION/M/S +SUSPICIOUS/Y +SUSTAIN/D/G/S +SUTURE/S +SUZANNE/M +SWAGGER/D/G +SWAIN/M/S +SWALLOW/D/G/S +SWAM +SWAMP/D/G/S +SWAMPY +SWAN/M/S +SWAP/S +SWAPPED +SWAPPING +SWARM/D/G/S +SWARTHY +SWATTED +SWAY/D/G +SWEAR/R/G/S +SWEAT/D/R/Z/G/S +SWEEP/R/Z/G/J/S +SWEET/P/T/R/X/Y/S +SWEETEN/D/R/Z/G/J/S +SWEETHEART/M/S +SWELL/D/G/J/S +SWEPT +SWERVE/D/G/S +SWIFT/P/T/R/Y +SWIM/S +SWIMMER/M/S +SWIMMING/Y +SWINE +SWING/R/Z/G/S +SWIRL/D/G +SWISH/D +SWITCH/D/R/Z/G/J/S +SWITCHBOARD/M/S +SWITZERLAND +SWOLLEN +SWOON +SWOOP/D/G/S +SWORD/M/S +SWORE +SWORN +SWUM +SWUNG +SYCAMORE +SYLLABI +SYLLABLE/M/S +SYLLABUS +SYLLOGISM/M/S +SYMBIOSIS +SYMBIOTIC +SYMBOL/M/S +SYMBOLIC +SYMBOLICALLY +SYMBOLISM +SYMBOLIZATION +SYMBOLIZE/D/G/S +SYMMETRIC +SYMMETRICAL/Y +SYMMETRY/M/S +SYMPATHETIC +SYMPATHIZE/D/R/Z/G/S +SYMPATHIZINGLY +SYMPATHY/M/S +SYMPHONY/M/S +SYMPOSIUM/S +SYMPTOM/M/S +SYMPTOMATIC +SYNAPSE/M/S +SYNCHRONIZATION +SYNCHRONIZE/D/R/Z/G/S +SYNCHRONOUS/Y +SYNCHRONY +SYNDICATE/D/N/S +SYNDROME/M/S +SYNERGISM +SYNERGISTIC +SYNONYM/M/S +SYNONYMOUS/Y +SYNOPSES +SYNOPSIS +SYNTACTIC +SYNTACTICAL/Y +SYNTAX +SYNTHESIS +SYNTHESIZE/D/R/Z/G/S +SYNTHETIC/S +SYRACUSE +SYRINGE/S +SYRUP +SYSTEM/M/S +SYSTEMATIC +SYSTEMATICALLY +SYSTEMATIZE/D/G/S +SYSTOLIC +TAB/S +TABERNACLE/M/S +TABLE/D/G/S +TABLEAU/M/S +TABLECLOTH +TABLECLOTHS +TABLESPOON/M/S +TABLESPOONFUL/M/S +TABLET/M/S +TABOO/M/S +TABULAR +TABULATE/D/G/N/X/S +TABULATOR/M/S +TACHOMETER/M/S +TACIT/Y +TACK/D/G +TACKLE/M/S +TACT +TACTICS +TACTILE +TAG/M/S +TAGGED +TAGGING +TAIL/D/G/S +TAILOR/D/G/S +TAINT/D +TAIWAN +TAKE/R/Z/G/J/S +TAKEN +TALE/M/S +TALENT/D/S +TALK/D/R/Z/G/S +TALKATIVE/P/Y +TALKIE +TALL/P/T/R +TALLOW +TAME/P/D/R/G/Y/S +TAMPER/D/G/S +TAN +TANDEM +TANG +TANGENT/M/S +TANGENTIAL +TANGIBLE +TANGIBLY +TANGLE/D +TANGY +TANK/R/Z/S +TANNER/M/S +TANTALIZING/Y +TANTAMOUNT +TANTRUM/M/S +TAP/M/S +TAPE/D/R/Z/G/J/S +TAPERED +TAPERING +TAPESTRY/M/S +TAPPED +TAPPER/M/S +TAPPING +TAPROOT/M/S +TAR +TARDY/P +TARGET/D/G/S +TARIFF/M/S +TARRY +TART/P/Y +TASK/D/G/S +TASSEL/M/S +TASTE/D/R/Z/G/S +TASTEFUL/P/Y +TASTELESS/Y +TASTY +TATTER/D +TATTOO/D/S +TAU +TAUGHT +TAUNT/D/R/G/S +TAUT/P/Y +TAUTOLOGICAL/Y +TAUTOLOGY/M/S +TAVERN/M/S +TAWNY +TAX/D/G/S +TAXABLE +TAXATION +TAXI/D/G/S +TAXICAB/M/S +TAXONOMIC +TAXONOMICALLY +TAXONOMY +TAXPAYER/M/S +TEA/S +TEACH/R/Z/G/J/S +TEACHABLE +TEACHER'S +TEAHOUSE +TEAM/D/G/S +TEAR/D/G/S +TEARFUL/Y +TEASE/D/G/S +TEASPOON/M/S +TEASPOONFUL/M/S +TECHNICAL/Y +TECHNICALITY/M/S +TECHNICIAN/M/S +TECHNIQUE/M/S +TECHNOLOGICAL/Y +TECHNOLOGIST/M/S +TECHNOLOGY/S +TEDDY/M +TEDIOUS/P/Y +TEDIUM +TEEM/D/G/S +TEEN/S +TEENAGE/D/R/Z +TEETH +TEETHE/D/G/S +TEFLON +TELECOMMUNICATION/S +TELEGRAM/M/S +TELEGRAPH/D/R/Z/G +TELEGRAPHIC +TELEGRAPHS +TELEOLOGICAL/Y +TELEOLOGY +TELEPHONE/D/R/Z/G/S +TELEPHONIC +TELEPHONY +TELESCOPE/D/G/S +TELETYPE/M/S +TELEVISE/D/G/N/X/S +TELEVISOR/M/S +TELL/R/Z/G/S +TEMPER/D/G/S +TEMPERAMENT/S +TEMPERAMENTAL +TEMPERANCE +TEMPERATE/P/Y +TEMPERATURE/M/S +TEMPEST +TEMPESTUOUS/Y +TEMPLATE/M/S +TEMPLE/M/S +TEMPORAL/Y +TEMPORARILY +TEMPORARY/S +TEMPT/D/R/Z/G/S +TEMPTATION/M/S +TEMPTINGLY +TEN/H/S +TENACIOUS/Y +TENANT/M/S +TEND/D/R/Z/G/S +TENDENCY/S +TENDERLY +TENDERNESS +TENEMENT/M/S +TENNESSEE +TENNIS +TENOR/M/S +TENSE/P/D/T/R/G/N/X/Y/S +TENSOR +TENT/D/G/S +TENTACLE/D/S +TENTATIVE/Y +TENURE +TERM/D/G/S +TERMINAL/M/Y/S +TERMINATE/D/G/N/X/S +TERMINATOR/M/S +TERMINOLOGY/S +TERMINUS +TERMWISE +TERNARY +TERRACE/D/S +TERRAIN/M/S +TERRESTRIAL +TERRIBLE +TERRIBLY +TERRIER/M/S +TERRIFIC +TERRIFY/D/G/S +TERRITORIAL +TERRITORY/M/S +TERROR/M/S +TERRORISM +TERRORIST/M/S +TERRORISTIC +TERRORIZE/D/G/S +TERSE +TERTIARY +TEST/D/R/Z/G/J/S +TESTABILITY +TESTABLE +TESTAMENT/M/S +TESTICLE/M/S +TESTIFY/D/R/Z/G/S +TESTIMONY/M/S +TEXAS +TEXT/M/S +TEXTBOOK/M/S +TEXTILE/M/S +TEXTUAL/Y +TEXTURE/D/S +THAN +THANK/D/G/S +THANKFUL/P/Y +THANKLESS/P/Y +THANKSGIVING +THAT/M/S +THATCH/S +THAW/D/G/S +THE/G/J +THEATER/M/S +THEATRICAL/Y/S +THEFT/M/S +THEIR/S +THEM +THEMATIC +THEME/M/S +THEMSELVES +THEN +THENCE +THENCEFORTH +THEOLOGICAL +THEOLOGY +THEOREM/M/S +THEORETIC +THEORETICAL/Y +THEORETICIANS +THEORIST/M/S +THEORIZATION/M/S +THEORIZE/D/R/Z/G/S +THEORY/M/S +THERAPEUTIC +THERAPIST/M/S +THERAPY/M/S +THERE/M +THEREABOUTS +THEREAFTER +THEREBY +THEREFORE +THEREIN +THEREOF +THEREON +THERETO +THEREUPON +THEREWITH +THERMAL +THERMODYNAMIC/S +THERMOMETER/M/S +THERMOSTAT/M/S +THESAURI +THESE/S +THESIS +THETA +THEY +THEY'D +THEY'LL +THEY'RE +THEY'VE +THICK/P/T/R/N/X/Y +THICKET/M/S +THIEF +THIEVE/G/S +THIGH +THIGHS +THIMBLE/M/S +THIN/P/Y +THINK/R/Z/G/S +THINKABLE +THINKABLY +THINNER +THINNEST +THIRD/Y/S +THIRST/D/S +THIRSTY +THIRTEEN/H/S +THIRTY/H/S +THIS +THISTLE +THOMAS +THOMPSON/M +THONG +THORN/M/S +THORNY +THOROUGH/P/Y +THOROUGHFARE/M/S +THOSE +THOUGH +THOUGHT/M/S +THOUGHTFUL/P/Y +THOUGHTLESS/P/Y +THOUSAND/H/S +THRASH/D/R/G/S +THREAD/D/R/Z/G/S +THREAT/N/S +THREATEN/D/G/S +THREE/M/S +THREESCORE +THRESHOLD/M/S +THREW +THRICE +THRIFT +THRIFTY +THRILL/D/R/Z/G/S +THRILLING/Y +THRIVE/D/G/S +THROAT/D/S +THROB/S +THROBBED +THROBBING +THRONE/M/S +THRONG/M/S +THROTTLE/D/G/S +THROUGH +THROUGHOUT +THROUGHPUT +THROW/R/G/S +THROWN +THRUSH +THRUST/R/Z/G/S +THUD/S +THUG/M/S +THUMB/D/G/S +THUMP/D/G +THUNDER/D/R/Z/G/S +THUNDERBOLT/M/S +THUNDERSTORM/M/S +THURSDAY/M/S +THUS/Y +THWART/D/G +THYSELF +TICK/D/R/Z/G/S +TICKET/M/S +TICKLE/D/G/S +TIDAL/Y +TIDE/D/G/J/S +TIDY/P/D/G +TIE/D/R/Z/S +TIGER/M/S +TIGHT/P/T/R/X/Y +TIGHTEN/D/R/Z/G/J/S +TILDE +TILE/D/G/S +TILL/D/R/Z/G/S +TILLABLE +TILT/D/G/S +TIMBER/D/G/S +TIME/D/R/Z/G/Y/J/S +TIMESHARING +TIMETABLE/M/S +TIMID/Y +TIMIDITY +TIN/M/S +TINGE/D +TINGLE/D/G/S +TINILY +TINKER/D/G/S +TINKLE/D/G/S +TINNILY +TINNY/P/T/R +TINT/D/G/S +TINY/P/T/R +TIP/M/S +TIPPED +TIPPER/M/S +TIPPING +TIPTOE +TIRE/D/G/S +TIREDLY +TIRELESS/P/Y +TIRESOME/P/Y +TISSUE/M/S +TIT/R/Z/S +TITHE/R/S +TITLE/D/S +TO +TOAD/M/S +TOAST/D/R/G/S +TOBACCO +TODAY +TOE/M/S +TOFU +TOGETHER/P +TOGGLE/D/G/S +TOIL/D/R/G/S +TOILET/M/S +TOKEN/M/S +TOLD +TOLERABILITY +TOLERABLE +TOLERABLY +TOLERANCE/S +TOLERANT/Y +TOLERATE/D/G/N/S +TOLL/D/S +TOM/M +TOMAHAWK/M/S +TOMATO +TOMATOES +TOMB/M/S +TOMOGRAPHY +TOMORROW +TON/M/S +TONAL +TONE/D/R/G/S +TONGS +TONGUE/D/S +TONIC/M/S +TONIGHT +TONNAGE +TONSIL +TOO/H +TOOK +TOOL/D/R/Z/G/S +TOOLKIT/S +TOOTHBRUSH/M/S +TOOTHPICK/M/S +TOP/R/S +TOPIC/M/S +TOPICAL/Y +TOPMOST +TOPOGRAPHIC +TOPOGRAPHICAL +TOPOLOGIC +TOPOLOGICAL +TOPOLOGY/S +TOPPLE/D/G/S +TORCH/M/S +TORE +TORMENT/D/R/Z/G +TORN +TORNADO/S +TORNADOES +TORPEDO/S +TORPEDOES +TORQUE +TORRENT/M/S +TORRID +TORTOISE/M/S +TORTURE/D/R/Z/G/S +TORUS/M/S +TOSS/D/G/S +TOTAL/D/G/Y/S/R/Z/M +TOTALER'S +TOTALITY/M/S +TOTALLED +TOTALLER/S/M +TOTALLING +TOTTER/D/G/S +TOUCH/D/G/S +TOUCHABLE +TOUCHILY +TOUCHINGLY +TOUCHY/P/T/R +TOUGH/P/T/R/N/Y +TOUR/D/G/S +TOURETZKY/M +TOURISM +TOURIST/M/S +TOURNAMENT/M/S +TOW/D/Z +TOWARD/S +TOWEL/G/S/D/M +TOWELLED +TOWELLING +TOWER/D/G/S +TOWN/M/S +TOWNSHIP/M/S +TOY/D/G/S +TRACE/D/R/Z/G/J/S +TRACEABLE +TRACK/D/R/Z/G/S +TRACT/M/V/S +TRACTABILITY +TRACTABLE +TRACTOR/M/S +TRADE/D/R/Z/G/S +TRADEMARK/M/S +TRADESMAN +TRADITION/M/S +TRADITIONAL/Y +TRAFFIC/M/S +TRAFFICKED +TRAFFICKER/M/S +TRAFFICKING +TRAGEDY/M/S +TRAGIC +TRAGICALLY +TRAIL/D/R/Z/G/J/S +TRAIN/D/R/Z/G/S +TRAINABLE +TRAINEE/M/S +TRAIT/M/S +TRAITOR/M/S +TRAJECTORY/M/S +TRAMP/D/G/S +TRAMPLE/D/R/G/S +TRANCE/M/S +TRANQUIL/Y +TRANQUILITY +TRANQUILLITY +TRANSACT +TRANSACTION/M/S +TRANSCEND/D/G/S +TRANSCENDENT +TRANSCONTINENTAL +TRANSCRIBE/D/R/Z/G/S +TRANSCRIPT/M/S +TRANSCRIPTION/M/S +TRANSFER/M/S/D/G +TRANSFERABLE +TRANSFERAL/M/S +TRANSFERRAL/M/S +TRANSFERRED +TRANSFERRER/M/S +TRANSFERRING +TRANSFINITE +TRANSFORM/D/G/S +TRANSFORMABLE +TRANSFORMATION/M/S +TRANSFORMATIONAL +TRANSGRESS/D +TRANSGRESSION/M/S +TRANSIENT/Y/S +TRANSISTOR/M/S +TRANSIT +TRANSITION/D/S +TRANSITIONAL +TRANSITIVE/P/Y +TRANSITIVITY +TRANSITORY +TRANSLATABILITY +TRANSLATABLE +TRANSLATE/D/G/N/X/S +TRANSLATIONAL +TRANSLATOR/M/S +TRANSLITERATE/N/D/G +TRANSLUCENT +TRANSMISSION/M/S +TRANSMIT/S +TRANSMITTAL +TRANSMITTED +TRANSMITTER/M/S +TRANSMITTING +TRANSMOGRIFY/N +TRANSPARENCY/M/S +TRANSPARENT/Y +TRANSPIRE/D/G/S +TRANSPLANT/D/G/S +TRANSPORT/D/R/Z/G/S +TRANSPORTABILITY +TRANSPORTATION +TRANSPOSE/D/G/S +TRANSPOSITION +TRAP/M/S +TRAPEZOID/M/S +TRAPEZOIDAL +TRAPPED +TRAPPER/M/S +TRAPPING/S +TRASH +TRAUMA +TRAUMATIC +TRAVAIL +TRAVEL/D/R/Z/G/J/S +TRAVERSAL/M/S +TRAVERSE/D/G/S +TRAVESTY/M/S +TRAY/M/S +TREACHEROUS/Y +TREACHERY/M/S +TREAD/G/S +TREASON +TREASURE/D/R/G/S +TREASURY/M/S +TREAT/D/G/S +TREATISE/M/S +TREATMENT/M/S +TREATY/M/S +TREBLE +TREE/M/S +TREETOP/M/S +TREK/M/S +TREMBLE/D/G/S +TREMENDOUS/Y +TREMOR/M/S +TRENCH/R/S +TREND/G/S +TRESPASS/D/R/Z/S +TRESS/M/S +TRIAL/M/S +TRIANGLE/M/S +TRIANGULAR/Y +TRIBAL +TRIBE/M/S +TRIBUNAL/M/S +TRIBUNE/M/S +TRIBUTARY +TRIBUTE/M/S +TRICHOTOMY +TRICK/D/G/S +TRICKLE/D/G/S +TRICKY/P/T/R +TRIFLE/R/G/S +TRIGGER/D/G/S +TRIGONOMETRIC +TRIGONOMETRY +TRIHEDRAL +TRILL/D +TRILLION/H/S +TRIM/P/Y/S +TRIMMED +TRIMMER +TRIMMEST +TRIMMING/S +TRINKET/M/S +TRIP/M/S +TRIPLE/D/G/S +TRIPLET/M/S +TRIUMPH/D/G +TRIUMPHAL +TRIUMPHANTLY +TRIUMPHS +TRIVIA +TRIVIAL/Y +TRIVIALITY/S +TROD +TROLL/M/S +TROLLEY/M/S +TROOP/R/Z/S +TROPHY/M/S +TROPIC/M/S +TROPICAL +TROT/S +TROUBLE/D/G/S +TROUBLEMAKER/M/S +TROUBLESHOOT/R/Z/G/S +TROUBLESOME/Y +TROUGH +TROUSER/S +TROUT +TROWEL/M/S +TRUANT/M/S +TRUCE +TRUCK/D/R/Z/G/S +TRUDGE/D +TRUE/D/T/R/G/S +TRUISM/M/S +TRULY +TRUMP/D/S +TRUMPET/R +TRUNCATE/D/G/S +TRUNCATION/M/S +TRUNK/M/S +TRUST/D/G/S +TRUSTEE/M/S +TRUSTFUL/P/Y +TRUSTINGLY +TRUSTWORTHY/P +TRUSTY +TRUTH +TRUTHFUL/P/Y +TRUTHS +TRY/D/R/Z/G/S +TUB/M/S +TUBE/R/Z/G/S +TUBERCULOSIS +TUCK/D/R/G/S +TUESDAY/M/S +TUFT/M/S +TUG/S +TUITION +TULIP/M/S +TUMBLE/D/R/Z/G/S +TUMOR/S +TUMULT/M/S +TUMULTUOUS +TUNABLE +TUNE/D/R/Z/G/S +TUNIC/M/S +TUNNEL/D/S +TUPLE/M/S +TURBAN/M/S +TURBO +TURBULENT/Y +TURF +TURING +TURKEY/M/S +TURMOIL/M/S +TURN/D/R/Z/G/J/S +TURNABLE +TURNIP/M/S +TURNOVER +TURPENTINE +TURQUOISE +TURRET/M/S +TURTLE/M/S +TUTOR/D/G/S +TUTORIAL/M/S +TV +TWAIN +TWANG +TWAS +TWEED +TWELFTH +TWELVE/S +TWENTY/H/S +TWICE +TWIG/M/S +TWILIGHT/M/S +TWILL +TWIN/M/S +TWINE/D/R +TWINKLE/D/R/G/S +TWIRL/D/R/G/S +TWIST/D/R/Z/G/S +TWITCH/D/G +TWITTER/D/G +TWO/M/S +TWOFOLD +TYING +TYPE/D/M/G/S +TYPECHECK/G/S/R +TYPEOUT +TYPESCRIPT/S +TYPEWRITER/M/S +TYPHOID +TYPICAL/P/Y +TYPIFY/D/G/S +TYPIST/M/S +TYPOGRAPHICAL/Y +TYPOGRAPHY +TYRANNY +TYRANT/M/S +UBIQUITOUS/Y +UBIQUITY +UGH +UGLY/P/T/R +UIMS +ULCER/M/S +ULTIMATE/Y +UMBRELLA/M/S +UMPIRE/M/S +UNABATED +UNABBREVIATED +UNABLE +UNACCEPTABILITY +UNACCEPTABLE +UNACCEPTABLY +UNACCUSTOMED +UNACKNOWLEDGED +UNADULTERATED +UNAESTHETICALLY +UNAFFECTED/P/Y +UNAIDED +UNALIENABILITY +UNALIENABLE +UNALTERABLY +UNALTERED +UNAMBIGUOUS/Y +UNAMBITIOUS +UNANALYZABLE +UNANIMOUS/Y +UNANSWERED +UNANTICIPATED +UNARMED +UNARY +UNASSAILABLE +UNASSIGNED +UNATTAINABILITY +UNATTAINABLE +UNATTENDED +UNATTRACTIVE/Y +UNAUTHORIZED +UNAVAILABILITY +UNAVAILABLE +UNAVOIDABLE +UNAVOIDABLY +UNAWARE/P/S +UNBALANCED +UNBEARABLE +UNBELIEVABLE +UNBIASED +UNBLOCK/D/G/S +UNBORN +UNBOUND/D +UNBREAKABLE +UNBROKEN +UNBUFFERED +UNCANCELED +UNCANCELLED +UNCANNY +UNCAPITALIZED +UNCAUGHT +UNCERTAIN/Y +UNCERTAINTY/S +UNCHANGEABLE +UNCHANGED +UNCHANGING +UNCHARTED +UNCLAIMED +UNCLE/M/S +UNCLEAN/P/Y +UNCLEAR/D +UNCLOSED +UNCOMFORTABLE +UNCOMFORTABLY +UNCOMMITTED +UNCOMMON/Y +UNCOMPROMISING +UNCOMPUTABLE +UNCONCERNED/Y +UNCONDITIONAL/Y +UNCONNECTED +UNCONSCIOUS/P/Y +UNCONSTRAINED +UNCONTROLLABILITY +UNCONTROLLABLE +UNCONTROLLABLY +UNCONTROLLED +UNCONVENTIONAL/Y +UNCONVINCED +UNCONVINCING +UNCORRECTABLE +UNCORRECTED +UNCOUNTABLE +UNCOUNTABLY +UNCOUTH +UNCOVER/D/G/S +UNDAUNTED/Y +UNDECIDABLE +UNDECIDED +UNDECLARED +UNDECOMPOSABLE +UNDEFINABILITY +UNDEFINED +UNDELETE +UNDELETED +UNDENIABLY +UNDER +UNDERBRUSH +UNDERDONE +UNDERESTIMATE/D/G/N/S +UNDERFLOW/D/G/S +UNDERFOOT +UNDERGO/G +UNDERGOES +UNDERGONE +UNDERGRADUATE/M/S +UNDERGROUND +UNDERLIE/S +UNDERLINE/D/G/J/S +UNDERLING/M/S +UNDERLYING +UNDERMINE/D/G/S +UNDERNEATH +UNDERPINNING/S +UNDERPLAY/D/G/S +UNDERSCORE/D/S +UNDERSTAND/G/J/S +UNDERSTANDABILITY +UNDERSTANDABLE +UNDERSTANDABLY +UNDERSTANDINGLY +UNDERSTATED +UNDERSTOOD +UNDERTAKE/R/Z/G/J/S +UNDERTAKEN +UNDERTOOK +UNDERWAY +UNDERWEAR +UNDERWENT +UNDERWORLD +UNDERWRITE/R/Z/G/S +UNDESIRABILITY +UNDESIRABLE +UNDETECTABLE +UNDETECTED +UNDETERMINED +UNDEVELOPED +UNDID +UNDIRECTED +UNDISCIPLINED +UNDISCOVERED +UNDISTORTED +UNDISTURBED +UNDIVIDED +UNDO/G/J +UNDOCUMENTED +UNDOES +UNDONE +UNDOUBTEDLY +UNDRESS/D/G/S +UNDUE +UNDULY +UNEASILY +UNEASY/P +UNECONOMICAL +UNEMBELLISHED +UNEMPLOYED +UNEMPLOYMENT +UNENDING +UNENLIGHTENING +UNEQUAL/D/Y +UNEQUIVOCAL/Y +UNESSENTIAL +UNEVALUATED +UNEVEN/P/Y +UNEVENTFUL +UNEXCUSED +UNEXPANDED +UNEXPECTED/Y +UNEXPLAINED +UNEXPLORED +UNEXTENDED +UNFAIR/P/Y +UNFAITHFUL/P/Y +UNFAMILIAR/Y +UNFAMILIARITY +UNFAVORABLE +UNFETTERED +UNFINISHED +UNFIT/P +UNFLAGGING +UNFOLD/D/G/S +UNFORESEEN +UNFORGEABLE +UNFORGIVING +UNFORMATTED +UNFORTUNATE/Y/S +UNFOUNDED +UNFRIENDLY/P +UNFULFILLED +UNGRAMMATICAL +UNGRATEFUL/P/Y +UNGROUNDED +UNGUARDED +UNGUIDED +UNHAPPILY +UNHAPPY/P/T/R +UNHEALTHY +UNHEEDED +UNICORN/M/S +UNIDENTIFIED +UNIDIRECTIONAL/Y +UNIDIRECTIONALITY +UNIFORM/D/Y/S +UNIFORMITY +UNIFY/D/R/Z/G/N/X/S +UNILATERAL +UNILLUMINATING +UNIMAGINABLE +UNIMPEDED +UNIMPLEMENTED +UNIMPORTANT +UNINDENTED +UNINFORMED +UNINITIALIZED +UNINTELLIGIBLE +UNINTENDED +UNINTENTIONAL/Y +UNINTERESTING/Y +UNINTERPRETED +UNINTERRUPTED/Y +UNION/M/S +UNIONIZATION +UNIONIZE/D/R/Z/G/S +UNIQUE/P/Y +UNISON +UNIT/M/S +UNITE/D/G/S +UNITY/M/S +UNIVALVE/M/S +UNIVERSAL/Y/S +UNIVERSALITY +UNIVERSE/M/S +UNIVERSITY/M/S +UNIX +UNJUST/Y +UNJUSTIFIED +UNKIND/P/Y +UNKNOWABLE +UNKNOWING/Y +UNKNOWN/S +UNLABELED +UNLAWFUL/Y +UNLEASH/D/G/S +UNLESS +UNLIKE/P/Y +UNLIMITED +UNLINK/D/G/S +UNLOAD/D/G/S +UNLOCK/D/G/S +UNLUCKY +UNMANAGEABLE +UNMANAGEABLY +UNMANNED +UNMARKED +UNMARRIED +UNMASKED +UNMATCHED +UNMISTAKABLE +UNMODIFIED +UNMOVED +UNNAMED +UNNATURAL/P/Y +UNNECESSARILY +UNNECESSARY +UNNEEDED +UNNOTICED +UNOBSERVABLE +UNOBSERVED +UNOBTAINABLE +UNOCCUPIED +UNOFFICIAL/Y +UNOPENED +UNOPTIMIZED +UNORDERED +UNPACK/D/G/S +UNPARALLELED +UNPARSED +UNPLANNED +UNPLEASANT/P/Y +UNPOPULAR +UNPOPULARITY +UNPRECEDENTED +UNPREDICTABLE +UNPRESCRIBED +UNPRESERVED +UNPRIMED +UNPROFITABLE +UNPROJECTED +UNPROTECTED +UNPROVABILITY +UNPROVABLE +UNPROVEN +UNPUBLISHED +UNQUALIFIED/Y +UNQUESTIONABLY +UNQUESTIONED +UNQUOTED +UNRAVEL/D/G/S +UNREACHABLE +UNREADABLE +UNREAL +UNREALISTIC +UNREALISTICALLY +UNREASONABLE/P +UNREASONABLY +UNRECOGNIZABLE +UNRECOGNIZED +UNRELATED +UNRELIABILITY +UNRELIABLE +UNREPORTED +UNREPRESENTABLE +UNRESOLVED +UNRESPONSIVE +UNREST +UNRESTRAINED +UNRESTRICTED/Y +UNRESTRICTIVE +UNROLL/D/G/S +UNRULY +UNSAFE/Y +UNSANITARY +UNSATISFACTORY +UNSATISFIABILITY +UNSATISFIABLE +UNSATISFIED +UNSATISFYING +UNSCRUPULOUS +UNSEEDED +UNSEEN +UNSELECTED +UNSELFISH/P/Y +UNSENT +UNSETTLED +UNSETTLING +UNSHAKEN +UNSHARED +UNSIGNED +UNSKILLED +UNSOLVABLE +UNSOLVED +UNSOPHISTICATED +UNSOUND +UNSPEAKABLE +UNSPECIFIED +UNSTABLE +UNSTEADY/P +UNSTRUCTURED +UNSUCCESSFUL/Y +UNSUITABLE +UNSUITED +UNSUPPORTED +UNSURE +UNSURPRISING/Y +UNSYNCHRONIZED +UNTAPPED +UNTERMINATED +UNTESTED +UNTHINKABLE +UNTIDY/P +UNTIE/D/S +UNTIL +UNTIMELY +UNTO +UNTOLD +UNTOUCHABLE/M/S +UNTOUCHED +UNTOWARD +UNTRAINED +UNTRANSLATED +UNTREATED +UNTRIED +UNTRUE +UNTRUTHFUL/P +UNTYING +UNUSABLE +UNUSED +UNUSUAL/Y +UNVARYING +UNVEIL/D/G/S +UNWANTED +UNWELCOME +UNWHOLESOME +UNWIELDY/P +UNWILLING/P/Y +UNWIND/R/Z/G/S +UNWISE/Y +UNWITTING/Y +UNWORTHY/P +UNWOUND +UNWRITTEN +UP +UPBRAID +UPDATE/D/R/G/S +UPGRADE/D/G/S +UPHELD +UPHILL +UPHOLD/R/Z/G/S +UPHOLSTER/D/R/G/S +UPKEEP +UPLAND/S +UPLIFT +UPON +UPPER +UPPERMOST +UPRIGHT/P/Y +UPRISING/M/S +UPROAR +UPROOT/D/G/S +UPSET/S +UPSHOT/M/S +UPSIDE +UPSTAIRS +UPSTREAM +UPTURN/D/G/S +UPWARD/S +URBAN +URBANA +URCHIN/M/S +URGE/D/G/J/S +URGENT/Y +URINATE/D/G/N/S +URINE +URN/M/S +US +USA +USABILITY +USABLE +USABLY +USAGE/S +USE/D/R/Z/G/S +USEFUL/P/Y +USELESS/P/Y +USENIX +USER'S +USHER/D/G/S +USUAL/Y +USURP/D/R +UTAH +UTENSIL/M/S +UTILITY/M/S +UTILIZATION/M/S +UTILIZE/D/G/S +UTMOST +UTOPIAN/M/S +UTTER/D/G/Y/S +UTTERANCE/M/S +UTTERMOST +UUCP +UZI +VACANCY/M/S +VACANT/Y +VACATE/D/G/X/S +VACATION/D/R/Z/G/S +VACUO +VACUOUS/Y +VACUUM/D/G +VAGABOND/M/S +VAGARY/M/S +VAGINA/M/S +VAGRANT/Y +VAGUE/P/T/R/Y +VAINLY +VALE/M/S +VALENCE/M/S +VALENTINE/M/S +VALET/M/S +VALIANT/Y +VALID/P/Y +VALIDATE/D/G/N/S +VALIDITY +VALLEY/M/S +VALOR +VALUABLE/S +VALUABLY +VALUATION/M/S +VALUE/D/R/Z/G/S +VALVE/M/S +VAN/M/S +VANCOUVER +VANDALIZE/D/G/S +VANE/M/S +VANILLA +VANISH/D/R/G/S +VANISHINGLY +VANITY/S +VANQUISH/D/G/S +VANTAGE +VAPOR/G/S +VARIABILITY +VARIABLE/P/M/S +VARIABLY +VARIANCE/M/S +VARIANT/Y/S +VARIATION/M/S +VARIETY/M/S +VARIOUS/Y +VARNISH/M/S +VARY/D/G/J/S +VASE/M/S +VASSAL +VAST/P/T/R/Y +VAT/M/S +VAUDEVILLE +VAULT/D/R/G/S +VAUNT/D +VAX +VAXEN +VAXES +VEAL +VECTOR/M/S +VECTORIZATION +VECTORIZING +VEE +VEER/D/G/S +VEGAS +VEGETABLE/M/S +VEGETARIAN/M/S +VEGETATE/D/G/N/V/S +VEHEMENCE +VEHEMENT/Y +VEHICLE/M/S +VEHICULAR +VEIL/D/G/S +VEIN/D/G/S +VELOCITY/M/S +VELVET +VENDOR/M/S +VENERABLE +VENGEANCE +VENISON +VENOM +VENOMOUS/Y +VENT/D/S +VENTILATE/D/G/N/S +VENTRICLE/M/S +VENTURE/D/R/Z/G/J/S +VERACITY +VERANDA/M/S +VERB/M/S +VERBAL/Y +VERBATIM +VERBOSE +VERBOSITY +VERDICT +VERDURE +VERGE/R/S +VERIFIABILITY +VERIFIABLE +VERIFY/D/R/Z/G/N/X/S +VERILY +VERITABLE +VERMIN +VERNACULAR +VERSA +VERSATILE +VERSATILITY +VERSE/D/G/N/X/S +VERSUS +VERTEBRATE/M/S +VERTEX +VERTICAL/P/Y +VERTICES +VERY +VESSEL/M/S +VEST/D/S +VESTIGE/M/S +VESTIGIAL +VETERAN/M/S +VETERINARIAN/M/S +VETERINARY +VETO/D/R +VETOES +VEX/D/G/S +VEXATION +VIA +VIABILITY +VIABLE +VIABLY +VIAL/M/S +VIBRATE/D/G/N/X +VICE/M/S +VICEROY +VICINITY +VICIOUS/P/Y +VICISSITUDE/M/S +VICTIM/M/S +VICTIMIZE/D/R/Z/G/S +VICTOR/M/S +VICTORIA +VICTORIOUS/Y +VICTORY/M/S +VICTUAL/R/S +VIDEO +VIDEOTAPE/M/S +VIE/D/R/S +VIEW/D/R/Z/G/S +VIEWABLE +VIEWPOINT/M/S +VIEWPORT/S +VIGILANCE +VIGILANT/Y +VIGILANTE/M/S +VIGNETTE/M/S +VIGOR +VIGOROUS/Y +VILE/P/Y +VILIFY/D/G/N/X/S +VILLA/M/S +VILLAGE/R/Z/S +VILLAIN/M/S +VILLAINOUS/P/Y +VILLAINY +VINDICTIVE/P/Y +VINE/M/S +VINEGAR +VINEYARD/M/S +VINTAGE +VIOLATE/D/G/N/X/S +VIOLATOR/M/S +VIOLENCE +VIOLENT/Y +VIOLET/M/S +VIOLIN/M/S +VIOLINIST/M/S +VIPER/M/S +VIRGIN/M/S +VIRGINIA +VIRGINITY +VIRTUAL/Y +VIRTUE/M/S +VIRTUOSO/M/S +VIRTUOUS/Y +VIRUS/M/S +VISA/S +VISAGE +VISCOUNT/M/S +VISCOUS +VISIBILITY +VISIBLE +VISIBLY +VISION/M/S +VISIONARY +VISIT/D/G/S +VISITATION/M/S +VISITOR/M/S +VISOR/M/S +VISTA/M/S +VISUAL/Y +VISUALIZATION +VISUALIZE/D/R/G/S +VITA +VITAE +VITAL/Y/S +VITALITY +VIVID/P/Y +VIZIER +VLSI +VMS +VOCABULARY/S +VOCAL/Y/S +VOCATION/M/S +VOCATIONAL/Y +VOGUE +VOICE/D/R/Z/G/S +VOID/D/R/G/S +VOLATILE +VOLATILITY/S +VOLCANIC +VOLCANO/M/S +VOLLEY +VOLLEYBALL/M/S +VOLT/S +VOLTAGE/S +VOLUME/M/S +VOLUNTARILY +VOLUNTARY +VOLUNTEER/D/G/S +VOMIT/D/G/S +VON +VOTE/D/R/Z/G/V/S +VOUCH/R/Z/G/S +VOW/D/R/G/S +VOWEL/M/S +VOYAGE/D/R/Z/G/J/S +VS +VULGAR/Y +VULNERABILITY/S +VULNERABLE +VULTURE/M/S +WADE/D/R/G/S +WAFER/M/S +WAFFLE/M/S +WAFT +WAG/S +WAGE/D/R/Z/G/S +WAGON/R/S +WAIL/D/G/S +WAIST/M/S +WAISTCOAT/M/S +WAIT/D/R/Z/G/S +WAITRESS/M/S +WAIVE/D/R/G/S +WAIVERABLE +WAKE/D/G/S +WAKEN/D/G +WALK/D/R/Z/G/S +WALL/D/G/S +WALLET/M/S +WALLOW/D/G/S +WALNUT/M/S +WALRUS/M/S +WALTZ/D/G/S +WAN/Y +WAND/Z +WANDER/D/R/Z/G/J/S +WANE/D/G/S +WANG +WANT/D/G/S +WANTON/P/Y +WAR/M/S +WARBLE/D/R/G/S +WARD/R/N/X/S +WARDROBE/M/S +WARE/S +WAREHOUSE/G/S +WARFARE +WARILY +WARLIKE +WARM/D/T/G/H/Y/S +WARMER/S +WARN/D/R/G/J/S +WARNINGLY +WARP/D/G/S +WARRANT/D/G/S +WARRANTY/M/S +WARRED +WARRING +WARRIOR/M/S +WARSHIP/M/S +WART/M/S +WARY/P +WAS +WASH/D/R/Z/G/J/S +WASHINGTON +WASN'T +WASP/M/S +WASTE/D/G/S +WASTEFUL/P/Y +WATCH/D/R/Z/G/J/S +WATCHFUL/P/Y +WATCHMAN +WATCHWORD/M/S +WATER/D/G/J/S +WATERFALL/M/S +WATERMELON +WATERPROOF/G +WATERWAY/M/S +WATERY +WAVE/D/R/Z/G/S +WAVEFORM/M/S +WAVEFRONT/M/S +WAVELENGTH +WAVELENGTHS +WAX/D/R/Z/G/N/S +WAXY +WAY/M/S +WAYSIDE +WAYWARD +WE'D +WE'LL +WE'RE +WE'VE +WE/T +WEAK/T/R/N/X/Y +WEAKEN/D/G/S +WEAKNESS/M/S +WEALTH +WEALTHS +WEALTHY/T +WEAN/D/G +WEAPON/M/S +WEAR/R/G/S +WEARABLE +WEARILY +WEARISOME/Y +WEARY/P/D/T/R/G +WEASEL/M/S +WEATHER/D/G/S +WEATHERCOCK/M/S +WEAVE/R/G/S +WEB/M/S +WED/S +WEDDED +WEDDING/M/S +WEDGE/D/G/S +WEDNESDAY/M/S +WEE/D +WEEDS +WEEK/Y/S +WEEKEND/M/S +WEEP/G/R/S/Z +WEIGH/D/G/J +WEIGHS +WEIGHT/D/G/S +WEIRD/Y +WELCOME/D/G/S +WELD/D/R/G/S +WELFARE +WELL/D/G/S +WENCH/M/S +WENT +WEPT +WERE +WEREN'T +WESLEY +WESTERN/R/Z +WESTWARD/S +WET/P/Y/S +WETTED +WETTER +WETTEST +WETTING +WHACK/D/G/S +WHALE/R/G/S +WHARF +WHARVES +WHAT/M +WHATEVER +WHATSOEVER +WHEAT/N +WHEEL/D/R/Z/G/J/S +WHELP +WHEN +WHENCE +WHENEVER +WHERE/M +WHEREABOUTS +WHEREAS +WHEREBY +WHEREIN +WHEREUPON +WHEREVER +WHETHER +WHICH +WHICHEVER +WHILE +WHIM/M/S +WHIMPER/D/G/S +WHIMSICAL/Y +WHIMSY/M/S +WHINE/D/G/S +WHIP/M/S +WHIPPED +WHIPPER/M/S +WHIPPING/M/S +WHIRL/D/G/S +WHIRLPOOL/M/S +WHIRLWIND +WHIRR/G +WHISK/D/R/Z/G/S +WHISKEY +WHISPER/D/G/J/S +WHISTLE/D/R/Z/G/S +WHIT/X +WHITE/P/T/R/G/Y/S +WHITEN/D/R/Z/G/S +WHITESPACE +WHITEWASH/D +WHITTLE/D/G/S +WHIZ +WHIZZED +WHIZZES +WHIZZING +WHO/M +WHOEVER +WHOLE/P/S +WHOLEHEARTED/Y +WHOLESALE/R/Z +WHOLESOME/P +WHOLLY +WHOM +WHOMEVER +WHOOP/D/G/S +WHORE/M/S +WHORL/M/S +WHOSE +WHY +WICK/D/R/S +WICKED/P/Y +WIDE/T/R/Y +WIDEN/D/R/G/S +WIDESPREAD +WIDOW/D/R/Z/S +WIDTH +WIDTHS +WIELD/D/R/G/S +WIFE/M/Y +WIG/M/S +WIGWAM +WILD/P/T/R/Y +WILDCARD/S +WILDCAT/M/S +WILDERNESS +WILDLIFE +WILE/S +WILL/D/G/S +WILLFUL/Y +WILLIAM/M +WILLINGLY +WILLINGNESS +WILLOW/M/S +WILT/D/G/S +WILY/P +WIN/S +WINCE/D/G/S +WIND/D/R/Z/G/S +WINDMILL/M/S +WINDOW/M/S +WINDY +WINE/D/R/Z/G/S +WING/D/G/S +WINK/D/R/G/S +WINNER/M/S +WINNING/Y/S +WINTER/D/G/S +WINTRY +WIPE/D/R/Z/G/S +WIRE/D/G/S +WIRELESS +WIRETAP/M/S +WIRY/P +WISCONSIN +WISDOM/S +WISE/D/T/R/Y +WISH/D/R/Z/G/S +WISHFUL +WISP/M/S +WISTFUL/P/Y +WIT/M/S +WITCH/G/S +WITCHCRAFT +WITH/R/Z +WITHAL +WITHDRAW/G/S +WITHDRAWAL/M/S +WITHDRAWN +WITHDREW +WITHHELD +WITHHOLD/R/Z/G/J/S +WITHIN +WITHOUT +WITHSTAND/G/S +WITHSTOOD +WITNESS/D/G/S +WITTY +WIVES +WIZARD/M/S +WOE +WOEFUL/Y +WOKE +WOLF +WOLVES +WOMAN/M/Y +WOMANHOOD +WOMB/M/S +WOMEN/M +WON +WON'T +WONDER/D/G/S +WONDERFUL/P/Y +WONDERINGLY +WONDERMENT +WONDROUS/Y +WONT/D +WOO/D/R/G/S +WOOD/D/N/S +WOODCHUCK/M/S +WOODCOCK/M/S +WOODENLY +WOODENNESS +WOODLAND +WOODMAN +WOODPECKER/M/S +WOODWORK/G +WOODY +WOOF/D/R/Z/G/S +WOOL/N/Y/S +WORD/D/M/G/S +WORDILY +WORDY/P +WORE +WORK/D/R/Z/G/J/S +WORKABLE +WORKABLY +WORKBENCH/M/S +WORKBOOK/M/S +WORKHORSE/M/S +WORKINGMAN +WORKLOAD +WORKMAN +WORKMANSHIP +WORKMEN +WORKSHOP/M/S +WORKSTATION/S +WORLD/M/Y/S +WORLDLINESS +WORLDWIDE +WORM/D/G/S +WORN +WORRISOME +WORRY/D/R/Z/G/S +WORRYINGLY +WORSE +WORSHIP/D/R/G/S +WORSHIPFUL +WORST/D +WORTH +WORTHLESS/P +WORTHS +WORTHWHILE/P +WORTHY/P/T +WOULD +WOULDN'T +WOUND/D/G/S +WOVE +WOVEN +WRANGLE/D/R +WRAP/M/S +WRAPPED +WRAPPER/M/S +WRAPPING/S +WRATH +WREAK/S +WREATH/D/S +WRECK/D/R/Z/G/S +WRECKAGE +WREN/M/S +WRENCH/D/G/S +WREST +WRESTLE/R/G/J/S +WRETCH/D/S +WRETCHEDNESS +WRIGGLE/D/R/G/S +WRING/R/S +WRINKLE/D/S +WRIST/M/S +WRISTWATCH/M/S +WRIT/M/S +WRITABLE +WRITE/R/Z/G/J/S +WRITER'S +WRITHE/D/G/S +WRITTEN +WRONG/D/G/Y/S +WROTE +WROUGHT +WRUNG +XENIX +XEROX +YALE +YANK/D/G/S +YARD/M/S +YARDSTICK/M/S +YARN/M/S +YAWN/R/G +YEA/S +YEAR/M/Y/S +YEARN/D/G/J +YEAST/M/S +YELL/D/R/G +YELLOW/P/D/T/R/G/S +YELLOWISH +YELP/D/G/S +YEOMAN +YEOMEN +YES +YESTERDAY +YET +YIELD/D/G/S +YOKE/M/S +YON +YONDER +YORK/R/Z +YORKTOWN +YOU'D +YOU'LL +YOU'RE +YOU'VE +YOU/H +YOUNG/T/R/Y +YOUNGSTER/M/S +YOUR/S +YOURSELF +YOURSELVES +YOUTHFUL/P/Y +YOUTHS +YUGOSLAVIA +ZEAL +ZEALOUS/P/Y +ZEBRA/M/S +ZENITH +ZERO/D/G/H/S +ZEROES +ZEST +ZIGZAG +ZINC +ZODIAC +ZONAL/Y +ZONE/D/G/S +ZOO/M/S +ZOOLOGICAL/Y +ZOOM/G Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell.asd =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell.asd (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spell.asd (revision 8058) @@ -0,0 +1,16 @@ +;;; -*- mode: lisp -*- +(defpackage :spell-system (:use :cl :asdf)) +(in-package :spell-system) + +(defsystem spell + :version "0.4" + :components ((:file "package") + (:file "constants" :depends-on ("package")) + (:file "hashing" :depends-on ("package")) + (:file "flags") + (:file "classes" :depends-on ("package")) + (:file "build" :depends-on ("constants" "hashing" + "flags" "classes")) + ;; kind of a fake dependency + (:file "io" :depends-on ("build")) + (:file "correlate" :depends-on ("build")))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spellcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spellcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spell/spellcoms.lisp (revision 8058) @@ -0,0 +1,822 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob Maclachlan. +;;; +;;; This file contains the code to implement commands using the spelling +;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary +;;; augmenting stuff in Spell-Augment.Lisp. + +(in-package "HEMLOCK") + + + +(defstruct (spell-info (:print-function print-spell-info) + (:constructor make-spell-info (pathname))) + pathname ;Dictionary file. + insertions) ;Incremental insertions for this dictionary. + +(defun print-spell-info (obj str n) + (declare (ignore n)) + (let ((pn (spell-info-pathname obj))) + (format str "#" + (and pn (namestring pn))))) + + +(defattribute "Spell Word Character" + "One if the character is one that is present in the spell dictionary, + zero otherwise.") + +(do-alpha-chars (c :both) + (setf (character-attribute :spell-word-character c) 1)) +(setf (character-attribute :spell-word-character #\') 1) + + +(defvar *spelling-corrections* (make-hash-table :test #'equal) + "Mapping from incorrect words to their corrections.") + +(defvar *ignored-misspellings* (make-hash-table :test #'equal) + "A hashtable with true values for words that will be quietly ignored when + they appear.") + +(defhvar "Spell Ignore Uppercase" + "If true, then \"Check Word Spelling\" and \"Correct Buffer Spelling\" will + ignore unknown words that are all uppercase. This is useful for + abbreviations and cryptic formatter directives." + :value nil) + + + + +;;;; Basic Spelling Correction Command (Esc-$ in EMACS) + +(defcommand "Check Word Spelling" (p) + "Check the spelling of the previous word and offer possible corrections + if the word in unknown. To add words to the dictionary from a text file see + the command \"Augment Spelling Dictionary\"." + "Check the spelling of the previous word and offer possible correct + spellings if the word is known to be misspelled." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let* ((region (spell-previous-word (current-point) nil)) + (word (if region + (region-to-string region) + (editor-error "No previous word."))) + (folded (string-upcase word))) + (message "Checking spelling of ~A." word) + (unless (check-out-word-spelling word folded) + (get-word-correction (region-start region) word folded)))) + + + +;;;; Auto-Spell mode: + +(defhvar "Check Word Spelling Beep" + "If true, \"Auto Check Word Spelling\" will beep when an unknown word is + found." + :value t) + +(defhvar "Correct Unique Spelling Immediately" + "If true, \"Auto Check Word Spelling\" will immediately attempt to correct any + unknown word, automatically making the correction if there is only one + possible." + :value t) + + +(defhvar "Default User Spelling Dictionary" + "This is the pathname of a dictionary to read the first time \"Spell\" mode + is entered in a given editing session. When \"Set Buffer Spelling + Dictionary\" or the \"dictionary\" file option is used to specify a + dictionary, this default one is read also. It defaults to nil." + :value nil) + +(defvar *default-user-dictionary-read-p* nil) + +(defun maybe-read-default-user-spelling-dictionary () + (let ((default-dict (value default-user-spelling-dictionary))) + (when (and default-dict (not *default-user-dictionary-read-p*)) + (spell:maybe-read-spell-dictionary) + (spell:spell-read-dictionary (truename default-dict)) + (setf *default-user-dictionary-read-p* t)))) + + +(defmode "Spell" + :transparent-p t :precedence 1.0 :setup-function 'spell-mode-setup) + +(defun spell-mode-setup (buffer) + (defhvar "Buffer Misspelled Words" + "This variable holds a ring of marks pointing to misspelled words." + :buffer buffer :value (make-ring 10 #'delete-mark)) + (maybe-read-default-user-spelling-dictionary)) + +(defcommand "Auto Spell Mode" (p) + "Toggle \"Spell\" mode in the current buffer. When in \"Spell\" mode, + the spelling of each word is checked after it is typed." + "Toggle \"Spell\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Spell") + (not (buffer-minor-mode (current-buffer) "Spell")))) + + +(defcommand "Auto Check Word Spelling" (p) + "Check the spelling of the previous word and display a message in the echo + area if the word is not in the dictionary. To add words to the dictionary + from a text file see the command \"Augment Spelling Dictionary\". If a + replacement for an unknown word has previously been specified, then the + replacement will be made immediately. If \"Correct Unique Spelling + Immediately\" is true, then this command will immediately correct words + which have a unique correction. If there is no obvious correction, then we + place the word in a ring buffer for access by the \"Correct Last Misspelled + Word\" command. If \"Check Word Spelling Beep\" is true, then this command + beeps when an unknown word is found, in addition to displaying the message." + "Check the spelling of the previous word, making obvious corrections, or + queuing the word in buffer-misspelled-words if we are at a loss." + (declare (ignore p)) + (unless (eq (last-command-type) :spell-check) + (spell:maybe-read-spell-dictionary) + (let ((region (spell-previous-word (current-point) t))) + (when region + (let* ((word (nstring-upcase (region-to-string region))) + (len (length word))) + (declare (simple-string word)) + (when (and (<= 2 len spell:max-entry-length) + (not (spell:spell-try-word word len))) + (let ((found (gethash word *spelling-corrections*)) + (save (region-to-string region))) + (cond (found + (undoable-replace-word (region-start region) save found) + (message "Corrected ~S to ~S." save found) + (when (value check-word-spelling-beep) (beep))) + ((and (value spell-ignore-uppercase) + (every #'upper-case-p save)) + (unless (gethash word *ignored-misspellings*) + (setf (gethash word *ignored-misspellings*) t) + (message "Ignoring ~S." save))) + (t + (let ((close (spell:spell-collect-close-words word))) + (cond ((and close + (null (rest close)) + (value correct-unique-spelling-immediately)) + (let ((fix (first close))) + (undoable-replace-word (region-start region) + save fix) + (message "Corrected ~S to ~S." save fix))) + (t + (ring-push (copy-mark (region-end region) + :right-inserting) + (value buffer-misspelled-words)) + (let ((nclose + (do ((i 0 (1+ i)) + (words close (cdr words)) + (nwords () (cons (list i (car words)) + nwords))) + ((null words) (nreverse nwords))))) + (message + "Word ~S not found.~ + ~@[ Corrections:~:{ ~D=~A~}~]" + save nclose))))) + (when (value check-word-spelling-beep) (beep)))))))))) + (setf (last-command-type) :spell-check)) + +(defcommand "Correct Last Misspelled Word" (p) + "Fix a misspelling found by \"Auto Check Word Spelling\". This prompts for + a single character command to determine which action to take to correct the + problem." + "Prompt for a single character command to determine how to fix up a + misspelling detected by Check-Word-Spelling-Command." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (do ((info (value spell-information))) + ((sub-correct-last-misspelled-word info)))) + +(defun sub-correct-last-misspelled-word (info) + (let* ((missed (value buffer-misspelled-words)) + (region (cond ((zerop (ring-length missed)) + (editor-error "No recently misspelled word.")) + ((spell-previous-word (ring-ref missed 0) t)) + (t (editor-error "No recently misspelled word.")))) + (word (region-to-string region)) + (folded (string-upcase word)) + (point (current-point)) + (save (copy-mark point)) + (res t)) + (declare (simple-string word)) + (unwind-protect + (progn + (when (check-out-word-spelling word folded) + (delete-mark (ring-pop missed)) + (return-from sub-correct-last-misspelled-word t)) + (move-mark point (region-end region)) + (command-case (:prompt "Action: " + :change-window nil + :help "Type a single character command to do something to the misspelled word.") + (#\c "Try to find a correction for this word." + (unless (get-word-correction (region-start region) word folded) + (reprompt))) + (#\i "Insert this word in the dictionary." + (spell:spell-add-entry folded) + (push folded (spell-info-insertions info)) + (message "~A inserted in the dictionary." word)) + (#\r "Prompt for a word to replace this word with." + (let ((s (prompt-for-string :prompt "Replace with: " + :default word + :help "Type a string to replace occurrences of this word with."))) + (delete-region region) + (insert-string point s) + (setf (gethash folded *spelling-corrections*) s))) + (:cancel "Ignore this word and go to the previous misspelled word." + (setq res nil)) + (:recursive-edit + "Go into a recursive edit and leave when it exits." + (do-recursive-edit)) + ((:exit #\q) "Exit and forget about this word.") + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + "Choose this numbered word as the correct spelling." + (let ((num (digit-char-p (ext:key-event-char *last-key-event-typed*))) + (close-words (spell:spell-collect-close-words folded))) + (cond ((> num (length close-words)) + (editor-error "Choice out of range.")) + (t (let ((s (nth num close-words))) + (setf (gethash folded *spelling-corrections*) s) + (undoable-replace-word (region-start region) + word s))))))) + (delete-mark (ring-pop missed)) + res) + (move-mark point save) + (delete-mark save)))) + +(defhvar "Spelling Un-Correct Prompt for Insert" + "When this is set, \"Undo Last Spelling Correction\" will prompt before + inserting the old word into the dictionary." + :value nil) + +(defcommand "Undo Last Spelling Correction" (p) + "Undo the last incremental spelling correction. + The \"correction\" is replaced with the old word, and the old word is + inserted in the dictionary. When \"Spelling Un-Correct Prompt for Insert\" + is set, the user is asked about inserting the old word. Any automatic + replacement for the old word is eliminated." + "Undo the last incremental spelling correction, nuking any undesirable + side-effects." + (declare (ignore p)) + (unless (hemlock-bound-p 'last-spelling-correction-mark) + (editor-error "No last spelling correction.")) + (let ((mark (value last-spelling-correction-mark)) + (words (value last-spelling-correction-words))) + (unless words + (editor-error "No last spelling correction.")) + (let* ((new (car words)) + (old (cdr words)) + (folded (string-upcase old))) + (declare (simple-string old new folded)) + (remhash folded *spelling-corrections*) + (delete-characters mark (length new)) + (insert-string mark old) + (setf (value last-spelling-correction-words) nil) + (when (or (not (value spelling-un-correct-prompt-for-insert)) + (prompt-for-y-or-n + :prompt (list "Insert ~A into spelling dictionary? " folded) + :default t + :default-string "Y")) + (push folded (spell-info-insertions (value spell-information))) + (spell:maybe-read-spell-dictionary) + (spell:spell-add-entry folded) + (message "Added ~S to spelling dictionary." old))))) + + +;;; Check-Out-Word-Spelling -- Internal +;;; +;;; Return Nil if Word is a candidate for correction, otherwise +;;; return T and message as to why it isn't. +;;; +(defun check-out-word-spelling (word folded) + (declare (simple-string word)) + (let ((len (length word))) + (cond ((= len 1) + (message "Single character words are not in the dictionary.") t) + ((> len spell:max-entry-length) + (message "~A is too long for the dictionary." word) t) + (t + (multiple-value-bind (idx flagp) (spell:spell-try-word folded len) + (when idx + (message "Found it~:[~; because of ~A~]." flagp + (spell:spell-root-word idx)) + t)))))) + +;;; Get-Word-Correction -- Internal +;;; +;;; Find all known close words to the either unknown or incorrectly +;;; spelled word we are checking. Word is the unmunged word, and Folded is +;;; the uppercased word. Mark is a mark which points to the beginning of +;;; the offending word. Return True if we successfully corrected the word. +;;; +(defun get-word-correction (mark word folded) + (let ((close-words (spell:spell-collect-close-words folded))) + (declare (list close-words)) + (if close-words + (with-pop-up-display (s :height 3) + (do ((i 0 (1+ i)) + (words close-words (cdr words))) + ((null words)) + (format s "~36R=~A " i (car words))) + (finish-output s) + (let* ((key-event (prompt-for-key-event + :prompt "Correction choice: ")) + (num (digit-char-p (ext:key-event-char key-event) 36))) + (cond ((not num) (return-from get-word-correction nil)) + ((> num (length close-words)) + (editor-error "Choice out of range.")) + (t + (let ((s (nth num close-words))) + (setf (gethash folded *spelling-corrections*) s) + (undoable-replace-word mark word s))))) + (return-from get-word-correction t)) + (with-pop-up-display (s :height 1) + (write-line "No corrections found." s) + nil)))) + + +;;; Undoable-Replace-Word -- Internal +;;; +;;; Like Spell-Replace-Word, but makes annotations in buffer local variables +;;; so that "Undo Last Spelling Correction" can undo it. +;;; +(defun undoable-replace-word (mark old new) + (unless (hemlock-bound-p 'last-spelling-correction-mark) + (let ((buffer (current-buffer))) + (defhvar "Last Spelling Correction Mark" + "This variable holds a park pointing to the last spelling correction." + :buffer buffer :value (copy-mark (buffer-start-mark buffer))) + (defhvar "Last Spelling Correction Words" + "The replacement done for the last correction: (new . old)." + :buffer buffer :value nil))) + (move-mark (value last-spelling-correction-mark) mark) + (setf (value last-spelling-correction-words) (cons new old)) + (spell-replace-word mark old new)) + + + +;;;; Buffer Correction + +(defvar *spell-word-characters* + (make-array char-code-limit :element-type 'bit :initial-element 0) + "Characters that are legal in a word for spelling checking purposes.") + +(do-alpha-chars (c :both) + (setf (sbit *spell-word-characters* (char-code c)) 1)) +(setf (sbit *spell-word-characters* (char-code #\')) 1) + + +(defcommand "Correct Buffer Spelling" (p) + "Correct spelling over whole buffer. A log of the found misspellings is + kept in the buffer \"Spell Corrections\". For each unknown word the + user may accept it, insert it in the dictionary, correct its spelling + with one of the offered possibilities, replace the word with a user + supplied word, or go into a recursive edit. Words may be added to the + dictionary in advance from a text file (see the command \"Augment + Spelling Dictionary\")." + "Correct spelling over whole buffer." + (declare (ignore p)) + (clrhash *ignored-misspellings*) + (let* ((buffer (current-buffer)) + (log (or (make-buffer "Spelling Corrections") + (getstring "Spelling Corrections" *buffer-names*))) + (point (buffer-end (buffer-point log))) + (*standard-output* (make-hemlock-output-stream point)) + (window (or (car (buffer-windows log)) (make-window point)))) + (format t "~&Starting spelling checking of buffer ~S.~2%" + (buffer-name buffer)) + (spell:maybe-read-spell-dictionary) + (correct-buffer-spelling buffer window) + (delete-window window) + (close *standard-output*))) + +;;; CORRECT-BUFFER-SPELLING scans through buffer a line at a time, grabbing the +;;; each line's string and breaking it up into words using the +;;; *spell-word-characters* mask. We try the spelling of each word, and if it +;;; is unknown, we call FIX-WORD and resynchronize when it returns. +;;; +(defun correct-buffer-spelling (buffer window) + (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) + (info (if (hemlock-bound-p 'spell-information :buffer buffer) + (variable-value 'spell-information :buffer buffer) + (value spell-information))) + (mask *spell-word-characters*) + (word (make-string spell:max-entry-length))) + ((null line)) + (declare (simple-bit-vector mask) (simple-string word)) + (block line + (let* ((string (line-string line)) + (length (length string))) + (declare (simple-string string)) + (do ((start 0 (or skip-apostrophes end)) + (skip-apostrophes nil nil) + end) + (nil) + ;; + ;; Find word start. + (loop + (when (= start length) (return-from line)) + (when (/= (bit mask (char-code (schar string start))) 0) (return)) + (incf start)) + ;; + ;; Find the end. + (setq end (1+ start)) + (loop + (when (= end length) (return)) + (when (zerop (bit mask (char-code (schar string end)))) (return)) + (incf end)) + (multiple-value-setq (end skip-apostrophes) + (correct-buffer-word-end string start end)) + ;; + ;; Check word. + (let ((word-len (- end start))) + (cond + ((= word-len 1)) + ((> word-len spell:max-entry-length) + (format t "Not checking ~S -- too long for dictionary.~2%" + word)) + (t + ;; + ;; Copy the word and uppercase it. + (do* ((i (1- end) (1- i)) + (j (1- word-len) (1- j))) + ((zerop j) + (setf (schar word 0) (char-upcase (schar string i)))) + (setf (schar word j) (char-upcase (schar string i)))) + (unless (spell:spell-try-word word word-len) + (move-to-position (current-point) start line) + (fix-word (subseq word 0 word-len) (subseq string start end) + window info) + (let ((point (current-point))) + (setq end (mark-charpos point) + line (mark-line point) + string (line-string line) + length (length string)))))))))))) + +;;; CORRECT-BUFFER-WORD-END takes a line string from CORRECT-BUFFER-SPELLING, a +;;; start, and a end. It places end to exclude from the word apostrophes used +;;; for quotation marks, possessives, and funny plurals (e.g., A's and AND's). +;;; Every word potentially can be followed by "'s", and any clown can use the +;;; `` '' Scribe ligature. This returns the value to use for end of the word +;;; and the value to use as the end when continuing to find the next word in +;;; string. +;;; +(defun correct-buffer-word-end (string start end) + (cond ((and (> (- end start) 2) + (char= (char-upcase (schar string (1- end))) #\S) + (char= (schar string (- end 2)) #\')) + ;; Use roots of possessives and funny plurals (e.g., A's and AND's). + (values (- end 2) end)) + (t + ;; Maybe backup over apostrophes used for quotation marks. + (do ((i (1- end) (1- i))) + ((= i start) (values end end)) + (when (char/= (schar string i) #\') + (return (values (1+ i) end))))))) + +;;; Fix-Word -- Internal +;;; +;;; Handles the case where the word has a known correction. If is does +;;; not then call Correct-Buffer-Word-Not-Found. In either case, the +;;; point is left at the place to resume checking. +;;; +(defun fix-word (word unfolded-word window info) + (declare (simple-string word unfolded-word)) + (let ((correction (gethash word *spelling-corrections*)) + (mark (current-point))) + (cond (correction + (format t "Replacing ~S with ~S.~%" unfolded-word correction) + (spell-replace-word mark unfolded-word correction)) + ((and (value spell-ignore-uppercase) + (every #'upper-case-p unfolded-word)) + (character-offset mark (length word)) + (unless (gethash word *ignored-misspellings*) + (setf (gethash word *ignored-misspellings*) t) + (format t "Ignoring ~S.~%" unfolded-word))) + (t + (correct-buffer-word-not-found word unfolded-word window info))))) + +(defun correct-buffer-word-not-found (word unfolded-word window info) + (declare (simple-string word unfolded-word)) + (let* ((close-words (spell:spell-collect-close-words word)) + (close-words-len (length (the list close-words))) + (mark (current-point)) + (wordlen (length word))) + (format t "Unknown word: ~A~%" word) + (cond (close-words + (format t "~[~;A~:;Some~]~:* possible correction~[~; is~:;s are~]: " + close-words-len) + (if (= close-words-len 1) + (write-line (car close-words)) + (let ((n 0)) + (dolist (w close-words (terpri)) + (format t "~36R=~A " n w) + (incf n))))) + (t + (write-line "No correction possibilities found."))) + (let ((point (buffer-point (window-buffer window)))) + (unless (displayed-p point window) + (center-window window point))) + (command-case + (:prompt "Action: " + :help "Type a single letter command, or help character for help." + :change-window nil) + (#\i "Insert unknown word into dictionary for future lookup." + (spell:spell-add-entry word) + (push word (spell-info-insertions info)) + (format t "~S added to dictionary.~2%" word)) + (#\c "Correct the unknown word with possible correct spellings." + (unless close-words + (write-line "There are no possible corrections.") + (reprompt)) + (let ((num (if (= close-words-len 1) 0 + (digit-char-p (ext:key-event-char + (prompt-for-key-event + :prompt "Correction choice: ")) + 36)))) + (unless num (reprompt)) + (when (> num close-words-len) + (beep) + (write-line "Response out of range.") + (reprompt)) + (let ((choice (nth num close-words))) + (setf (gethash word *spelling-corrections*) choice) + (spell-replace-word mark unfolded-word choice))) + (terpri)) + (#\a "Accept the word as correct (that is, ignore it)." + (character-offset mark wordlen)) + (#\r "Replace the unknown word with a supplied replacement." + (let ((s (prompt-for-string + :prompt "Replacement Word: " + :default unfolded-word + :help "String to replace the unknown word with."))) + (setf (gethash word *spelling-corrections*) s) + (spell-replace-word mark unfolded-word s)) + (terpri)) + (:recursive-edit + "Go into a recursive edit and resume correction where the point is left." + (do-recursive-edit))))) + +;;; Spell-Replace-Word -- Internal +;;; +;;; Replaces Old with New, starting at Mark. The case of Old is used +;;; to derive the new case. +;;; +(defun spell-replace-word (mark old new) + (declare (simple-string old new)) + (let ((res (cond ((lower-case-p (schar old 0)) + (string-downcase new)) + ((lower-case-p (schar old 1)) + (let ((res (string-downcase new))) + (setf (char res 0) (char-upcase (char res 0))) + res)) + (t + (string-upcase new))))) + (with-mark ((m mark :left-inserting)) + (delete-characters m (length old)) + (insert-string m res)))) + + + +;;;; User Spelling Dictionaries. + +(defvar *pathname-to-spell-info* (make-hash-table :test #'equal) + "This maps dictionary files to spelling information.") + +(defhvar "Spell Information" + "This is the information about a spelling dictionary and its incremental + insertions." + :value (make-spell-info nil)) + +(define-file-option "Dictionary" (buffer file) + (let* ((dict (merge-pathnames + file + (make-pathname :defaults (buffer-default-pathname buffer) + :type "dict"))) + (dictp (probe-file dict))) + (if dictp + (set-buffer-spelling-dictionary-command nil dictp buffer) + (loud-message "Couldn't find dictionary ~A." (namestring dict))))) + +;;; SAVE-DICTIONARY-ON-WRITE is on the "Write File Hook" in buffers with +;;; the "dictionary" file option. +;;; +(defun save-dictionary-on-write (buffer) + (when (hemlock-bound-p 'spell-information :buffer buffer) + (save-spelling-insertions + (variable-value 'spell-information :buffer buffer)))) + + +(defcommand "Save Incremental Spelling Insertions" (p) + "Append incremental spelling dictionary insertions to a file. The file + is prompted for unless \"Set Buffer Spelling Dictionary\" has been + executed in the buffer." + "Append incremental spelling dictionary insertions to a file." + (declare (ignore p)) + (let* ((info (value spell-information)) + (file (or (spell-info-pathname info) + (value default-user-spelling-dictionary) + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :must-exist nil + :help + "Name of the dictionary file to append dictionary insertions to.")))) + (save-spelling-insertions info file) + (let* ((ginfo (variable-value 'spell-information :global)) + (insertions (spell-info-insertions ginfo))) + (when (and insertions + (prompt-for-y-or-n + :prompt + `("Global spelling insertions exist.~%~ + Save these to ~A also? " + ,(namestring file) + :default t + :default-string "Y")) + (save-spelling-insertions ginfo file)))))) + +(defun save-spelling-insertions (info &optional + (name (spell-info-pathname info))) + (when (spell-info-insertions info) + (with-open-file (stream name + :direction :output :element-type 'base-char + :if-exists :append :if-does-not-exist :create) + (dolist (w (spell-info-insertions info)) + (write-line w stream))) + (setf (spell-info-insertions info) ()) + (message "Incremental spelling insertions for ~A written." + (namestring name)))) + +(defcommand "Set Buffer Spelling Dictionary" (p &optional file buffer) + "Prompts for the dictionary file to associate with the current buffer. + If this file has not been read for any other buffer, then it is read. + Incremental spelling insertions from this buffer can be appended to + this file with \"Save Incremental Spelling Insertions\"." + "Sets the buffer's spelling dictionary and reads it if necessary." + (declare (ignore p)) + (maybe-read-default-user-spelling-dictionary) + (let* ((file (truename (or file + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :help + "Name of the dictionary file to add into the current dictionary.")))) + (file-name (namestring file)) + (spell-info-p (gethash file-name *pathname-to-spell-info*)) + (spell-info (or spell-info-p (make-spell-info file))) + (buffer (or buffer (current-buffer)))) + (defhvar "Spell Information" + "This is the information about a spelling dictionary and its incremental + insertions." + :value spell-info :buffer buffer) + (add-hook write-file-hook 'save-dictionary-on-write) + (unless spell-info-p + (setf (gethash file-name *pathname-to-spell-info*) spell-info) + (read-spelling-dictionary-command nil file)))) + +(defcommand "Read Spelling Dictionary" (p &optional file) + "Adds entries to the dictionary from a file in the following format: + + entry1/flag1/flag2/flag3 + entry2 + entry3/flag1/flag2/flag3/flag4/flag5. + + The flags are single letter indicators of legal suffixes for the entry; + the available flags and their correct use may be found at the beginning + of spell-correct.lisp in the Hemlock sources. There must be exactly one + entry per line, and each line must be flushleft." + "Add entries to the dictionary from a text file in a specified format." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (spell:spell-read-dictionary + (or file + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :help + "Name of the dictionary file to add into the current dictionary.")))) + +(defun dictionary-name-default () + (make-pathname :defaults (buffer-default-pathname (current-buffer)) + :type "dict")) + +(defcommand "Add Word to Spelling Dictionary" (p) + "Add the previous word to the spelling dictionary." + "Add the previous word to the spelling dictionary." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let ((word (region-to-string (spell-previous-word (current-point) nil)))) + ;; + ;; SPELL:SPELL-ADD-ENTRY destructively uppercases word. + (when (spell:spell-add-entry word) + (message "Word ~(~S~) added to the spelling dictionary." word) + (push word (spell-info-insertions (value spell-information)))))) + +(defcommand "Remove Word from Spelling Dictionary" (p) + "Prompts for word to remove from the spelling dictionary." + "Prompts for word to remove from the spelling dictionary." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let* ((word (prompt-for-string + :prompt "Word to remove from spelling dictionary: " + :trim t)) + (upword (string-upcase word))) + (declare (simple-string word)) + (multiple-value-bind (index flagp) + (spell:spell-try-word upword (length word)) + (unless index + (editor-error "~A not in dictionary." upword)) + (if flagp + (remove-spelling-word upword) + (let ((flags (spell:spell-root-flags index))) + (when (or (not flags) + (prompt-for-y-or-n + :prompt + `("Deleting ~A also removes words formed from this root and these flags: ~% ~ + ~S.~%~ + Delete word anyway? " + ,word ,flags) + :default t + :default-string "Y")) + (remove-spelling-word upword))))))) + +;;; REMOVE-SPELLING-WORD removes the uppercase word word from the spelling +;;; dictionary and from the spelling informations incremental insertions list. +;;; +(defun remove-spelling-word (word) + (let ((info (value spell-information))) + (spell:spell-remove-entry word) + (setf (spell-info-insertions info) + (delete word (spell-info-insertions info) :test #'string=)))) + +(defcommand "List Incremental Spelling Insertions" (p) + "Display the incremental spelling insertions for the current buffer's + associated spelling dictionary file." + "Display the incremental spelling insertions for the current buffer's + associated spelling dictionary file." + (declare (ignore p)) + (let* ((info (value spell-information)) + (file (spell-info-pathname info)) + (insertions (spell-info-insertions info))) + (declare (list insertions)) + (with-pop-up-display (s :height (1+ (length insertions))) + (if file + (format s "Incremental spelling insertions for dictionary ~A:~%" + (namestring file)) + (write-line "Global incremental spelling insertions:" s)) + (dolist (w insertions) + (write-line w s))))) + + + + +;;;; Utilities for above stuff. + +;;; SPELL-PREVIOUS-WORD returns as a region the current or previous word, using +;;; the spell word definition. If there is no such word, return nil. If end-p +;;; is non-nil, then mark ends the word even if there is a non-delimiter +;;; character after it. +;;; +;;; Actually, if mark is between the first character of a word and a +;;; non-spell-word characer, it is considered to be in that word even though +;;; that word is after the mark. This is because Hemlock's cursor is always +;;; displayed over the next character, so users tend to think of a cursor +;;; displayed on the first character of a word as being in that word instead of +;;; before it. +;;; +(defun spell-previous-word (mark end-p) + (with-mark ((point mark) + (mark mark)) + (cond ((or end-p + (zerop (character-attribute :spell-word-character + (next-character point)))) + (unless (reverse-find-attribute mark :spell-word-character) + (return-from spell-previous-word nil)) + (move-mark point mark) + (reverse-find-attribute point :spell-word-character #'zerop)) + (t + (find-attribute mark :spell-word-character #'zerop) + (reverse-find-attribute point :spell-word-character #'zerop))) + (cond ((and (> (- (mark-charpos mark) (mark-charpos point)) 2) + (char= (char-upcase (previous-character mark)) #\S) + (char= (prog1 (previous-character (mark-before mark)) + (mark-after mark)) + #\')) + ;; Use roots of possessives and funny plurals (e.g., A's and AND's). + (character-offset mark -2)) + (t + ;; Maybe backup over apostrophes used for quotation marks. + (loop + (when (mark= point mark) (return-from spell-previous-word nil)) + (when (char/= (previous-character mark) #\') (return)) + (mark-before mark)))) + (region point mark))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spellcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spellcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/spellcoms.lisp (revision 8058) @@ -0,0 +1,822 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob Maclachlan. +;;; +;;; This file contains the code to implement commands using the spelling +;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary +;;; augmenting stuff in Spell-Augment.Lisp. + +(in-package :hemlock) + + + +(defstruct (spell-info (:print-function print-spell-info) + (:constructor make-spell-info (pathname))) + pathname ;Dictionary file. + insertions) ;Incremental insertions for this dictionary. + +(defun print-spell-info (obj str n) + (declare (ignore n)) + (let ((pn (spell-info-pathname obj))) + (format str "#" + (and pn (namestring pn))))) + + +(defattribute "Spell Word Character" + "One if the character is one that is present in the spell dictionary, + zero otherwise.") + +(do-alpha-chars (c :both) + (setf (character-attribute :spell-word-character c) 1)) +(setf (character-attribute :spell-word-character #\') 1) + + +(defvar *spelling-corrections* (make-hash-table :test #'equal) + "Mapping from incorrect words to their corrections.") + +(defvar *ignored-misspellings* (make-hash-table :test #'equal) + "A hashtable with true values for words that will be quietly ignored when + they appear.") + +(defhvar "Spell Ignore Uppercase" + "If true, then \"Check Word Spelling\" and \"Correct Buffer Spelling\" will + ignore unknown words that are all uppercase. This is useful for + abbreviations and cryptic formatter directives." + :value nil) + + + + +;;;; Basic Spelling Correction Command (Esc-$ in EMACS) + +(defcommand "Check Word Spelling" (p) + "Check the spelling of the previous word and offer possible corrections + if the word in unknown. To add words to the dictionary from a text file see + the command \"Augment Spelling Dictionary\"." + "Check the spelling of the previous word and offer possible correct + spellings if the word is known to be misspelled." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let* ((region (spell-previous-word (current-point) nil)) + (word (if region + (region-to-string region) + (editor-error "No previous word."))) + (folded (string-upcase word))) + (message "Checking spelling of ~A." word) + (unless (check-out-word-spelling word folded) + (get-word-correction (region-start region) word folded)))) + + + +;;;; Auto-Spell mode: + +(defhvar "Check Word Spelling Beep" + "If true, \"Auto Check Word Spelling\" will beep when an unknown word is + found." + :value t) + +(defhvar "Correct Unique Spelling Immediately" + "If true, \"Auto Check Word Spelling\" will immediately attempt to correct any + unknown word, automatically making the correction if there is only one + possible." + :value t) + + +(defhvar "Default User Spelling Dictionary" + "This is the pathname of a dictionary to read the first time \"Spell\" mode + is entered in a given editing session. When \"Set Buffer Spelling + Dictionary\" or the \"dictionary\" file option is used to specify a + dictionary, this default one is read also. It defaults to nil." + :value nil) + +(defvar *default-user-dictionary-read-p* nil) + +(defun maybe-read-default-user-spelling-dictionary () + (let ((default-dict (value default-user-spelling-dictionary))) + (when (and default-dict (not *default-user-dictionary-read-p*)) + (spell:maybe-read-spell-dictionary) + (spell:spell-read-dictionary (truename default-dict)) + (setf *default-user-dictionary-read-p* t)))) + + +(defmode "Spell" + :transparent-p t :precedence 1.0 :setup-function 'spell-mode-setup) + +(defun spell-mode-setup (buffer) + (defhvar "Buffer Misspelled Words" + "This variable holds a ring of marks pointing to misspelled words." + :buffer buffer :value (make-ring 10 #'delete-mark)) + (maybe-read-default-user-spelling-dictionary)) + +(defcommand "Auto Spell Mode" (p) + "Toggle \"Spell\" mode in the current buffer. When in \"Spell\" mode, + the spelling of each word is checked after it is typed." + "Toggle \"Spell\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Spell") + (not (buffer-minor-mode (current-buffer) "Spell")))) + + +(defcommand "Auto Check Word Spelling" (p) + "Check the spelling of the previous word and display a message in the echo + area if the word is not in the dictionary. To add words to the dictionary + from a text file see the command \"Augment Spelling Dictionary\". If a + replacement for an unknown word has previously been specified, then the + replacement will be made immediately. If \"Correct Unique Spelling + Immediately\" is true, then this command will immediately correct words + which have a unique correction. If there is no obvious correction, then we + place the word in a ring buffer for access by the \"Correct Last Misspelled + Word\" command. If \"Check Word Spelling Beep\" is true, then this command + beeps when an unknown word is found, in addition to displaying the message." + "Check the spelling of the previous word, making obvious corrections, or + queuing the word in buffer-misspelled-words if we are at a loss." + (declare (ignore p)) + (unless (eq (last-command-type) :spell-check) + (spell:maybe-read-spell-dictionary) + (let ((region (spell-previous-word (current-point) t))) + (when region + (let* ((word (nstring-upcase (region-to-string region))) + (len (length word))) + (declare (simple-string word)) + (when (and (<= 2 len spell:max-entry-length) + (not (spell:spell-try-word word len))) + (let ((found (gethash word *spelling-corrections*)) + (save (region-to-string region))) + (cond (found + (undoable-replace-word (region-start region) save found) + (message "Corrected ~S to ~S." save found) + (when (value check-word-spelling-beep) (beep))) + ((and (value spell-ignore-uppercase) + (every #'upper-case-p save)) + (unless (gethash word *ignored-misspellings*) + (setf (gethash word *ignored-misspellings*) t) + (message "Ignoring ~S." save))) + (t + (let ((close (spell:spell-collect-close-words word))) + (cond ((and close + (null (rest close)) + (value correct-unique-spelling-immediately)) + (let ((fix (first close))) + (undoable-replace-word (region-start region) + save fix) + (message "Corrected ~S to ~S." save fix))) + (t + (ring-push (copy-mark (region-end region) + :right-inserting) + (value buffer-misspelled-words)) + (let ((nclose + (do ((i 0 (1+ i)) + (words close (cdr words)) + (nwords () (cons (list i (car words)) + nwords))) + ((null words) (nreverse nwords))))) + (message + "Word ~S not found.~ + ~@[ Corrections:~:{ ~D=~A~}~]" + save nclose))))) + (when (value check-word-spelling-beep) (beep)))))))))) + (setf (last-command-type) :spell-check)) + +(defcommand "Correct Last Misspelled Word" (p) + "Fix a misspelling found by \"Auto Check Word Spelling\". This prompts for + a single character command to determine which action to take to correct the + problem." + "Prompt for a single character command to determine how to fix up a + misspelling detected by Check-Word-Spelling-Command." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (do ((info (value spell-information))) + ((sub-correct-last-misspelled-word info)))) + +(defun sub-correct-last-misspelled-word (info) + (let* ((missed (value buffer-misspelled-words)) + (region (cond ((zerop (ring-length missed)) + (editor-error "No recently misspelled word.")) + ((spell-previous-word (ring-ref missed 0) t)) + (t (editor-error "No recently misspelled word.")))) + (word (region-to-string region)) + (folded (string-upcase word)) + (point (current-point)) + (save (copy-mark point)) + (res t)) + (declare (simple-string word)) + (unwind-protect + (progn + (when (check-out-word-spelling word folded) + (delete-mark (ring-pop missed)) + (return-from sub-correct-last-misspelled-word t)) + (move-mark point (region-end region)) + (command-case (:prompt "Action: " + :change-window nil + :help "Type a single character command to do something to the misspelled word.") + (#\c "Try to find a correction for this word." + (unless (get-word-correction (region-start region) word folded) + (reprompt))) + (#\i "Insert this word in the dictionary." + (spell:spell-add-entry folded) + (push folded (spell-info-insertions info)) + (message "~A inserted in the dictionary." word)) + (#\r "Prompt for a word to replace this word with." + (let ((s (prompt-for-string :prompt "Replace with: " + :default word + :help "Type a string to replace occurrences of this word with."))) + (delete-region region) + (insert-string point s) + (setf (gethash folded *spelling-corrections*) s))) + (:cancel "Ignore this word and go to the previous misspelled word." + (setq res nil)) + (:recursive-edit + "Go into a recursive edit and leave when it exits." + (do-recursive-edit)) + ((:exit #\q) "Exit and forget about this word.") + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + "Choose this numbered word as the correct spelling." + (let ((num (digit-char-p (ext:key-event-char *last-key-event-typed*))) + (close-words (spell:spell-collect-close-words folded))) + (cond ((> num (length close-words)) + (editor-error "Choice out of range.")) + (t (let ((s (nth num close-words))) + (setf (gethash folded *spelling-corrections*) s) + (undoable-replace-word (region-start region) + word s))))))) + (delete-mark (ring-pop missed)) + res) + (move-mark point save) + (delete-mark save)))) + +(defhvar "Spelling Un-Correct Prompt for Insert" + "When this is set, \"Undo Last Spelling Correction\" will prompt before + inserting the old word into the dictionary." + :value nil) + +(defcommand "Undo Last Spelling Correction" (p) + "Undo the last incremental spelling correction. + The \"correction\" is replaced with the old word, and the old word is + inserted in the dictionary. When \"Spelling Un-Correct Prompt for Insert\" + is set, the user is asked about inserting the old word. Any automatic + replacement for the old word is eliminated." + "Undo the last incremental spelling correction, nuking any undesirable + side-effects." + (declare (ignore p)) + (unless (hemlock-bound-p 'last-spelling-correction-mark) + (editor-error "No last spelling correction.")) + (let ((mark (value last-spelling-correction-mark)) + (words (value last-spelling-correction-words))) + (unless words + (editor-error "No last spelling correction.")) + (let* ((new (car words)) + (old (cdr words)) + (folded (string-upcase old))) + (declare (simple-string old new folded)) + (remhash folded *spelling-corrections*) + (delete-characters mark (length new)) + (insert-string mark old) + (setf (value last-spelling-correction-words) nil) + (when (or (not (value spelling-un-correct-prompt-for-insert)) + (prompt-for-y-or-n + :prompt (list "Insert ~A into spelling dictionary? " folded) + :default t + :default-string "Y")) + (push folded (spell-info-insertions (value spell-information))) + (spell:maybe-read-spell-dictionary) + (spell:spell-add-entry folded) + (message "Added ~S to spelling dictionary." old))))) + + +;;; Check-Out-Word-Spelling -- Internal +;;; +;;; Return Nil if Word is a candidate for correction, otherwise +;;; return T and message as to why it isn't. +;;; +(defun check-out-word-spelling (word folded) + (declare (simple-string word)) + (let ((len (length word))) + (cond ((= len 1) + (message "Single character words are not in the dictionary.") t) + ((> len spell:max-entry-length) + (message "~A is too long for the dictionary." word) t) + (t + (multiple-value-bind (idx flagp) (spell:spell-try-word folded len) + (when idx + (message "Found it~:[~; because of ~A~]." flagp + (spell:spell-root-word idx)) + t)))))) + +;;; Get-Word-Correction -- Internal +;;; +;;; Find all known close words to the either unknown or incorrectly +;;; spelled word we are checking. Word is the unmunged word, and Folded is +;;; the uppercased word. Mark is a mark which points to the beginning of +;;; the offending word. Return True if we successfully corrected the word. +;;; +(defun get-word-correction (mark word folded) + (let ((close-words (spell:spell-collect-close-words folded))) + (declare (list close-words)) + (if close-words + (with-pop-up-display (s :height 3) + (do ((i 0 (1+ i)) + (words close-words (cdr words))) + ((null words)) + (format s "~36R=~A " i (car words))) + (finish-output s) + (let* ((key-event (prompt-for-key-event + :prompt "Correction choice: ")) + (num (digit-char-p (ext:key-event-char key-event) 36))) + (cond ((not num) (return-from get-word-correction nil)) + ((> num (length close-words)) + (editor-error "Choice out of range.")) + (t + (let ((s (nth num close-words))) + (setf (gethash folded *spelling-corrections*) s) + (undoable-replace-word mark word s))))) + (return-from get-word-correction t)) + (with-pop-up-display (s :height 1) + (write-line "No corrections found." s) + nil)))) + + +;;; Undoable-Replace-Word -- Internal +;;; +;;; Like Spell-Replace-Word, but makes annotations in buffer local variables +;;; so that "Undo Last Spelling Correction" can undo it. +;;; +(defun undoable-replace-word (mark old new) + (unless (hemlock-bound-p 'last-spelling-correction-mark) + (let ((buffer (current-buffer))) + (defhvar "Last Spelling Correction Mark" + "This variable holds a park pointing to the last spelling correction." + :buffer buffer :value (copy-mark (buffer-start-mark buffer))) + (defhvar "Last Spelling Correction Words" + "The replacement done for the last correction: (new . old)." + :buffer buffer :value nil))) + (move-mark (value last-spelling-correction-mark) mark) + (setf (value last-spelling-correction-words) (cons new old)) + (spell-replace-word mark old new)) + + + +;;;; Buffer Correction + +(defvar *spell-word-characters* + (make-array char-code-limit :element-type 'bit :initial-element 0) + "Characters that are legal in a word for spelling checking purposes.") + +(do-alpha-chars (c :both) + (setf (sbit *spell-word-characters* (char-code c)) 1)) +(setf (sbit *spell-word-characters* (char-code #\')) 1) + + +(defcommand "Correct Buffer Spelling" (p) + "Correct spelling over whole buffer. A log of the found misspellings is + kept in the buffer \"Spell Corrections\". For each unknown word the + user may accept it, insert it in the dictionary, correct its spelling + with one of the offered possibilities, replace the word with a user + supplied word, or go into a recursive edit. Words may be added to the + dictionary in advance from a text file (see the command \"Augment + Spelling Dictionary\")." + "Correct spelling over whole buffer." + (declare (ignore p)) + (clrhash *ignored-misspellings*) + (let* ((buffer (current-buffer)) + (log (or (make-buffer "Spelling Corrections") + (getstring "Spelling Corrections" *buffer-names*))) + (point (buffer-end (buffer-point log))) + (*standard-output* (make-hemlock-output-stream point)) + (window (or (car (buffer-windows log)) (make-window point)))) + (format t "~&Starting spelling checking of buffer ~S.~2%" + (buffer-name buffer)) + (spell:maybe-read-spell-dictionary) + (correct-buffer-spelling buffer window) + (delete-window window) + (close *standard-output*))) + +;;; CORRECT-BUFFER-SPELLING scans through buffer a line at a time, grabbing the +;;; each line's string and breaking it up into words using the +;;; *spell-word-characters* mask. We try the spelling of each word, and if it +;;; is unknown, we call FIX-WORD and resynchronize when it returns. +;;; +(defun correct-buffer-spelling (buffer window) + (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) + (info (if (hemlock-bound-p 'spell-information :buffer buffer) + (variable-value 'spell-information :buffer buffer) + (value spell-information))) + (mask *spell-word-characters*) + (word (make-string spell:max-entry-length))) + ((null line)) + (declare (simple-bit-vector mask) (simple-string word)) + (block line + (let* ((string (line-string line)) + (length (length string))) + (declare (simple-string string)) + (do ((start 0 (or skip-apostrophes end)) + (skip-apostrophes nil nil) + end) + (nil) + ;; + ;; Find word start. + (loop + (when (= start length) (return-from line)) + (when (/= (bit mask (char-code (schar string start))) 0) (return)) + (incf start)) + ;; + ;; Find the end. + (setq end (1+ start)) + (loop + (when (= end length) (return)) + (when (zerop (bit mask (char-code (schar string end)))) (return)) + (incf end)) + (multiple-value-setq (end skip-apostrophes) + (correct-buffer-word-end string start end)) + ;; + ;; Check word. + (let ((word-len (- end start))) + (cond + ((= word-len 1)) + ((> word-len spell:max-entry-length) + (format t "Not checking ~S -- too long for dictionary.~2%" + word)) + (t + ;; + ;; Copy the word and uppercase it. + (do* ((i (1- end) (1- i)) + (j (1- word-len) (1- j))) + ((zerop j) + (setf (schar word 0) (char-upcase (schar string i)))) + (setf (schar word j) (char-upcase (schar string i)))) + (unless (spell:spell-try-word word word-len) + (move-to-position (current-point) start line) + (fix-word (subseq word 0 word-len) (subseq string start end) + window info) + (let ((point (current-point))) + (setq end (mark-charpos point) + line (mark-line point) + string (line-string line) + length (length string)))))))))))) + +;;; CORRECT-BUFFER-WORD-END takes a line string from CORRECT-BUFFER-SPELLING, a +;;; start, and a end. It places end to exclude from the word apostrophes used +;;; for quotation marks, possessives, and funny plurals (e.g., A's and AND's). +;;; Every word potentially can be followed by "'s", and any clown can use the +;;; `` '' Scribe ligature. This returns the value to use for end of the word +;;; and the value to use as the end when continuing to find the next word in +;;; string. +;;; +(defun correct-buffer-word-end (string start end) + (cond ((and (> (- end start) 2) + (char= (char-upcase (schar string (1- end))) #\S) + (char= (schar string (- end 2)) #\')) + ;; Use roots of possessives and funny plurals (e.g., A's and AND's). + (values (- end 2) end)) + (t + ;; Maybe backup over apostrophes used for quotation marks. + (do ((i (1- end) (1- i))) + ((= i start) (values end end)) + (when (char/= (schar string i) #\') + (return (values (1+ i) end))))))) + +;;; Fix-Word -- Internal +;;; +;;; Handles the case where the word has a known correction. If is does +;;; not then call Correct-Buffer-Word-Not-Found. In either case, the +;;; point is left at the place to resume checking. +;;; +(defun fix-word (word unfolded-word window info) + (declare (simple-string word unfolded-word)) + (let ((correction (gethash word *spelling-corrections*)) + (mark (current-point))) + (cond (correction + (format t "Replacing ~S with ~S.~%" unfolded-word correction) + (spell-replace-word mark unfolded-word correction)) + ((and (value spell-ignore-uppercase) + (every #'upper-case-p unfolded-word)) + (character-offset mark (length word)) + (unless (gethash word *ignored-misspellings*) + (setf (gethash word *ignored-misspellings*) t) + (format t "Ignoring ~S.~%" unfolded-word))) + (t + (correct-buffer-word-not-found word unfolded-word window info))))) + +(defun correct-buffer-word-not-found (word unfolded-word window info) + (declare (simple-string word unfolded-word)) + (let* ((close-words (spell:spell-collect-close-words word)) + (close-words-len (length (the list close-words))) + (mark (current-point)) + (wordlen (length word))) + (format t "Unknown word: ~A~%" word) + (cond (close-words + (format t "~[~;A~:;Some~]~:* possible correction~[~; is~:;s are~]: " + close-words-len) + (if (= close-words-len 1) + (write-line (car close-words)) + (let ((n 0)) + (dolist (w close-words (terpri)) + (format t "~36R=~A " n w) + (incf n))))) + (t + (write-line "No correction possibilities found."))) + (let ((point (buffer-point (window-buffer window)))) + (unless (displayed-p point window) + (center-window window point))) + (command-case + (:prompt "Action: " + :help "Type a single letter command, or help character for help." + :change-window nil) + (#\i "Insert unknown word into dictionary for future lookup." + (spell:spell-add-entry word) + (push word (spell-info-insertions info)) + (format t "~S added to dictionary.~2%" word)) + (#\c "Correct the unknown word with possible correct spellings." + (unless close-words + (write-line "There are no possible corrections.") + (reprompt)) + (let ((num (if (= close-words-len 1) 0 + (digit-char-p (ext:key-event-char + (prompt-for-key-event + :prompt "Correction choice: ")) + 36)))) + (unless num (reprompt)) + (when (> num close-words-len) + (beep) + (write-line "Response out of range.") + (reprompt)) + (let ((choice (nth num close-words))) + (setf (gethash word *spelling-corrections*) choice) + (spell-replace-word mark unfolded-word choice))) + (terpri)) + (#\a "Accept the word as correct (that is, ignore it)." + (character-offset mark wordlen)) + (#\r "Replace the unknown word with a supplied replacement." + (let ((s (prompt-for-string + :prompt "Replacement Word: " + :default unfolded-word + :help "String to replace the unknown word with."))) + (setf (gethash word *spelling-corrections*) s) + (spell-replace-word mark unfolded-word s)) + (terpri)) + (:recursive-edit + "Go into a recursive edit and resume correction where the point is left." + (do-recursive-edit))))) + +;;; Spell-Replace-Word -- Internal +;;; +;;; Replaces Old with New, starting at Mark. The case of Old is used +;;; to derive the new case. +;;; +(defun spell-replace-word (mark old new) + (declare (simple-string old new)) + (let ((res (cond ((lower-case-p (schar old 0)) + (string-downcase new)) + ((lower-case-p (schar old 1)) + (let ((res (string-downcase new))) + (setf (char res 0) (char-upcase (char res 0))) + res)) + (t + (string-upcase new))))) + (with-mark ((m mark :left-inserting)) + (delete-characters m (length old)) + (insert-string m res)))) + + + +;;;; User Spelling Dictionaries. + +(defvar *pathname-to-spell-info* (make-hash-table :test #'equal) + "This maps dictionary files to spelling information.") + +(defhvar "Spell Information" + "This is the information about a spelling dictionary and its incremental + insertions." + :value (make-spell-info nil)) + +(define-file-option "Dictionary" (buffer file) + (let* ((dict (merge-pathnames + file + (make-pathname :defaults (buffer-default-pathname buffer) + :type "dict"))) + (dictp (probe-file dict))) + (if dictp + (set-buffer-spelling-dictionary-command nil dictp buffer) + (loud-message "Couldn't find dictionary ~A." (namestring dict))))) + +;;; SAVE-DICTIONARY-ON-WRITE is on the "Write File Hook" in buffers with +;;; the "dictionary" file option. +;;; +(defun save-dictionary-on-write (buffer) + (when (hemlock-bound-p 'spell-information :buffer buffer) + (save-spelling-insertions + (variable-value 'spell-information :buffer buffer)))) + + +(defcommand "Save Incremental Spelling Insertions" (p) + "Append incremental spelling dictionary insertions to a file. The file + is prompted for unless \"Set Buffer Spelling Dictionary\" has been + executed in the buffer." + "Append incremental spelling dictionary insertions to a file." + (declare (ignore p)) + (let* ((info (value spell-information)) + (file (or (spell-info-pathname info) + (value default-user-spelling-dictionary) + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :must-exist nil + :help + "Name of the dictionary file to append dictionary insertions to.")))) + (save-spelling-insertions info file) + (let* ((ginfo (variable-value 'spell-information :global)) + (insertions (spell-info-insertions ginfo))) + (when (and insertions + (prompt-for-y-or-n + :prompt + `("Global spelling insertions exist.~%~ + Save these to ~A also? " + ,(namestring file) + :default t + :default-string "Y")) + (save-spelling-insertions ginfo file)))))) + +(defun save-spelling-insertions (info &optional + (name (spell-info-pathname info))) + (when (spell-info-insertions info) + (with-open-file (stream name + :direction :output :element-type 'base-char + :if-exists :append :if-does-not-exist :create) + (dolist (w (spell-info-insertions info)) + (write-line w stream))) + (setf (spell-info-insertions info) ()) + (message "Incremental spelling insertions for ~A written." + (namestring name)))) + +(defcommand "Set Buffer Spelling Dictionary" (p &optional file buffer) + "Prompts for the dictionary file to associate with the current buffer. + If this file has not been read for any other buffer, then it is read. + Incremental spelling insertions from this buffer can be appended to + this file with \"Save Incremental Spelling Insertions\"." + "Sets the buffer's spelling dictionary and reads it if necessary." + (declare (ignore p)) + (maybe-read-default-user-spelling-dictionary) + (let* ((file (truename (or file + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :help + "Name of the dictionary file to add into the current dictionary.")))) + (file-name (namestring file)) + (spell-info-p (gethash file-name *pathname-to-spell-info*)) + (spell-info (or spell-info-p (make-spell-info file))) + (buffer (or buffer (current-buffer)))) + (defhvar "Spell Information" + "This is the information about a spelling dictionary and its incremental + insertions." + :value spell-info :buffer buffer) + (add-hook write-file-hook 'save-dictionary-on-write) + (unless spell-info-p + (setf (gethash file-name *pathname-to-spell-info*) spell-info) + (read-spelling-dictionary-command nil file)))) + +(defcommand "Read Spelling Dictionary" (p &optional file) + "Adds entries to the dictionary from a file in the following format: + + entry1/flag1/flag2/flag3 + entry2 + entry3/flag1/flag2/flag3/flag4/flag5. + + The flags are single letter indicators of legal suffixes for the entry; + the available flags and their correct use may be found at the beginning + of spell-correct.lisp in the Hemlock sources. There must be exactly one + entry per line, and each line must be flushleft." + "Add entries to the dictionary from a text file in a specified format." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (spell:spell-read-dictionary + (or file + (prompt-for-file + :prompt "Dictionary File: " + :default (dictionary-name-default) + :help + "Name of the dictionary file to add into the current dictionary.")))) + +(defun dictionary-name-default () + (make-pathname :defaults (buffer-default-pathname (current-buffer)) + :type "dict")) + +(defcommand "Add Word to Spelling Dictionary" (p) + "Add the previous word to the spelling dictionary." + "Add the previous word to the spelling dictionary." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let ((word (region-to-string (spell-previous-word (current-point) nil)))) + ;; + ;; SPELL:SPELL-ADD-ENTRY destructively uppercases word. + (when (spell:spell-add-entry word) + (message "Word ~(~S~) added to the spelling dictionary." word) + (push word (spell-info-insertions (value spell-information)))))) + +(defcommand "Remove Word from Spelling Dictionary" (p) + "Prompts for word to remove from the spelling dictionary." + "Prompts for word to remove from the spelling dictionary." + (declare (ignore p)) + (spell:maybe-read-spell-dictionary) + (let* ((word (prompt-for-string + :prompt "Word to remove from spelling dictionary: " + :trim t)) + (upword (string-upcase word))) + (declare (simple-string word)) + (multiple-value-bind (index flagp) + (spell:spell-try-word upword (length word)) + (unless index + (editor-error "~A not in dictionary." upword)) + (if flagp + (remove-spelling-word upword) + (let ((flags (spell:spell-root-flags index))) + (when (or (not flags) + (prompt-for-y-or-n + :prompt + `("Deleting ~A also removes words formed from this root and these flags: ~% ~ + ~S.~%~ + Delete word anyway? " + ,word ,flags) + :default t + :default-string "Y")) + (remove-spelling-word upword))))))) + +;;; REMOVE-SPELLING-WORD removes the uppercase word word from the spelling +;;; dictionary and from the spelling informations incremental insertions list. +;;; +(defun remove-spelling-word (word) + (let ((info (value spell-information))) + (spell:spell-remove-entry word) + (setf (spell-info-insertions info) + (delete word (spell-info-insertions info) :test #'string=)))) + +(defcommand "List Incremental Spelling Insertions" (p) + "Display the incremental spelling insertions for the current buffer's + associated spelling dictionary file." + "Display the incremental spelling insertions for the current buffer's + associated spelling dictionary file." + (declare (ignore p)) + (let* ((info (value spell-information)) + (file (spell-info-pathname info)) + (insertions (spell-info-insertions info))) + (declare (list insertions)) + (with-pop-up-display (s :height (1+ (length insertions))) + (if file + (format s "Incremental spelling insertions for dictionary ~A:~%" + (namestring file)) + (write-line "Global incremental spelling insertions:" s)) + (dolist (w insertions) + (write-line w s))))) + + + + +;;;; Utilities for above stuff. + +;;; SPELL-PREVIOUS-WORD returns as a region the current or previous word, using +;;; the spell word definition. If there is no such word, return nil. If end-p +;;; is non-nil, then mark ends the word even if there is a non-delimiter +;;; character after it. +;;; +;;; Actually, if mark is between the first character of a word and a +;;; non-spell-word characer, it is considered to be in that word even though +;;; that word is after the mark. This is because Hemlock's cursor is always +;;; displayed over the next character, so users tend to think of a cursor +;;; displayed on the first character of a word as being in that word instead of +;;; before it. +;;; +(defun spell-previous-word (mark end-p) + (with-mark ((point mark) + (mark mark)) + (cond ((or end-p + (zerop (character-attribute :spell-word-character + (next-character point)))) + (unless (reverse-find-attribute mark :spell-word-character) + (return-from spell-previous-word nil)) + (move-mark point mark) + (reverse-find-attribute point :spell-word-character #'zerop)) + (t + (find-attribute mark :spell-word-character #'zerop) + (reverse-find-attribute point :spell-word-character #'zerop))) + (cond ((and (> (- (mark-charpos mark) (mark-charpos point)) 2) + (char= (char-upcase (previous-character mark)) #\S) + (char= (prog1 (previous-character (mark-before mark)) + (mark-after mark)) + #\')) + ;; Use roots of possessives and funny plurals (e.g., A's and AND's). + (character-offset mark -2)) + (t + ;; Maybe backup over apostrophes used for quotation marks. + (loop + (when (mark= point mark) (return-from spell-previous-word nil)) + (when (char/= (previous-character mark) #\') (return)) + (mark-before mark)))) + (region point mark))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/srccom.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/srccom.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/srccom.lisp (revision 8058) @@ -0,0 +1,484 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Source comparison stuff for Hemlock. +;;; +;;; Written by Skef Wholey and Bill Chiles. +;;; + +(in-package :hemlock) + +(defhvar "Source Compare Ignore Extra Newlines" + "If T, Source Compare and Source Merge will treat all groups of newlines + as if they were a single newline. The default is T." + :value t) + +(defhvar "Source Compare Ignore Case" + "If T, Source Compare and Source Merge will treat all letters as if they + were of the same case. The default is Nil." + :value nil) + +(defhvar "Source Compare Ignore Indentation" + "This determines whether comparisons ignore initial whitespace on a line or + use the whole line." + :value nil) + +(defhvar "Source Compare Number of Lines" + "This variable controls the number of lines Source Compare and Source Merge + will compare when resyncronizing after a difference has been encountered. + The default is 3." + :value 3) + +(defhvar "Source Compare Default Destination" + "This is a sticky-default buffer name to offer when comparison commands prompt + for a results buffer." + :value "Differences") + + +(defcommand "Buffer Changes" (p) + "Generate a comparison of the current buffer with its file on disk." + "Generate a comparison of the current buffer with its file on disk." + (declare (ignore p)) + (let ((buffer (current-buffer))) + (unless (buffer-pathname buffer) + (editor-error "No pathname associated with buffer.")) + (let ((other-buffer (or (getstring "Buffer Changes File" *buffer-names*) + (make-buffer "Buffer Changes File"))) + (result-buffer (or (getstring "Buffer Changes Result" *buffer-names*) + (make-buffer "Buffer Changes Result")))) + (visit-file-command nil (buffer-pathname buffer) other-buffer) + (delete-region (buffer-region result-buffer)) + (compare-buffers-command nil buffer other-buffer result-buffer) + (delete-buffer other-buffer)))) + +;;; "Compare Buffers" creates two temporary buffers when there is a prefix. +;;; These get deleted when we're done. Buffer-a and Buffer-b are used for +;;; names is banners in either case. +;;; +(defcommand "Compare Buffers" (p &optional buffer-a buffer-b dest-buffer) + "Performs a source comparison on two specified buffers. If the prefix + argument is supplied, only compare the regions in the buffer." + "Performs a source comparison on two specified buffers, Buffer-A and + Buffer-B, putting the result of the comparison into the Dest-Buffer. + If the prefix argument is supplied, only compare the regions in the + buffer." + (srccom-choose-comparison-functions) + (multiple-value-bind (buffer-a buffer-b dest-point + delete-buffer-a delete-buffer-b) + (get-srccom-buffers "Compare buffer: " buffer-a buffer-b + dest-buffer p) + (with-output-to-mark (log dest-point) + (format log "Comparison of ~A and ~A.~%~%" + (buffer-name buffer-a) (buffer-name buffer-b)) + (with-mark ((mark-a (buffer-start-mark (or delete-buffer-a buffer-a))) + (mark-b (buffer-start-mark (or delete-buffer-b buffer-b)))) + (loop + (multiple-value-bind (diff-a diff-b) + (srccom-find-difference mark-a mark-b) + (when (null diff-a) (return nil)) + (format log "**** Buffer ~A:~%" (buffer-name buffer-a)) + (insert-region dest-point diff-a) + (format log "**** Buffer ~A:~%" (buffer-name buffer-b)) + (insert-region dest-point diff-b) + (format log "***************~%~%") + (move-mark mark-a (region-end diff-a)) + (move-mark mark-b (region-end diff-b)) + (unless (line-offset mark-a 1) (return)) + (unless (line-offset mark-b 1) (return))))) + (format log "Done.~%")) + (when delete-buffer-a + (delete-buffer delete-buffer-a) + (delete-buffer delete-buffer-b)))) + + +;;; "Merge Buffers" creates two temporary buffers when there is a prefix. +;;; These get deleted when we're done. Buffer-a and Buffer-b are used for +;;; names is banners in either case. +;;; +(defcommand "Merge Buffers" (p &optional buffer-a buffer-b dest-buffer) + "Performs a source merge on two specified buffers. If the prefix + argument is supplied, only compare the regions in the buffer." + "Performs a source merge on two specified buffers, Buffer-A and Buffer-B, + putting the resulting text into the Dest-Buffer. If the prefix argument + is supplied, only compare the regions in the buffer." + (srccom-choose-comparison-functions) + (multiple-value-bind (buffer-a buffer-b dest-point + delete-buffer-a delete-buffer-b) + (get-srccom-buffers "Merge buffer: " buffer-a buffer-b + dest-buffer p) + (with-output-to-mark (stream dest-point) + (let ((region-a (buffer-region (or delete-buffer-a buffer-a)))) + (with-mark ((temp-a (region-start region-a) :right-inserting) + (temp-b dest-point :right-inserting) + (mark-a (region-start region-a)) + (mark-b (region-start + (buffer-region (or delete-buffer-b buffer-b))))) + (clear-echo-area) + (loop + (multiple-value-bind (diff-a diff-b) + (srccom-find-difference mark-a mark-b) + (when (null diff-a) + (insert-region dest-point (region temp-a (region-end region-a))) + (return nil)) + ;; Copy the part that's the same. + (insert-region dest-point (region temp-a (region-start diff-a))) + ;; Put both versions in the buffer, and prompt for which one to use. + (move-mark temp-a dest-point) + (format stream "~%**** Buffer ~A (1):~%" (buffer-name buffer-a)) + (insert-region dest-point diff-a) + (move-mark temp-b dest-point) + (format stream "~%**** Buffer ~A (2):~%" (buffer-name buffer-b)) + (insert-region dest-point diff-b) + (command-case + (:prompt "Merge Buffers: " + :help "Type one of these characters to say how to merge:") + (#\1 "Use the text from buffer 1." + (delete-region (region temp-b dest-point)) + (delete-characters temp-a) + (delete-region + (region temp-a + (line-start temp-b + (line-next (mark-line temp-a)))))) + (#\2 "Use the text from buffer 2." + (delete-region (region temp-a temp-b)) + (delete-characters temp-b) + (delete-region + (region temp-b + (line-start temp-a + (line-next (mark-line temp-b)))))) + (#\b "Insert both versions with **** MERGE LOSSAGE **** around them." + (insert-string temp-a " + **** MERGE LOSSAGE ****") + (insert-string dest-point " + **** END OF MERGE LOSSAGE ****")) + (#\a "Align window at start of difference display." + (line-start + (move-mark + (window-display-start + (car (buffer-windows (line-buffer (mark-line temp-a))))) + temp-a)) + (reprompt)) + (:recursive-edit "Enter a recursive edit." + (with-mark ((save dest-point)) + (do-recursive-edit) + (move-mark dest-point save)) + (reprompt))) + (redisplay) + (move-mark mark-a (region-end diff-a)) + (move-mark mark-b (region-end diff-b)) + (move-mark temp-a mark-a) + (unless (line-offset mark-a 1) (return)) + (unless (line-offset mark-b 1) (return)))))) + (message "Done.")) + (when delete-buffer-a + (delete-buffer delete-buffer-a) + (delete-buffer delete-buffer-b)))) + +(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p) + (unless buffer-a + (setf buffer-a (prompt-for-buffer :prompt first-prompt + :must-exist t + :default (current-buffer)))) + (unless buffer-b + (setf buffer-b (prompt-for-buffer :prompt "With buffer: " + :must-exist t + :default (previous-buffer)))) + (unless dest-buffer + (setf dest-buffer + (prompt-for-buffer :prompt "Putting results in buffer: " + :must-exist nil + :default-string + (value source-compare-default-destination)))) + (if (stringp dest-buffer) + (setf dest-buffer (make-buffer dest-buffer)) + (buffer-end (buffer-point dest-buffer))) + (setf (value source-compare-default-destination) (buffer-name dest-buffer)) + (change-to-buffer dest-buffer) + (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym))))) + (alt-buffer-b (if alt-buffer-a + (make-buffer (prin1-to-string (gensym)))))) + (when alt-buffer-a + (ninsert-region (buffer-point alt-buffer-a) + (copy-region (if (mark< (buffer-point buffer-a) + (buffer-mark buffer-a)) + (region (buffer-point buffer-a) + (buffer-mark buffer-a)) + (region (buffer-mark buffer-a) + (buffer-point buffer-a))))) + (ninsert-region (buffer-point alt-buffer-b) + (copy-region (if (mark< (buffer-point buffer-b) + (buffer-mark buffer-b)) + (region (buffer-point buffer-b) + (buffer-mark buffer-b)) + (region (buffer-mark buffer-b) + (buffer-point buffer-b)))))) + (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b))) +#| +(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p) + (unless buffer-a + (setf buffer-a (prompt-for-buffer :prompt first-prompt + :must-exist t + :default (current-buffer)))) + (unless buffer-b + (setf buffer-b (prompt-for-buffer :prompt "With buffer: " + :must-exist t + :default (previous-buffer)))) + (unless dest-buffer + (let* ((name (value source-compare-default-destination)) + (temp-default (getstring name *buffer-names*)) + (default (or temp-default (make-buffer name)))) + (setf dest-buffer (prompt-for-buffer :prompt "Putting results in buffer: " + :must-exist nil + :default default)) + ;; Delete the default buffer if it did already exist and was not chosen. + (unless (or (eq dest-buffer default) temp-default) + (delete-buffer default)))) + (if (stringp dest-buffer) + (setf dest-buffer (make-buffer dest-buffer)) + (buffer-end (buffer-point dest-buffer))) + (setf (value source-compare-default-destination) (buffer-name dest-buffer)) + (change-to-buffer dest-buffer) + (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym))))) + (alt-buffer-b (if alt-buffer-a + (make-buffer (prin1-to-string (gensym)))))) + (when alt-buffer-a + (ninsert-region (buffer-point alt-buffer-a) + (copy-region (if (mark< (buffer-point buffer-a) + (buffer-mark buffer-a)) + (region (buffer-point buffer-a) + (buffer-mark buffer-a)) + (region (buffer-mark buffer-a) + (buffer-point buffer-a))))) + (ninsert-region (buffer-point alt-buffer-b) + (copy-region (if (mark< (buffer-point buffer-b) + (buffer-mark buffer-b)) + (region (buffer-point buffer-b) + (buffer-mark buffer-b)) + (region (buffer-mark buffer-b) + (buffer-point buffer-b)))))) + (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b))) +|# + + + +;;;; Functions that find the differences between two buffers. + +(defun srccom-find-difference (mark-a mark-b) + "Returns as multiple values two regions of text that are different in the + lines following Mark-A and Mark-B. If no difference is encountered, Nil + is returned." + (multiple-value-bind (diff-a diff-b) + (srccom-different-lines mark-a mark-b) + (when diff-a + (multiple-value-bind (same-a same-b) + (srccom-similar-lines diff-a diff-b) + (values (region diff-a same-a) + (region diff-b same-b)))))) + +;;; These are set by SRCCOM-CHOOSE-COMPARISON-FUNCTIONS depending on something. +;;; +(defvar *srccom-line=* nil) +(defvar *srccom-line-next* nil) + +(defun srccom-different-lines (mark-a mark-b) + "Returns as multiple values two marks pointing to the first different lines + found after Mark-A and Mark-B. Nil is returned if no different lines are + found." + (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a)) + (mark-a (copy-mark mark-a)) + (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b)) + (mark-b (copy-mark mark-b))) + (()) + (cond ((null line-a) + (return (if line-b + (values mark-a mark-b)))) + ((null line-b) + (return (values mark-a mark-b)))) + (line-start mark-a line-a) + (line-start mark-b line-b) + (unless (funcall *srccom-line=* line-a line-b) + (return (values mark-a mark-b))))) + +(defun srccom-similar-lines (mark-a mark-b) + "Returns as multiple values two marks pointing to the first similar lines + found after Mark-A and Mark-B." + (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a)) + (cmark-a (copy-mark mark-a)) + (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b)) + (cmark-b (copy-mark mark-b)) + (temp) + (window-size (value source-compare-number-of-lines))) + (()) + ;; If we hit the end of one buffer, then the difference extends to the end + ;; of both buffers. + (if (or (null line-a) (null line-b)) + (return + (values + (buffer-end-mark (line-buffer (mark-line mark-a))) + (buffer-end-mark (line-buffer (mark-line mark-b)))))) + (line-start cmark-a line-a) + (line-start cmark-b line-b) + ;; Three cases: + ;; 1] Difference will be same length in A and B. If so, Line-A = Line-B. + ;; 2] Difference will be longer in A. If so, Line-A = something in B. + ;; 3] Difference will be longer in B. If so, Line-B = something in A. + (cond ((and (funcall *srccom-line=* line-a line-b) + (srccom-check-window line-a line-b window-size)) + (return (values cmark-a cmark-b))) + ((and (setq temp (srccom-line-in line-a mark-b cmark-b)) + (srccom-check-window line-a temp window-size)) + (return (values cmark-a (line-start cmark-b temp)))) + ((and (setq temp (srccom-line-in line-b mark-a cmark-a)) + (srccom-check-window temp line-b window-size)) + (return (values (line-start cmark-a temp) cmark-b)))))) + +(defun srccom-line-in (line start end) + "Checks to see if there is a Line Srccom-Line= to the given Line in the + region delimited by the Start and End marks. Returns that line if so, or + Nil if there is none." + (do ((current (mark-line start) (funcall *srccom-line-next* current)) + (terminus (funcall *srccom-line-next* (mark-line end)))) + ((eq current terminus) nil) + (if (funcall *srccom-line=* line current) + (return current)))) + +(defun srccom-check-window (line-a line-b count) + "Verifies that the Count lines following Line-A and Line-B are Srccom-Line=. + If so, returns T. Otherwise returns Nil." + (do ((line-a line-a (funcall *srccom-line-next* line-a)) + (line-b line-b (funcall *srccom-line-next* line-b)) + (index 0 (1+ index))) + ((= index count) t) + (if (not (funcall *srccom-line=* line-a line-b)) + (return nil)))) + + + + +;;;; Functions that control the comparison of text. + +;;; SRCCOM-CHOOSE-COMPARISON-FUNCTIONS -- Internal. +;;; +;;; This initializes utility functions for comparison commands based on Hemlock +;;; variables. +;;; +(defun srccom-choose-comparison-functions () + (setf *srccom-line=* + (if (value source-compare-ignore-case) + (if (value source-compare-ignore-indentation) + #'srccom-ignore-case-and-indentation-line= + #'srccom-case-insensitive-line=) + (if (value source-compare-ignore-indentation) + #'srccom-ignore-indentation-case-sensitive-line= + #'srccom-case-sensitive-line=))) + (setf *srccom-line-next* + (if (value source-compare-ignore-extra-newlines) + #'srccom-line-next-ignoring-extra-newlines + #'line-next))) +#| +(defun srccom-choose-comparison-functions () + "This function should be called by a ``top level'' source compare utility + to initialize the lower-level functions that compare text." + (setf *srccom-line=* + (if (value source-compare-ignore-case) + #'srccom-case-insensitive-line= + #'srccom-case-sensitive-line=)) + (setf *srccom-line-next* + (if (value source-compare-ignore-extra-newlines) + #'srccom-line-next-ignoring-extra-newlines + #'line-next))) +|# + +;;; SRCCOM-LINE-NEXT-IGNORING-EXTRA-NEWLINES -- Internal. +;;; +;;; This is the value of *srccom-line-next* when "Source Compare Ignore Extra +;;; Newlines" is non-nil. +;;; +(defun srccom-line-next-ignoring-extra-newlines (line) + (if (null line) nil + (do ((line (line-next line) (line-next line))) + ((or (null line) (not (blank-line-p line))) line)))) + +;;; SRCCOM-IGNORE-CASE-AND-INDENTATION-LINE= -- Internal. +;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal. +;;; SRCCOM-IGNORE-INDENTATION-CASE-SENSITIVE-LINE= -- Internal. +;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal. +;;; +;;; These are the value of *srccom-line-=* depending on the orthogonal values +;;; of "Source Compare Ignore Case" and "Source Compare Ignore Indentation". +;;; +(macrolet ((def-line= (name test &optional ignore-indentation) + `(defun ,name (line-a line-b) + (or (eq line-a line-b) ; if they're both NIL + (and line-a + line-b + (let* ((chars-a (line-string line-a)) + (len-a (length chars-a)) + (chars-b (line-string line-b)) + (len-b (length chars-b))) + (declare (simple-string chars-a chars-b)) + (cond + ((and (= len-a len-b) + (,test chars-a chars-b))) + ,@(if ignore-indentation + `((t + (flet ((frob (chars len) + (dotimes (i len nil) + (let ((char (schar chars i))) + (unless + (or (char= char #\space) + (char= char #\tab)) + (return i)))))) + (let ((i (frob chars-a len-a)) + (j (frob chars-b len-b))) + (if (and i j) + (,test chars-a chars-b + :start1 i :end1 len-a + :start2 j :end2 len-b) + ))))))))))))) + + (def-line= srccom-ignore-case-and-indentation-line= string-equal t) + + (def-line= srccom-case-insensitive-line= string-equal) + + (def-line= srccom-ignore-indentation-case-sensitive-line= string= t) + + (def-line= srccom-case-sensitive-line= string=)) + +#| +;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal. +;;; +;;; Returns t if line-a and line-b contain STRING-EQUAL text. +;;; +(defun srccom-case-insensitive-line= (line-a line-b) + (or (eq line-a line-b) ; if they're both NIL + (and line-a + line-b + (let ((chars-a (line-string line-a)) + (chars-b (line-string line-b))) + (declare (simple-string chars-a chars-b)) + (and (= (length chars-a) (length chars-b)) + (string-equal chars-a chars-b)))))) + +;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal. +;;; +;;; Returns t if line-a and line-b contain STRING= text. +;;; +(defun srccom-case-sensitive-line= (line-a line-b) + (or (eq line-a line-b) ; if they're both NIL + (and line-a + line-b + (let ((chars-a (line-string line-a)) + (chars-b (line-string line-b))) + (declare (simple-string chars-a chars-b)) + (and (= (length chars-a) (length chars-b)) + (string= chars-a chars-b)))))) +|# Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/ts-buf.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/ts-buf.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/ts-buf.lisp (revision 8058) @@ -0,0 +1,318 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(hemlock-ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code for processing input to and output from slaves +;;; using typescript streams. It maintains the stuff that hacks on the +;;; typescript buffer and maintains its state. +;;; +;;; Written by William Lott. +;;; + +(in-package :hemlock) + + +(defhvar "Input Wait Alarm" + "When non-nil, the user is informed when a typescript buffer goes into + an input wait, and it is not visible. Legal values are :message, + :loud-message (the default), and nil." + :value :loud-message) + + + + +;;;; Structures. + +(defstruct (ts-data + (:print-function + (lambda (ts s d) + (declare (ignore ts d)) + (write-string "#" s))) + (:constructor + make-ts-data (buffer + &aux + (fill-mark (copy-mark (buffer-end-mark buffer) + :right-inserting))))) + buffer ; The buffer we are in + stream ; Stream in the slave. + wire ; Wire to slave + server ; Server info struct. + fill-mark ; Mark where output goes. This is actually the + ; "Buffer Input Mark" which is :right-inserting, + ; and we make sure it is :left-inserting for + ; inserting output. + ) + + + +;;;; Output routines. + +;;; TS-BUFFER-OUTPUT-STRING --- internal interface. +;;; +;;; Called by the slave to output stuff in the typescript. Can also be called +;;; by other random parts of hemlock when they want to output stuff to the +;;; buffer. Since this is called for value from the slave, we have to be +;;; careful about what values we return, so the result can be sent back. It is +;;; called for value only as a synchronization thing. +;;; +;;; Whenever the output is gratuitous, we want it to go behind the prompt. +;;; When it's gratuitous, and we're not at the line-start, then we can output +;;; it normally, but we also make sure we end the output in a newline for +;;; visibility's sake. +;;; +(defun ts-buffer-output-string (ts string &optional gratuitous-p) + "Outputs STRING to the typescript described with TS. The output is inserted + before the fill-mark and the current input." + (when (hemlock.wire:remote-object-p ts) + (setf ts (hemlock.wire:remote-object-value ts))) + (hemlock-ext:without-interrupts + (let ((mark (ts-data-fill-mark ts))) + (cond ((and gratuitous-p (not (start-line-p mark))) + (with-mark ((m mark :left-inserting)) + (line-start m) + (insert-string m string) + (unless (start-line-p m) + (insert-character m #\newline)))) + (t + (setf (mark-kind mark) :left-inserting) + (insert-string mark string) + (when (and gratuitous-p (not (start-line-p mark))) + (insert-character mark #\newline)) + (setf (mark-kind mark) :right-inserting))))) + (values)) + +;;; TS-BUFFER-FINISH-OUTPUT --- internal interface. +;;; +;;; Redisplays the windows. Used by ts-stream in order to finish-output. +;;; +(defun ts-buffer-finish-output (ts) + (declare (ignore ts)) + (redisplay) + nil) + +;;; TS-BUFFER-CHARPOS --- internal interface. +;;; +;;; Used by ts-stream in order to find the charpos. +;;; +(defun ts-buffer-charpos (ts) + (mark-charpos (ts-data-fill-mark (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts)))) + +;;; TS-BUFFER-LINE-LENGTH --- internal interface. +;;; +;;; Used by ts-stream to find out the line length. Returns the width of the +;;; first window, or 80 if there are no windows. +;;; +(defun ts-buffer-line-length (ts) + (let* ((ts (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts)) + (window (car (buffer-windows (ts-data-buffer ts))))) + (if window + (window-width window) + 80))) ; Seems like a good number to me. + + + +;;;; Input routines + +(defun ts-buffer-ask-for-input (remote) + (let* ((ts (hemlock.wire:remote-object-value remote)) + (buffer (ts-data-buffer ts))) + (unless (buffer-windows buffer) + (let ((input-wait-alarm + (if (hemlock-bound-p 'input-wait-alarm + :buffer buffer) + (variable-value 'input-wait-alarm + :buffer buffer) + (variable-value 'input-wait-alarm + :global)))) + (when input-wait-alarm + (when (eq input-wait-alarm :loud-message) + (beep)) + (message "Waiting for input in buffer ~A." + (buffer-name buffer)))))) + nil) + +(defun ts-buffer-clear-input (ts) + (let* ((ts (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts)) + (buffer (ts-data-buffer ts)) + (mark (ts-data-fill-mark ts))) + (unless (mark= mark (buffer-end-mark buffer)) + (with-mark ((start mark)) + (line-start start) + (let ((prompt (region-to-string (region start mark))) + (end (buffer-end-mark buffer))) + (unless (zerop (mark-charpos end)) + (insert-character end #\Newline)) + (insert-string end "[Input Cleared]") + (insert-character end #\Newline) + (insert-string end prompt) + (move-mark mark end))))) + nil) + +(defun ts-buffer-set-stream (ts stream) + (let ((ts (if (hemlock.wire:remote-object-p ts) + (hemlock.wire:remote-object-value ts) + ts))) + (setf (ts-data-stream ts) stream) + (hemlock.wire:remote (ts-data-wire ts) + (ts-stream-set-line-length stream (ts-buffer-line-length ts)))) + nil) + + + +;;;; Typescript mode. + +(defun setup-typescript (buffer) + (let ((ts (make-ts-data buffer))) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value nil) + + (defhvar "Typescript Data" + "The ts-data structure for this buffer" + :buffer buffer + :value ts) + + (defhvar "Buffer Input Mark" + "Beginning of typescript input in this buffer." + :value (ts-data-fill-mark ts) + :buffer buffer) + + (defhvar "Interactive History" + "A ring of the regions input to the Hemlock typescript." + :buffer buffer + :value (make-ring (value interactive-history-length))) + + (defhvar "Interactive Pointer" + "Pointer into the Hemlock typescript input history." + :buffer buffer + :value 0) + + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0))) + +(defmode "Typescript" + :setup-function #'setup-typescript + :documentation "The Typescript mode is used to interact with slave lisps.") + + +;;; TYPESCRIPTIFY-BUFFER -- Internal interface. +;;; +;;; Buffer creation code for eval server connections calls this to setup a +;;; typescript buffer, tie things together, and make some local Hemlock +;;; variables. +;;; +(defun typescriptify-buffer (buffer server wire) + (setf (buffer-minor-mode buffer "Typescript") t) + (let ((info (variable-value 'typescript-data :buffer buffer))) + (setf (ts-data-server info) server) + (setf (ts-data-wire info) wire) + (defhvar "Server Info" + "Server-info structure for this buffer." + :buffer buffer :value server) + (defhvar "Current Eval Server" + "The Server-Info object for the server currently used for evaluation and + compilation." + :buffer buffer :value server) + info)) + +(defun ts-buffer-wire-died (ts) + (setf (ts-data-stream ts) nil) + (setf (ts-data-wire ts) nil) + (buffer-end (ts-data-fill-mark ts) (ts-data-buffer ts)) + (ts-buffer-output-string ts (format nil "~%~%Slave died!~%"))) + +(defun unwedge-typescript-buffer () + (typescript-slave-to-top-level-command nil) + (buffer-end (current-point) (current-buffer))) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-typescript-buffer + :mode "Typescript") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Cause the slave to throw to the top level? " + :mode "Typescript") + +;;; TYPESCRIPT-DATA-OR-LOSE -- internal +;;; +;;; Return the typescript-data for the current buffer, or die trying. +;;; +(defun typescript-data-or-lose () + (if (hemlock-bound-p 'typescript-data) + (let ((ts (value typescript-data))) + (if ts + ts + (editor-error "Can't find the typescript data?"))) + (editor-error "Not in a typescript buffer."))) + +(defcommand "Confirm Typescript Input" (p) + "Send the current input to the slave typescript." + "Send the current input to the slave typescript." + (declare (ignore p)) + (let ((ts (typescript-data-or-lose))) + (let ((input (get-interactive-input))) + (when input + (let ((string (region-to-string input))) + (declare (simple-string string)) + (insert-character (current-point) #\NewLine) + (hemlock.wire:remote (ts-data-wire ts) + (ts-stream-accept-input (ts-data-stream ts) + (concatenate 'simple-string + string + (string #\newline)))) + (hemlock.wire:wire-force-output (ts-data-wire ts)) + (buffer-end (ts-data-fill-mark ts) + (ts-data-buffer ts))))))) + +(defcommand "Typescript Slave Break" (p) + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to invoke BREAK." + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to invoke BREAK." + (declare (ignore p)) + (send-oob-to-slave "B")) + +(defcommand "Typescript Slave to Top Level" (p) + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to throw to the top level REP loop." + "Interrupt the slave Lisp process associated with this interactive buffer, + causing it to throw to the top level REP loop." + (declare (ignore p)) + (send-oob-to-slave "T")) + +(defcommand "Typescript Slave Status" (p) + "Interrupt the slave and cause it to print status information." + "Interrupt the slave and cause it to print status information." + (declare (ignore p)) + (send-oob-to-slave "S")) + +#+NIL +(defun send-oob-to-slave (string) + (let* ((ts (typescript-data-or-lose)) + (wire (ts-data-wire ts)) + (socket (hemlock.wire:wire-fd wire))) + (unless socket + (editor-error "The slave is no longer alive.")) + (error "SEND-OOB-TO-SLAVE seeks an implementation.") + #+NIL + (hemlock-ext:send-character-out-of-band socket (schar string 0)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/ts-stream.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/ts-stream.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/ts-stream.lisp (revision 8058) @@ -0,0 +1,422 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(hemlock-ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file implements typescript streams. +;;; +;;; A typescript stream is a bidirectional stream which uses remote +;;; function calls to interact with a Hemlock typescript buffer. That +;;; is: the code in this file is executed on the slave side. +;;; +;;; Written by William Lott. +;;; + +(in-package :hemlock) + + + +;;;; Ts-streams. + +(defconstant ts-stream-output-buffer-size 512) + +(defclass ts-stream (hi::fundamental-character-output-stream + hi::fundamental-character-input-stream) + ((wire + :initarg :wire + :initform nil + :accessor ts-stream-wire) + + (typescript + :initarg :typescript + :initform nil + :accessor ts-stream-typescript) + + (output-buffer + :initarg :output-buffer + :initform (make-string ts-stream-output-buffer-size) + :accessor ts-stream-output-buffer + :type simple-string) + + (output-buffer-index + :initarg :output-buffer-index + :initform 0 + :accessor ts-stream-output-buffer-index + :type fixnum) + + (char-pos + :initarg :char-pos + :initform 0 + :accessor ts-stream-char-pos + :type fixnum + :documentation "The current output character position on the line, returned by the :CHARPOS method.") + + (line-length + :initarg :line-length + :initform 80 + :accessor ts-stream-line-length + :documentation "The current length of a line of output. Returned by STREAM-LINE-LENGTH method.") + + (current-input + :initarg :current-input + :initform nil + :accessor ts-stream-current-input + :type list + :documentation "This is a list of strings and stream-commands whose order manifests the + input provided by remote procedure calls into the slave of + TS-STREAM-ACCEPT-INPUT.") + + (input-read-index + :initarg :input-read-index + :initform 0 + :accessor ts-stream-input-read-index + :type fixnum))) + +(defun make-ts-stream (wire typescript) + (make-instance 'ts-stream :wire wire :typescript typescript)) + + + +;;;; Conditions. + +(define-condition unexpected-stream-command (error) + ;; Context is a string to be plugged into the report text. + ((context :reader unexpected-stream-command-context :initarg :context)) + (:report (lambda (condition stream) + (format stream "~&Unexpected stream-command while ~A." + (unexpected-stream-command-context condition))))) + + + + +;;;; Editor remote calls into slave. + +;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface. +;;; +;;; The editor calls this remotely in the slave to indicate that the user has +;;; provided input. Input is a string, symbol, or list. If it is a list, the +;;; the CAR names the command, and the CDR is the arguments. +;;; +(defun ts-stream-accept-input (remote input) + (let ((stream (hemlock.wire:remote-object-value remote))) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (setf (ts-stream-current-input stream) + (nconc (ts-stream-current-input stream) + (list (etypecase input + (string + (let ((newline + (position #\newline input :from-end t))) + (setf (ts-stream-char-pos stream) + (if newline + (- (length input) newline 1) + (length input))) + input)) + #+NILGB + (cons + (ext:make-stream-command (car input) + (cdr input))) + #+NILGB + (symbol + (ext:make-stream-command input))))))))) + nil) + +;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface. +;;; +;;; This function is called by the editor to indicate that the line-length for +;;; a TS stream should now be Length. +;;; +(defun ts-stream-set-line-length (remote length) + (let ((stream (hemlock.wire:remote-object-value remote))) + (setf (ts-stream-line-length stream) length))) + + + + +;;;; Stream methods. + +;;; %TS-STREAM-LISTEN -- Internal. +;;; +;;; Determine if there is any input available. If we don't think so, process +;;; all pending events, and look again. +;;; +(defmethod hi::stream-listen ((stream ts-stream)) + (flet ((check () + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (loop + (let* ((current (ts-stream-current-input stream)) + (first (first current))) + (cond ((null current) + (return nil)) + #+NILGB + ((ext:stream-command-p first) + (return t)) + ((>= (ts-stream-input-read-index stream) + (length (the simple-string first))) + (pop (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0)) + (t + (return t))))))))) + (or (check) + (progn + #+NILGB (system:serve-all-events 0) + (check))))) + +;;; %TS-STREAM-IN -- Internal. +;;; +;;; The READ-CHAR stream method. +;;; +(defmethod hi::stream-read-char ((stream ts-stream)) + (hi::stream-force-output stream) + (wait-for-typescript-input stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((first (first (ts-stream-current-input stream)))) + (etypecase first + (string + (prog1 (schar first (ts-stream-input-read-index stream)) + (incf (ts-stream-input-read-index stream)))) + #+NILGB + (ext:stream-command + (error 'unexpected-stream-command + :context "in the READ-CHAR method"))))))) + +;;; %TS-STREAM-READ-LINE -- Internal. +;;; +;;; The READ-LINE stream method. Note: here we take advantage of the fact that +;;; newlines will only appear at the end of strings. +;;; + +(defmethod stream-read-line (stream) + (macrolet + ((next-str () + '(progn + (wait-for-typescript-input stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((first (first (ts-stream-current-input stream)))) + (etypecase first + (string + (prog1 (if (zerop (ts-stream-input-read-index stream)) + (pop (ts-stream-current-input stream)) + (subseq (pop (ts-stream-current-input stream)) + (ts-stream-input-read-index stream))) + (setf (ts-stream-input-read-index stream) 0))) + #+NILGB + (ext:stream-command + (error 'unexpected-stream-command + :context "in the READ-CHAR method"))))))))) + (do ((result (next-str) (concatenate 'simple-string result (next-str)))) + ((char= (schar result (1- (length result))) #\newline) + (values (subseq result 0 (1- (length result))) + nil)) + (declare (simple-string result))))) + +;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal. +;;; +;;; Keep calling server until some input shows up. +;;; +(defun wait-for-typescript-input (stream) + (unless (hi::stream-listen stream) ;for some reasons in CLISP CL:LISTEN calls STREAM-READ-CHAR :-/ + (let ((wire (ts-stream-wire stream)) + (ts (ts-stream-typescript stream))) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (hemlock.wire:remote wire (ts-buffer-ask-for-input ts)) + (hemlock.wire:wire-force-output wire))) + (loop + #+:hemlock.serve-event (hemlock.wire::serve-all-events) + #-:hemlock.serve-event (hemlock.wire:wire-get-object wire) + #+NILGB (sleep .1) ;### + (when (hi::stream-listen stream) + (return)))))) + +;;; %TS-STREAM-FLSBUF --- internal. +;;; +;;; Flush the output buffer associated with stream. This should only be used +;;; inside a without-interrupts and without-gcing. +;;; +(defun %ts-stream-flsbuf (stream) + (when (and (ts-stream-wire stream) + (ts-stream-output-buffer stream) + (not (zerop (ts-stream-output-buffer-index stream)))) + (hemlock.wire:remote (ts-stream-wire stream) + (ts-buffer-output-string + (ts-stream-typescript stream) + (subseq (the simple-string (ts-stream-output-buffer stream)) + 0 + (ts-stream-output-buffer-index stream)))) + (setf (ts-stream-output-buffer-index stream) 0))) + +;;; %TS-STREAM-OUT --- internal. +;;; +;;; Output a single character to stream. +;;; +(defmethod hi::stream-write-char ((stream ts-stream) char) + (declare (base-char char)) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (when (= (ts-stream-output-buffer-index stream) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream)) + (setf (schar (ts-stream-output-buffer stream) + (ts-stream-output-buffer-index stream)) + char) + (incf (ts-stream-output-buffer-index stream)) + (incf (ts-stream-char-pos stream)) + (when (= (char-code char) + (char-code #\Newline)) + (%ts-stream-flsbuf stream) + (setf (ts-stream-char-pos stream) 0) + (hemlock.wire:wire-force-output (ts-stream-wire stream))) + char))) + +;;; %TS-STREAM-SOUT --- internal. +;;; +;;; Output a string to stream. +;;; +(defmethod hi::stream-write-string ((stream ts-stream) string &optional (start 0) (end (length string))) + ;; This can't be true generally: --GB + #+NIL (declare (simple-string string)) + (declare (fixnum start end)) + (let ((wire (ts-stream-wire stream)) + (newline (position #\Newline string :start start :end end :from-end t)) + (length (- end start))) + (when wire + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((index (ts-stream-output-buffer-index stream))) + (cond ((> (+ index length) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream) + (hemlock.wire:remote wire + (ts-buffer-output-string (ts-stream-typescript stream) + (subseq string start end))) + (when newline + (hemlock.wire:wire-force-output wire))) + (t + (replace (the simple-string (ts-stream-output-buffer stream)) + string + :start1 index + :end1 (+ index length) + :start2 start + :end2 end) + (incf (ts-stream-output-buffer-index stream) + length) + (when newline + (%ts-stream-flsbuf stream) + (hemlock.wire:wire-force-output wire))))) + (setf (ts-stream-char-pos stream) + (if newline + (- end newline 1) + (+ (ts-stream-char-pos stream) + length)))))))) + +;;; %TS-STREAM-UNREAD -- Internal. +;;; +;;; Unread a single character. +;;; +(defmethod hi::stream-unread-char ((stream ts-stream) char) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (let ((first (first (ts-stream-current-input stream)))) + (cond ((and (stringp first) + (> (ts-stream-input-read-index stream) 0)) + (setf (schar first (decf (ts-stream-input-read-index stream))) + char)) + (t + (push (string char) (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0))))))) + +;;; %TS-STREAM-CLOSE --- internal. +;;; +;;; Can't do much, 'cause the wire is shared. +;;; +(defmethod close ((stream ts-stream) &key abort) + (unless abort + (force-output stream)) + #+NILGB (lisp::set-closed-flame stream) ;Hugh!? what is that? --GB + ) + +;;; %TS-STREAM-CLEAR-INPUT -- Internal. +;;; +;;; Pass the request to the editor and clear any buffered input. +;;; +(defmethod hi::stream-clear-input ((stream ts-stream)) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (when (ts-stream-wire stream) + (hemlock.wire:remote-value (ts-stream-wire stream) + (ts-buffer-clear-input (ts-stream-typescript stream)))) + (setf (ts-stream-current-input stream) nil + (ts-stream-input-read-index stream) 0)))) + +(defmethod hi::stream-finish-output ((stream ts-stream)) + (when (ts-stream-wire stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (%ts-stream-flsbuf stream) + ;; Note: for the return value to come back, + ;; all pending RPCs must have completed. + ;; Therefore, we know it has synced. + (hemlock.wire:remote-value (ts-stream-wire stream) + (ts-buffer-finish-output (ts-stream-typescript stream)))))) + t) + +(defmethod hi::stream-force-output ((stream ts-stream)) + (when (ts-stream-wire stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (%ts-stream-flsbuf stream) + (hemlock.wire:wire-force-output (ts-stream-wire stream))))) + t) + +(defmethod hi::stream-line-column ((stream ts-stream)) + (ts-stream-char-pos stream)) + +(defmethod hi::stream-line-length ((stream ts-stream)) + (ts-stream-line-length stream)) + +#+NILGB ;; -- hmm. +(defmethod interactive-stream-p ((stream ts-stream)) + t) + +(defmethod hi::stream-clear-output ((stream ts-stream)) + (setf (ts-stream-output-buffer-index stream) 0)) + +;;; %TS-STREAM-MISC -- Internal. +;;; +;;; The misc stream method. +;;; +#+NILGB +(defun %ts-stream-misc (stream operation &optional arg1 arg2) + (case operation + (:get-command + (wait-for-typescript-input stream) + (hemlock-ext:without-interrupts + (hemlock-ext:without-gcing + (etypecase (first (ts-stream-current-input stream)) + (stream-command + (setf (ts-stream-input-read-index stream) 0) + (pop (ts-stream-current-input stream))) + (string nil))))) + )) + +;; $Log$ +;; Revision 1.1 2003/10/19 08:57:16 gb +;; Initial revision +;; +;; Revision 1.1.2.1 2003/08/10 19:11:40 gb +;; New files, imported from upstream CVS as of 03/08/09. +;; +;; Revision 1.3 2003/08/05 19:51:13 gilbert +;; initial slave lisp support, still not ready for prime time. +;; +;; Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/termcap.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/termcap.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/termcap.lisp (revision 8058) @@ -0,0 +1,443 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; Terminal Capability +;;; +;;; This stuff parses a Termcap file and returns a data structure suitable +;;; for initializing a redisplay methods device. +;;; + +(in-package :hemlock-internals) + + + + +;;;; Interface for device creating code. + +(defun get-termcap (name) + "Look in TERMCAP environment variable for terminal capabilities or a + file to use. If it is a file, look for name in it. If it is a description + of the capabilities, use it, and don't look for name anywhere. If TERMCAP + is undefined, look for name in termcap-file. An error is signaled if it + cannot find the terminal capabilities." + (let ((termcap-env-var (get-termcap-env-var))) + (if termcap-env-var + (if (char= (schar termcap-env-var 0) #\/) ; hack for filenamep + (with-open-file (s termcap-env-var) + (if (find-termcap-entry name s) + (parse-fields s) + (error "Unknown Terminal ~S in file ~S." name termcap-env-var))) + (with-input-from-string (s termcap-env-var) + (skip-termcap-names s) + (parse-fields s))) + (with-open-file (s termcap-file) + (if (find-termcap-entry name s) + (parse-fields s) + (error "Unknown Terminal ~S in file ~S." name termcap-file)))))) + +(declaim (inline termcap)) +(defun termcap (name termcap) + (cdr (assoc name termcap :test #'eq))) + + + + +;;;; Finding the termcap entry + +(defun find-termcap-entry (name stream) + (loop + (let ((end-of-names (lex-termcap-name stream))) + (when (termcap-found-p name) + (unless end-of-names (skip-termcap-names stream)) + (return t)) + (when end-of-names + (unless (skip-termcap-fields stream) + (return nil)))))) + + +;;; This buffer is used in LEX-TERMCAP-NAME and PARSE-FIELDS to +;;; do string comparisons and build strings from interpreted termcap +;;; characters, respectively. +;;; +(defvar *termcap-string-buffer* (make-string 300)) +(defvar *termcap-string-index* 0) + +(eval-when (:compile-toplevel :execute) + +(defmacro init-termcap-string-buffer () + `(setf *termcap-string-index* 0)) + +(defmacro store-char (char) + `(progn + (setf (schar *termcap-string-buffer* *termcap-string-index*) ,char) + (incf *termcap-string-index*))) + +(defmacro termcap-string-buffer-string () + `(subseq (the simple-string *termcap-string-buffer*) + 0 *termcap-string-index*)) + +) ;eval-when + + +;;; LEX-TERMCAP-NAME gathers characters until the next #\|, which separate +;;; terminal names, or #\:, which terminate terminal names for an entry. +;;; T is returned if the end of the names is reached for the entry. +;;; If we hit and EOF, act like we found a :. +;;; +(defun lex-termcap-name (stream) + (init-termcap-string-buffer) + (loop + (let ((char (read-char stream nil #\:))) + (case char + (#\Linefeed (init-termcap-string-buffer)) + (#\# (read-line stream nil)) + (#\| (return nil)) + (#\: (return t)) + (t (store-char char)))))) + +(defun termcap-found-p (name) + (string= name *termcap-string-buffer* :end2 *termcap-string-index*)) + +;;; SKIP-TERMCAP-NAMES eats characters until the next #\: which terminates +;;; terminal names for an entry. Stop also at EOF. +;;; +(defun skip-termcap-names (stream) + (loop + (when (char= (read-char stream nil #\:) #\:) + (return)))) + +;;; SKIP-TERMCAP-FIELDS skips the rest of an entry, returning nil if there +;;; are no more entries in the file. An entry is terminated by a #\: +;;; followed by a #\newline (possibly by eof). +;;; +(defun skip-termcap-fields (stream) + (loop + (multiple-value-bind (line eofp) + (read-line stream nil) + (if eofp + (return nil) + (let ((len (length line))) + (declare (simple-string line)) + (when (and (not (zerop len)) + (not (char= (schar line 0) #\#)) + (char= (schar line (1- len)) #\:)) + (let ((char (read-char stream nil :eof))) + (if (eq char :eof) + (return nil) + (unread-char char stream)) + (return t)))))))) + + + + +;;;; Defining known capabilities for parsing purposes. + +(eval-when (:compile-toplevel :execute :load-toplevel) +(defvar *known-termcaps* ()) +) ;eval-when + + +(eval-when (:compile-toplevel :execute) + +;;; DEFTERMCAP makes a terminal capability known for parsing purposes. +;;; Type is one of :string, :number, or :boolean. Cl-name is an EQ +;;; identifier for the capability. +;;; +(defmacro deftermcap (name type cl-name) + `(progn (push (list ,name ,type ,cl-name) *known-termcaps*))) + +(defmacro termcap-def (name) + `(cdr (assoc ,name *known-termcaps* :test #'string=))) + +(defmacro termcap-def-type (termcap-def) + `(car ,termcap-def)) + +(defmacro termcap-def-cl-name (termcap-def) + `(cadr ,termcap-def)) + +) ;eval-when + + +(deftermcap "is" :string :init-string) +(deftermcap "if" :string :init-file) +(deftermcap "ti" :string :init-cursor-motion) +(deftermcap "te" :string :end-cursor-motion) +(deftermcap "al" :string :open-line) +(deftermcap "am" :boolean :auto-margins-p) +(deftermcap "ce" :string :clear-to-eol) +(deftermcap "cl" :string :clear-display) +(deftermcap "cm" :string :cursor-motion) +(deftermcap "co" :number :columns) +(deftermcap "dc" :string :delete-char) +(deftermcap "dm" :string :init-delete-mode) +(deftermcap "ed" :string :end-delete-mode) +(deftermcap "dl" :string :delete-line) +(deftermcap "im" :string :init-insert-mode) +(deftermcap "ic" :string :init-insert-char) +(deftermcap "ip" :string :end-insert-char) +(deftermcap "ei" :string :end-insert-mode) +(deftermcap "li" :number :lines) +(deftermcap "so" :string :init-standout-mode) +(deftermcap "se" :string :end-standout-mode) +(deftermcap "tc" :string :similar-terminal) +(deftermcap "os" :boolean :overstrikes) +(deftermcap "ul" :boolean :underlines) + +;;; font related stuff, added by William +(deftermcap "ae" :string :end-alternate-char-set) +(deftermcap "as" :string :start-alternate-char-set) +(deftermcap "mb" :string :start-blinking-attribute) +(deftermcap "md" :string :start-bold-attribute) +(deftermcap "me" :string :end-all-attributes) +(deftermcap "mh" :string :start-half-bright-attribute) +(deftermcap "mk" :string :start-blank-attribute) +(deftermcap "mp" :string :start-protected-attribute) +(deftermcap "mr" :string :start-reverse-video-attribute) +(deftermcap "ue" :string :end-underscore-mode) +(deftermcap "us" :string :start-underscore-mode) + + + +;;;; Parsing an entry. + +(defvar *getchar-ungetchar-buffer* nil) + +(eval-when (:compile-toplevel :execute) + +;;; UNGETCHAR -- Internal. +;;; +;;; We need this to be able to peek ahead more than one character. +;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR. +;;; +(defmacro ungetchar (char) + `(push ,char *getchar-ungetchar-buffer*)) + +;;; GETCHAR -- Internal. +;;; +;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR. +;;; +(defmacro getchar () + `(loop + (setf char + (if *getchar-ungetchar-buffer* + (pop *getchar-ungetchar-buffer*) + (read-char stream nil :eof))) + (if (and (characterp char) (char= char #\\)) + (let ((temp (if *getchar-ungetchar-buffer* + (pop *getchar-ungetchar-buffer*) + (read-char stream)))) + (when (char/= temp #\newline) + (ungetchar temp) + (return char))) + (return char)))) + + +;;; STORE-FIELD used in PARSE-FIELDS. +;;; +(defmacro store-field (cl-name value) + (let ((name (gensym))) + `(let ((,name ,cl-name)) + (unless (cdr (assoc ,name termcap :test #'eq)) + (push (cons ,name ,value) termcap))))) + +) ;eval-when + +;;; PARSE-FIELDS parses a termcap entry. We start out in the state get-name. +;;; Each name is looked up in *known-termcaps*, and if it is of interest, then +;;; we dispatch to a state to pick up the value of the field; otherwise, eat +;;; the rest of the field to get to the next name. The name could be present +;;; simply to have the capability negated before the entry indirects to a +;;; similar terminal's capabilities, in which case it is followed by an #\@. +;;; Negated fields are stored with the value :negated since we only store a +;;; field if it does not already have a value -- this is the intent of the +;;; sequencing built into the termcap file. When we are done, we see if there +;;; is a similar terminal to be parsed, and when we are really done, we replace +;;; all the :negated's with nil's. +;;; +(defun parse-fields (stream) + (prog ((termcap-name (make-string 2)) + (termcap ()) + char termcap-def) + GET-NAME + ;; + ;; This state expects char to be a #\:. + (case (getchar) + ((#\space #\tab) + (go GET-NAME)) + (#\: + ;; This is an empty field. + (go GET-NAME)) + ((#\newline :eof) + (go MAYBE-DONE)) + (t + (setf (schar termcap-name 0) char))) + (setf (schar termcap-name 1) (getchar)) + (setf termcap-def (termcap-def termcap-name)) + (unless termcap-def (go EAT-FIELD)) + (when (char= (getchar) #\@) + ;; Negation of a capability to be inherited from a similar terminal. + (store-field (termcap-def-cl-name termcap-def) :negated) + (go EAT-FIELD)) + (case (termcap-def-type termcap-def) + (:number (go NUMBER)) + (:boolean (go BOOLEAN)) + (:string (go STRING))) + NUMBER + (unless (char= char #\#) + (error "Bad termcap format -- number field '#' missing.")) + (let ((number 0) + digit) + (loop + (setf digit (digit-char-p (getchar))) + (if digit + (setf number (+ digit (* number 10))) + (if (char= char #\:) + (return) + (error "Bad termcap format -- number field not : terminated.")))) + (store-field (termcap-def-cl-name termcap-def) number) + (go GET-NAME)) + BOOLEAN + (store-field (termcap-def-cl-name termcap-def) t) + (if (char= char #\:) + (go GET-NAME) + (error "Bad termcap format -- boolean field not : terminated.")) + STRING + (unless (char= char #\=) + (error "Bad termcap format -- string field '=' missing.")) + ;; + ;; Eat up any cost of the capability. + (when (digit-char-p (getchar)) + (let ((dotp nil)) + (loop + (case (getchar) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (#\. + (when dotp (return)) + (setf dotp t)) + (t (when (char= char #\*) (getchar)) ; '*' means a per line cost + (return)))))) + ;; + ;; Collect the characters. + (let ((normal-string-p (not (eq (termcap-def-cl-name termcap-def) + :cursor-motion))) + xp cm-info) + (init-termcap-string-buffer) + (loop + (case (setf char (get-termcap-string-char stream char)) + (#\% + (if normal-string-p + (store-char #\%) + (case (getchar) + (#\% (store-char #\%)) + ((#\d #\2 #\3) + (push (if (char= char #\d) 0 (digit-char-p char)) + cm-info) + (push (if xp :y-pad :x-pad) cm-info) + (push (termcap-string-buffer-string) cm-info) + (push (if xp :string2 :string1) cm-info) + (init-termcap-string-buffer) + (setf xp t)) + (#\. + (push (termcap-string-buffer-string) cm-info) + (push (if xp :string2 :string1) cm-info) + (init-termcap-string-buffer) + (setf xp t)) + (#\+ + (push (termcap-string-buffer-string) cm-info) + (push (if xp :string2 :string1) cm-info) + (push (get-termcap-string-char stream (getchar)) cm-info) + (push (if xp :y-add-char :x-add-char) cm-info) + (init-termcap-string-buffer) + (setf xp t)) + (#\> + (push (get-termcap-string-char stream (getchar)) cm-info) + (push (if xp :y-condx-char :x-condx-char) cm-info) + (push (get-termcap-string-char stream (getchar)) cm-info) + (push (if xp :y-condx-add-char :x-condx-add-char) cm-info)) + (#\r + (push t cm-info) + (push :reversep cm-info)) + (#\i + (push t cm-info) + (push :one-origin cm-info))))) + (#\: + (store-field (termcap-def-cl-name termcap-def) + (cond (normal-string-p (termcap-string-buffer-string)) + (t (push (termcap-string-buffer-string) cm-info) + (cons :string3 cm-info)))) + (return)) + (t (store-char char))) + (getchar)) + (go GET-NAME)) + EAT-FIELD + (loop (when (char= (getchar) #\:) (return))) + (go GET-NAME) + MAYBE-DONE + (let* ((similar-terminal (assoc :similar-terminal termcap :test #'eq)) + (name (cdr similar-terminal))) + (when name + (file-position stream :start) + (setf (cdr similar-terminal) nil) + (if (find-termcap-entry name stream) + (go GET-NAME) + (error "Unknown similar terminal name -- ~S." name)))) + (dolist (ele termcap) + (when (eq (cdr ele) :negated) + (setf (cdr ele) nil))) + (return termcap))) + +;;; GET-TERMCAP-STRING-CHAR -- Internal. +;;; +;;; This parses/lexes an ASCII character out of the termcap file and converts +;;; it into the appropriate Common Lisp character. This is a Common Lisp +;;; character with the same CHAR-CODE code as the ASCII code, so writing the +;;; character to the tty will have the desired effect. If this function needs +;;; to look ahead to determine any characters, it unreads the character. +;;; +(defun get-termcap-string-char (stream char) + (case char + (#\\ + (case (getchar) + (#\E (code-char 27)) + (#\n (code-char 10)) + (#\r (code-char 13)) + (#\t (code-char 9)) + (#\b (code-char 8)) + (#\f (code-char 12)) + (#\^ #\^) + (#\\ #\\) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((result 0) + (digit (digit-char-p char))) + (loop (setf result (+ digit (* 8 result))) + (unless (setf digit (digit-char-p (getchar))) + (ungetchar char) + (return (code-char (ldb (byte 7 0) result))))))) + (t (error "Bad termcap format -- unknown backslash character.")))) + (#\^ + (code-char (- (char-code (char-upcase (getchar))) 64))) + (t char))) + + + +;;;; Initialization file string. + +(defun get-init-file-string (f) + (unless (probe-file f) + (error "File containing terminal initialization string does not exist -- ~S." + f)) + (with-open-file (s f) + (let* ((len (file-length s)) + (string (make-string len))) + (dotimes (i len string) + (setf (schar string i) (read-char s)))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-disp-rt.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-disp-rt.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-disp-rt.lisp (revision 8058) @@ -0,0 +1,200 @@ +;;; -*- Log: hemlock.log; Package: hemlock-internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock-internals) + + + +;;;; Terminal init and exit methods. + +(defvar *hemlock-input-handler*) + +(defun init-tty-device (device) + (setf *hemlock-input-handler* + (system:add-fd-handler 0 :input #'get-editor-tty-input)) + (standard-device-init) + (device-write-string (tty-device-init-string device)) + (redisplay-all)) + +(defun exit-tty-device (device) + (cursor-motion device 0 (1- (tty-device-lines device))) + ;; Can't call the clear-to-eol method since we don't have a hunk to + ;; call it on, and you can't count on the bottom hunk being the echo area. + ;; + (if (tty-device-clear-to-eol-string device) + (device-write-string (tty-device-clear-to-eol-string device)) + (dotimes (i (tty-device-columns device) + (cursor-motion device 0 (1- (tty-device-lines device)))) + (tty-write-char #\space))) + (device-write-string (tty-device-cm-end-string device)) + (when (device-force-output device) + (funcall (device-force-output device))) + (when *hemlock-input-handler* + (system:remove-fd-handler *hemlock-input-handler*) + (setf *hemlock-input-handler* nil)) + (standard-device-exit)) + + + +;;;; Get terminal attributes: + +(defvar *terminal-baud-rate* nil) +(declaim (type (or (unsigned-byte 24) null) *terminal-baud-rate*)) + +;;; GET-TERMINAL-ATTRIBUTES -- Interface +;;; +;;; Get terminal attributes from Unix. Return as values, the lines, +;;; columns and speed. If any value is inaccessible, return NIL for that +;;; value. We also sleazily cache the speed in *terminal-baud-rate*, since I +;;; don't want to figure out how to get my hands on the TTY-DEVICE at the place +;;; where I need it. Currently, there really can only be one TTY anyway, since +;;; the buffer is in a global. +;;; +(defun get-terminal-attributes (&optional (fd 1)) + (alien:with-alien ((winsize (alien:struct unix:winsize)) + #-(or glibc2 bsd) + (sgtty (alien:struct unix:sgttyb)) + #+bsd ; termios + (tios (alien:struct unix:termios))) + (let ((size-win (unix:unix-ioctl fd unix:TIOCGWINSZ + (alien:alien-sap winsize))) + #-(or glibc2 bsd) + (speed-win (unix:unix-ioctl fd unix:TIOCGETP + (alien:alien-sap sgtty))) + #+bsd + (speed-win (unix:unix-tcgetattr fd (alien:alien-sap tios)))) + (flet ((frob (val) + (if (and size-win (not (zerop val))) + val + nil))) + (values + (frob (alien:slot winsize 'unix:ws-row)) + (frob (alien:slot winsize 'unix:ws-col)) + #-(or glibc2 bsd) + (and speed-win + (setq *terminal-baud-rate* + (svref unix:terminal-speeds + (alien:slot sgtty 'unix:sg-ospeed)))) + #+bsd + (and speed-win + (setq *terminal-baud-rate* (unix:unix-cfgetospeed tios))) + #+glibc2 + 4800))))) + + + +;;;; Output routines and buffering. + +(defconstant redisplay-output-buffer-length 256) + +(defvar *redisplay-output-buffer* + (make-string redisplay-output-buffer-length)) +(declaim (simple-string *redisplay-output-buffer*)) + +(defvar *redisplay-output-buffer-index* 0) +(declaim (fixnum *redisplay-output-buffer-index*)) + +;;; WRITE-AND-MAYBE-WAIT -- Internal +;;; +;;; Write the first Count characters in the redisplay output buffer. If +;;; *terminal-baud-rate* is set, then sleep for long enough to allow the +;;; written text to be displayed. We multiply by 10 to get the baud-per-byte +;;; conversion, which assumes 7 character bits + 1 start bit + 2 stop bits, no +;;; parity. +;;; +(defun write-and-maybe-wait (count) + (declare (fixnum count)) + (unix:unix-write 1 *redisplay-output-buffer* 0 count) + (let ((speed *terminal-baud-rate*)) + (when speed + (sleep (/ (* (float count) 10.0) (float speed)))))) + + +;;; TTY-WRITE-STRING blasts the string into the redisplay output buffer. +;;; If the string overflows the buffer, then segments of the string are +;;; blasted into the buffer, dumping the buffer, until the last piece of +;;; the string is stored in the buffer. The buffer is always dumped if +;;; it is full, even if the last piece of the string just fills the buffer. +;;; +(defun tty-write-string (string start length) + (declare (fixnum start length)) + (let ((buffer-space (- redisplay-output-buffer-length + *redisplay-output-buffer-index*))) + (declare (fixnum buffer-space)) + (cond ((<= length buffer-space) + (let ((dst-index (+ *redisplay-output-buffer-index* length))) + (%primitive byte-blt string start *redisplay-output-buffer* + *redisplay-output-buffer-index* dst-index) + (cond ((= length buffer-space) + (write-and-maybe-wait redisplay-output-buffer-length) + (setf *redisplay-output-buffer-index* 0)) + (t + (setf *redisplay-output-buffer-index* dst-index))))) + (t + (let ((remaining (- length buffer-space))) + (declare (fixnum remaining)) + (loop + (%primitive byte-blt string start *redisplay-output-buffer* + *redisplay-output-buffer-index* + redisplay-output-buffer-length) + (write-and-maybe-wait redisplay-output-buffer-length) + (when (< remaining redisplay-output-buffer-length) + (%primitive byte-blt string (+ start buffer-space) + *redisplay-output-buffer* 0 remaining) + (setf *redisplay-output-buffer-index* remaining) + (return t)) + (incf start buffer-space) + (setf *redisplay-output-buffer-index* 0) + (setf buffer-space redisplay-output-buffer-length) + (decf remaining redisplay-output-buffer-length))))))) + + +;;; TTY-WRITE-CHAR stores a character in the redisplay output buffer, +;;; dumping the buffer if it becomes full. +;;; +(defun tty-write-char (char) + (setf (schar *redisplay-output-buffer* *redisplay-output-buffer-index*) + char) + (incf *redisplay-output-buffer-index*) + (when (= *redisplay-output-buffer-index* redisplay-output-buffer-length) + (write-and-maybe-wait redisplay-output-buffer-length) + (setf *redisplay-output-buffer-index* 0))) + + +;;; TTY-FORCE-OUTPUT dumps the redisplay output buffer. This is called +;;; out of terminal device structures in multiple places -- the device +;;; exit method, random typeout methods, out of tty-hunk-stream methods, +;;; after calls to REDISPLAY or REDISPLAY-ALL. +;;; +(defun tty-force-output () + (unless (zerop *redisplay-output-buffer-index*) + (write-and-maybe-wait *redisplay-output-buffer-index*) + (setf *redisplay-output-buffer-index* 0))) + + +;;; TTY-FINISH-OUTPUT simply dumps output. +;;; +(defun tty-finish-output (device window) + (declare (ignore window)) + (let ((force-output (device-force-output device))) + (when force-output + (funcall force-output)))) + + + + +;;;; Screen image line hacks. + +(defmacro replace-si-line (dst-string src-string src-start dst-start dst-end) + `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-display.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-display.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-display.lisp (revision 8058) @@ -0,0 +1,1303 @@ +;;; -*- Log: hemlock.log; Package: hemlock-internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock-internals) + +(export '(redisplay redisplay-all define-tty-font)) + + + + +;;;; Macros. + +(eval-when (:compile-toplevel :execute) +(defmacro tty-hunk-modeline-pos (hunk) + `(tty-hunk-text-height ,hunk)) +) ;eval-when + + +(defvar *currently-selected-hunk* nil) +(defvar *hunk-top-line*) + +(declaim (fixnum *hunk-top-line*)) + +(eval-when (:compile-toplevel :execute) +(defmacro select-hunk (hunk) + `(unless (eq ,hunk *currently-selected-hunk*) + (setf *currently-selected-hunk* ,hunk) + (setf *hunk-top-line* + (the fixnum + (1+ (the fixnum + (- (the fixnum + (tty-hunk-text-position ,hunk)) + (the fixnum + (tty-hunk-text-height ,hunk))))))))) +) ;eval-when + + +;;; Screen image lines. +;;; +(defstruct (si-line (:print-function print-screen-image-line) + (:constructor %make-si-line (chars))) + (chars nil :type simple-string) + (length 0) + (fonts nil :type list)) + +(defun make-si-line (n) + (%make-si-line (make-string n))) + +(defun print-screen-image-line (obj str n) + (declare (ignore n)) + (write-string "#" str)) + + +(defun find-identical-prefix (dis-line dis-line-fonts si-line) + (declare (type dis-line dis-line) + (type list dis-line-fonts) + (type si-line si-line)) + (let* ((dl-chars (dis-line-chars dis-line)) + (dl-len (dis-line-length dis-line)) + (si-chars (si-line-chars si-line)) + (si-len (si-line-length si-line)) + (okay-until 0)) + (declare (type simple-string dl-chars si-chars) + (type (and unsigned-byte fixnum) dl-len si-len) + (type (and unsigned-byte fixnum) okay-until)) + (do ((dl-fonts dis-line-fonts (cdr dis-line-fonts)) + (si-fonts (si-line-fonts si-line) (cdr si-fonts))) + ((or (null dl-fonts) (null si-fonts)) + (let ((next-font (car (or dl-fonts si-fonts)))) + (if next-font + (let ((end (min dl-len si-len (cadr next-font)))) + (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 end :end2 end) + end)) + (let ((end (min dl-len si-len))) + (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 end :end2 end) + (if (= dl-len si-len) nil end)))))) + (let ((dl-font (caar dl-fonts)) + (dl-start (cadar dl-fonts)) + (dl-stop (cddar dl-fonts)) + (si-font (caar si-fonts)) + (si-start (cadar si-fonts)) + (si-stop (cddar si-fonts))) + (unless (and (= dl-font si-font) + (= dl-start si-start)) + (let ((font-lossage (min dl-start si-start))) + (return (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 font-lossage :end2 font-lossage) + font-lossage)))) + (unless (= dl-stop si-stop) + (let ((font-lossage (min dl-stop si-stop))) + (return (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 font-lossage :end2 font-lossage) + font-lossage)))) + (let ((mismatch (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 dl-stop :end2 si-stop))) + (if mismatch + (return mismatch) + (setf okay-until dl-stop))))))) + + +(defun find-identical-suffix (dis-line dis-line-fonts si-line) + (declare (type dis-line dis-line) + (type list dis-line-fonts) + (type si-line si-line)) + (let* ((dl-chars (dis-line-chars dis-line)) + (dl-len (dis-line-length dis-line)) + (si-chars (si-line-chars si-line)) + (si-len (si-line-length si-line)) + (count (dotimes (i (min dl-len si-len) i) + (when (char/= (schar dl-chars (- dl-len i 1)) + (schar si-chars (- si-len i 1))) + (return i))))) + (declare (type simple-string dl-chars si-chars) + (type (and unsigned-byte fixnum) dl-len si-len)) + (do ((dl-fonts (reverse dis-line-fonts) (cdr dis-line-fonts)) + (si-fonts (reverse (si-line-fonts si-line)) (cdr si-fonts))) + ((or (null dl-fonts) (null si-fonts)) + (cond (dl-fonts + (min (- dl-len (cddar dl-fonts)) count)) + (si-fonts + (min (- si-len (cddar si-fonts)) count)) + (t + count))) + (let ((dl-font (caar dl-fonts)) + (dl-start (- dl-len (cadar dl-fonts))) + (dl-stop (- dl-len (cddar dl-fonts))) + (si-font (caar si-fonts)) + (si-start (- si-len (cadar si-fonts))) + (si-stop (- si-len (cddar si-fonts)))) + (unless (and (= dl-font si-font) + (= dl-stop si-stop)) + (return (min dl-stop si-stop count))) + (unless (= dl-start si-start) + (return (min dl-start si-start count))) + (when (<= count dl-start) + (return count)))))) + + +(defmacro si-line (screen-image n) + `(svref ,screen-image ,n)) + + + + +;;; Font support. + +(defvar *tty-font-strings* (make-array font-map-size :initial-element nil) + "Array of (start-string . end-string) for fonts, or NIL if no such font.") + +(defun define-tty-font (font-id &rest stuff) + (unless (<= 0 font-id (1- font-map-size)) + (error "Bogus font-id: ~S" font-id)) + (cond ((every #'keywordp stuff) + (error "Can't extract font strings from the termcap entry yet.")) + ((and (= (length stuff) 2) + (stringp (car stuff)) + (stringp (cadr stuff))) + (setf (aref *tty-font-strings* font-id) + (cons (car stuff) (cadr stuff)))) + (t + (error "Bogus font spec: ~S~%Must be either a list of keywords or ~ + a list of the start string and end string.")))) + + +(defun compute-font-usages (dis-line) + (do ((results nil) + (change (dis-line-font-changes dis-line) (font-change-next change)) + (prev nil change)) + ((null change) + (when prev + (let ((font (font-change-font prev))) + (when (and (not (zerop font)) + (aref *tty-font-strings* font)) + (push (list* (font-change-font prev) + (font-change-x prev) + (dis-line-length dis-line)) + results)))) + (nreverse results)) + (when prev + (let ((font (font-change-font prev))) + (when (and (not (zerop font)) + (aref *tty-font-strings* font)) + (push (list* (font-change-font prev) + (font-change-x prev) + (font-change-x change)) + results)))))) + + + +;;;; Dumb window redisplay. + +(defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y) + (let ((dl (gensym)) (dl-chars (gensym)) (dl-fonts (gensym)) (dl-len (gensym)) + (dl-pos (gensym)) (screen-image-line (gensym))) + `(let* ((,dl ,dis-line) + (,dl-chars (dis-line-chars ,dl)) + (,dl-fonts (compute-font-usages ,dis-line)) + (,dl-len (dis-line-length ,dl)) + (,dl-pos ,(or y `(dis-line-position ,dl)))) + (funcall (tty-device-display-string ,device) + ,hunk 0 ,dl-pos ,dl-chars ,dl-fonts 0 ,dl-len) + (setf (dis-line-flags ,dl) unaltered-bits) + (setf (dis-line-delta ,dl) 0) + (select-hunk ,hunk) + (let ((,screen-image-line (si-line (tty-device-screen-image ,device) + (+ *hunk-top-line* ,dl-pos)))) + (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars + 0 0 ,dl-len) + (setf (si-line-length ,screen-image-line) ,dl-len) + (setf (si-line-fonts ,screen-image-line) ,dl-fonts))))) + +(defun tty-dumb-window-redisplay (window) + (let* ((first (window-first-line window)) + (hunk (window-hunk window)) + (device (device-hunk-device hunk)) + (screen-image (tty-device-screen-image device))) + (funcall (tty-device-clear-to-eow device) hunk 0 0) + (do ((i 0 (1+ i)) + (dl (cdr first) (cdr dl))) + ((eq dl the-sentinel) + (setf (window-old-lines window) (1- i)) + (select-hunk hunk) + (do ((last (tty-hunk-text-position hunk)) + (i (+ *hunk-top-line* i) (1+ i))) + ((> i last)) + (declare (fixnum i last)) + (let ((si-line (si-line screen-image i))) + (setf (si-line-length si-line) 0) + (setf (si-line-fonts si-line) nil)))) + (tty-dumb-line-redisplay device hunk (car dl) i)) + (setf (window-first-changed window) the-sentinel + (window-last-changed window) first) + (when (window-modeline-buffer window) + (let ((dl (window-modeline-dis-line window)) + (y (tty-hunk-modeline-pos hunk))) + (unwind-protect + (progn + (funcall (tty-device-standout-init device) hunk) + (funcall (tty-device-clear-to-eol device) hunk 0 y) + (tty-dumb-line-redisplay device hunk dl y)) + (funcall (tty-device-standout-end device) hunk)) + (setf (dis-line-flags dl) unaltered-bits))))) + + + + +;;;; Dumb redisplay top n lines of a window. + +(defun tty-redisplay-n-lines (window n) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (funcall (tty-device-clear-lines device) hunk 0 0 n) + (do ((n n (1- n)) + (dl (cdr (window-first-line window)) (cdr dl))) + ((or (zerop n) (eq dl the-sentinel))) + (tty-dumb-line-redisplay device hunk (car dl))))) + + + + +;;;; Semi dumb window redisplay + +;;; This is for terminals without opening and deleting lines. + +;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY, +;;; but it calls different line redisplay functions. +;;; +(defun tty-semi-dumb-window-redisplay (window) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (let ((first-changed (window-first-changed window)) + (last-changed (window-last-changed window))) + ;; Is there anything to do? + (unless (eq first-changed the-sentinel) + (if ;; One line-changed. + (and (eq first-changed last-changed) + (zerop (dis-line-delta (car first-changed)))) + (tty-semi-dumb-line-redisplay device hunk (car first-changed)) + ;; More lines changed. + (do-semi-dumb-line-writes first-changed last-changed hunk)) + ;; Set the bounds so we know we displayed... + (setf (window-first-changed window) the-sentinel + (window-last-changed window) (window-first-line window)))) + ;; + ;; Clear any extra lines at the end of the window. + (let ((pos (dis-line-position (car (window-last-line window))))) + (when (< pos (1- (window-height window))) + (tty-smart-clear-to-eow hunk (1+ pos))) + (setf (window-old-lines window) pos)) + ;; + ;; Update the modeline if needed. + (when (window-modeline-buffer window) + (let ((dl (window-modeline-dis-line window))) + (when (/= (dis-line-flags dl) unaltered-bits) + (unwind-protect + (progn + (funcall (tty-device-standout-init device) hunk) + (tty-smart-line-redisplay device hunk dl + (tty-hunk-modeline-pos hunk))) + (funcall (tty-device-standout-end device) hunk))))))) + +;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and +;;; COMPUTE-TTY-CHANGES. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro next-dis-line () + `(progn + (setf prev dl) + (setf dl (cdr dl)) + (setf flags (dis-line-flags (car dl))))) +) ;eval-when + +;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last +;;; changed line. The commented out code was a gratuitous optimization, +;;; especially if the first-changed line really is the first changes line. +;;; Anyway, this had to be removed because of this function's use in +;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to +;;; "Scroll Redraw Ratio". However, these supposedly moved lines had their +;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was +;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves. +;;; +(defun do-semi-dumb-line-writes (first-changed last-changed hunk) + (let* ((dl first-changed) + flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE. + prev) + ;; + ;; Skip old, unchanged, unmoved lines. + ;; (loop + ;; (unless (zerop flags) (return)) + ;; (next-dis-line)) + ;; + ;; Write every remaining line. + (let* ((device (device-hunk-device hunk)) + (force-output (device-force-output device))) + (loop + (tty-semi-dumb-line-redisplay device hunk (car dl)) + (when force-output (funcall force-output)) + (next-dis-line) + (when (eq prev last-changed) (return)))))) + +;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character +;;; comparing the display line and the screen image line, writes out the +;;; rest of the display line, and clears to end-of-line as necessary. +;;; +(defun tty-semi-dumb-line-redisplay (device hunk dl + &optional (dl-pos (dis-line-position dl))) + (declare (fixnum dl-pos)) + (let* ((dl-chars (dis-line-chars dl)) + (dl-len (dis-line-length dl)) + (dl-fonts (compute-font-usages dl))) + (declare (fixnum dl-len) (simple-string dl-chars)) + (when (listen-editor-input *editor-input*) + (throw 'redisplay-catcher :editor-input)) + (select-hunk hunk) + (let* ((screen-image-line (si-line (tty-device-screen-image device) + (+ *hunk-top-line* dl-pos))) + (si-line-chars (si-line-chars screen-image-line)) + (si-line-length (si-line-length screen-image-line)) + (findex (find-identical-prefix dl dl-fonts screen-image-line))) + (declare (type (or fixnum null) findex) (simple-string si-line-chars)) + ;; + ;; When the dis-line and screen chars are not string=. + (when findex + (cond + ;; See if the screen shows an initial substring of the dis-line. + ((= findex si-line-length) + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) + (replace-si-line si-line-chars dl-chars findex findex dl-len)) + ;; When the dis-line is an initial substring of what's on the screen. + ((= findex dl-len) + (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) + ;; Otherwise, blast dl-chars and clear to eol as necessary. + (t (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) + (when (< dl-len si-line-length) + (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) + (replace-si-line si-line-chars dl-chars findex findex dl-len))) + (setf (si-line-length screen-image-line) dl-len) + (setf (si-line-fonts screen-image-line) dl-fonts))) + (setf (dis-line-flags dl) unaltered-bits) + (setf (dis-line-delta dl) 0))) + + + + +;;;; Smart window redisplay -- operation queues and internal screen image. + +;;; This is used for creating temporary smart redisplay structures. +;;; +(defconstant tty-hunk-height-limit 100) + + +;;; Queues for redisplay operations and access macros. +;;; +(defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit))) + +(defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit))) + +(defvar *tty-line-writes* (make-array tty-hunk-height-limit)) + +(defvar *tty-line-moves* (make-array tty-hunk-height-limit)) + +(eval-when (:compile-toplevel :execute) + +(defmacro queue (value queue ptr) + `(progn + (setf (svref ,queue ,ptr) ,value) + (the fixnum (incf (the fixnum ,ptr))))) + +(defmacro dequeue (queue ptr) + `(prog1 + (svref ,queue ,ptr) + (the fixnum (incf (the fixnum ,ptr))))) + +) ;eval-when + +;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY. The counting is +;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES. +;;; +(defun insert-line-count (ins) + (do ((i 1 (+ i 2)) + (count 0 (+ count (svref *tty-line-insertions* i)))) + ((> i ins) count))) + + +;;; Temporary storage for screen-image lines and accessing macros. +;;; +(defvar *screen-image-temp* (make-array tty-hunk-height-limit)) + +(eval-when (:compile-toplevel :execute) + +;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's +;;; happening to the screen in a device's screen-image. At y, num +;;; lines are deleted and saved in *screen-image-temp*; fsil is the +;;; end of the free screen image lines saved here. Also, we must +;;; move lines up in the screen-image structure. In the outer loop +;;; we save lines in the temp storage and move lines up at the same +;;; time. In the termination/inner loop we move any lines that still +;;; need to be moved up. The screen-length is adjusted by the fsil +;;; because any time a deletion is in progress, there are fsil bogus +;;; lines at the bottom of the screen image from lines being moved +;;; up previously. +;;; +(defmacro delete-si-lines (screen-image y num fsil screen-length) + (let ((do-screen-image (gensym)) (delete-index (gensym)) + (free-lines (gensym)) (source-index (gensym)) (target-index (gensym)) + (n (gensym)) (do-screen-length (gensym)) (do-y (gensym))) + `(let ((,do-screen-image ,screen-image) + (,do-screen-length (- ,screen-length fsil)) + (,do-y ,y)) + (declare (fixnum ,do-screen-length ,do-y)) + (do ((,delete-index ,do-y (1+ ,delete-index)) + (,free-lines ,fsil (1+ ,free-lines)) + (,source-index (+ ,do-y ,num) (1+ ,source-index)) + (,n ,num (1- ,n))) + ((zerop ,n) + (do ((,target-index ,delete-index (1+ ,target-index)) + (,source-index ,source-index (1+ ,source-index))) + ((>= ,source-index ,do-screen-length)) + (declare (fixnum ,target-index ,source-index)) + (setf (si-line ,do-screen-image ,target-index) + (si-line ,do-screen-image ,source-index)))) + (declare (fixnum ,delete-index ,free-lines ,source-index ,n)) + (setf (si-line *screen-image-temp* ,free-lines) + (si-line ,do-screen-image ,delete-index)) + (when (< ,source-index ,do-screen-length) + (setf (si-line ,do-screen-image ,delete-index) + (si-line ,do-screen-image ,source-index))))))) + + +;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's +;;; happening to the screen in a device's screen-image. At y, num free +;;; lines are inserted from *screen-image-temp*; fsil is the end of the +;;; free lines. When copying lines down in screen-image, we must start +;;; with the lower lines and end with the higher ones, so we don't trash +;;; any lines. The outer loop does all the copying, and the termination/ +;;; inner loop inserts the free screen image lines, setting their length +;;; to zero. +;;; +(defmacro insert-si-lines (screen-image y num fsil screen-length) + (let ((do-screen-image (gensym)) (source-index (gensym)) + (target-index (gensym)) (target-terminus (gensym)) + (do-screen-length (gensym)) (temp (gensym)) (do-y (gensym)) + (insert-index (gensym)) (free-lines-index (gensym)) + (n (gensym))) + `(let ((,do-screen-length ,screen-length) + (,do-screen-image ,screen-image) + (,do-y ,y)) + (do ((,target-terminus (1- (+ ,do-y ,num))) ; (1- target-start) + (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end) + (1- ,source-index)) + (,target-index (- (+ ,do-screen-length ,num) + ,fsil 1) ; (1- target-end) + (1- ,target-index))) + ((= ,target-index ,target-terminus) + (do ((,insert-index ,do-y (1+ ,insert-index)) + (,free-lines-index (1- ,fsil) (1- ,free-lines-index)) + (,n ,num (1- ,n))) + ((zerop ,n)) + (declare (fixnum ,insert-index ,free-lines-index ,n)) + (let ((,temp (si-line *screen-image-temp* ,free-lines-index))) + (setf (si-line-length ,temp) 0) + (setf (si-line-fonts ,temp) nil) + (setf (si-line ,do-screen-image ,insert-index) ,temp))) + (decf ,fsil ,num)) + (declare (fixnum ,target-terminus ,source-index ,target-index)) + (setf (si-line ,do-screen-image ,target-index) + (si-line ,do-screen-image ,source-index)))))) + +) ;eval-when + + + + +;;;; Smart window redisplay -- the function. + +;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after +;;; some preliminary processing. If more than one line changed, +;;; then we compute changes to make to the screen in the form of +;;; line insertions, deletions, and writes. Deletions must be done +;;; first, so lines are not lost off the bottom of the screen by +;;; inserting lines. +;;; +(defun tty-smart-window-redisplay (window) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (let ((first-changed (window-first-changed window)) + (last-changed (window-last-changed window))) + ;; Is there anything to do? + (unless (eq first-changed the-sentinel) + (if (and (eq first-changed last-changed) + (zerop (dis-line-delta (car first-changed)))) + ;; One line-changed. + (tty-smart-line-redisplay device hunk (car first-changed)) + ;; More lines changed. + (multiple-value-bind (ins outs writes moves) + (compute-tty-changes + first-changed last-changed + (tty-hunk-modeline-pos hunk)) + (let ((ratio (variable-value 'hemlock::scroll-redraw-ratio))) + (cond ((and ratio + (> (/ (insert-line-count ins) + (tty-hunk-text-height hunk)) + ratio)) + (do-semi-dumb-line-writes first-changed last-changed + hunk)) + (t + (do-line-insertions hunk ins + (do-line-deletions hunk outs)) + (note-line-moves moves) + (do-line-writes hunk writes)))))) + ;; Set the bounds so we know we displayed... + (setf (window-first-changed window) the-sentinel + (window-last-changed window) (window-first-line window)))) + ;; + ;; Clear any extra lines at the end of the window. + (let ((pos (dis-line-position (car (window-last-line window))))) + (when (< pos (1- (window-height window))) + (tty-smart-clear-to-eow hunk (1+ pos))) + (setf (window-old-lines window) pos)) + ;; + ;; Update the modeline if needed. + (when (window-modeline-buffer window) + (let ((dl (window-modeline-dis-line window))) + (when (/= (dis-line-flags dl) unaltered-bits) + (unwind-protect + (progn + (funcall (tty-device-standout-init device) hunk) + (tty-smart-line-redisplay device hunk dl + (tty-hunk-modeline-pos hunk))) + (funcall (tty-device-standout-end device) hunk))))))) + + + + +;;;; Smart window redisplay -- computing changes to the display. + +;;; There is a lot of documentation here to help since this code is not +;;; obviously correct. The code is not that cryptic, but the correctness +;;; of the algorithm is somewhat. Most of the complexity is in handling +;;; lines that moved on the screen which the introduction deals with. +;;; Also, the block of documentation immediately before the function +;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of +;;; the function which is the largest block of code in the function. + +;;; The window image dis-lines are annotated with the difference between +;;; their current intended locations and their previous locations in the +;;; window. This delta (distance moved) is negative for an upward move and +;;; positive for a downward move. To determine what to do with moved +;;; groups of lines, we consider the transition (or difference in deltas) +;;; between two adjacent groups as we look at the window's dis-lines moving +;;; down the window image, disregarding whether they are contiguous (having +;;; moved only by a different delta) or separated by some lines (such as +;;; lines that are new and unmoved). +;;; +;;; Considering the transition between moved groups makes sense because a +;;; given group's delta affects all the lines below it since the dis-lines +;;; reflect the window's buffer's actual lines which are all connected in +;;; series. Therefore, if the previous group moved up some delta number of +;;; lines because of line deletions, then the lines below this group (down +;;; to the last line of the window image) moved up by the same delta too, +;;; unless one of the following is true: +;;; 1] The lines below the group moved up by a greater delta, possibly +;;; due to multiple disjoint buffer line deletions. +;;; 2] The lines below the group moved up by a lesser delta, possibly +;;; due to a number (less than the previous delta) of new line +;;; insertions below the group that moved up. +;;; 3] The lines below the group moved down, possibly due to a number +;;; (greater than the previous delta) of new line insertions below +;;; the group that moved up. +;;; Similarly, if the previous group moved down some delta number of lines +;;; because of new line insertions, then the lines below this group (down +;;; to the last line of the window image not to fall off the window's lower +;;; edge) moved down by the same delta too, unless one of the following is +;;; true: +;;; 1] The lines below the group moved down by a greater delta, possibly +;;; due to multiple disjoint buffer line insertions. +;;; 2] The lines below the group moved down by a lesser delta, possibly +;;; due to a number (less than the previous delta) of line deletions +;;; below the group that moved down. +;;; 3] The lines below the group moved up, possibly due to a number +;;; (greater than the previous delta) of line deletions below the +;;; group that moved down. +;;; +;;; Now we can see how the first moved group affects the window image below +;;; it except where there is a lower group of lines that have moved a +;;; different delta due to separate operations on the buffer's lines viewed +;;; through a window. We can see that this different delta is the expected +;;; effect throughout the window image below the second group, unless +;;; something lower down again has affected the window image. Also, in the +;;; case of a last group of lines that moved up, the group will never +;;; reflect all of the lines in the window image from the first line to +;;; move down to the bottom of the window image because somewhere down below +;;; the group that moved up are some new lines that have just been drawn up +;;; into the window's image. +;;; + +;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY. +;;; It goes through all the display lines for a window recording where +;;; lines need to be inserted, deleted, or written to make the screen +;;; consistent with the internal image of the screen. Pointers to +;;; the insertions, deletions, and writes that have to be done are +;;; returned. +;;; +;;; If a line is new, then simply queue it to be written. +;;; +;;; If a line is moved and/or changed, then we compute the difference +;;; between the last block of lines that moved with the same delta and the +;;; current block of lines that moved with the current delta. If this +;;; difference is positive, then some lines need to be deleted. Since we +;;; do all the line deletions first to prevent line insertions from +;;; dropping lines off the bottom of the screen, we have to compute the +;;; position of line deletions using the cumulative insertions +;;; (cum-inserts). Without any insertions, deletions may be done right at +;;; the dis-line's new position. With insertions needed above a given +;;; deletion point combined with the fact that deletions are all done +;;; first, the location for the deletion is higher than it would be without +;;; the insertions being done above the deletions. The location of the +;;; deletion is higher by the number of insertions we have currently put +;;; off. When computing the position of line insertions (a negative delta +;;; transition), we do not need to consider the cumulative insertions or +;;; cumulative deletions since everything above the point of insertion +;;; (both deletions and insertions) has been done. Because of the screen +;;; state being correct above the point of an insertion, the screen is only +;;; off by the delta transition number of lines. After determining the +;;; line insertions or deletions, loop over contiguous lines with the same +;;; delta queuing any changed ones to be written. The delta and flag +;;; fields are initialized according to the need to be written; since +;;; redisplay may be interrupted by more user input after moves have been +;;; done to the screen, we save the changed bit on, so the line will be +;;; queued to be written after redisplay is re-entered. +;;; +;;; If the line is changed or new, then queue it to be written. Since we can +;;; abort out of the actual dislpay at any time (due to pending input), we +;;; don't clear the flags or delta here. A dis-line may be groveled many times +;;; by this function before it actually makes it to the screen, so we may have +;;; odd combinations of bits such as both new and changed. +;;; +;;; Otherwise, get the next display line, loop, and see if it's +;;; interesting. +;;; +(defun compute-tty-changes (first-changed last-changed modeline-pos) + (declare (fixnum modeline-pos)) + (let* ((dl first-changed) + (flags (dis-line-flags (car dl))) + (ins 0) (outs 0) (writes 0) (moves 0) + (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0) + prev) + (declare (fixnum flags ins outs writes moves prev-delta cum-deletes + net-delta cum-inserts)) + (loop + (cond + ((logtest flags new-bit) + (queue (car dl) *tty-line-writes* writes) + (next-dis-line)) + ((logtest flags moved-bit) + (let* ((start-dl (car dl)) + (start-pos (dis-line-position start-dl)) + (curr-delta (dis-line-delta start-dl)) + (delta-delta (- prev-delta curr-delta)) + (car-dl start-dl)) + (declare (fixnum start-pos curr-delta delta-delta)) + (cond ((plusp delta-delta) + (queue (the fixnum (- start-pos cum-inserts)) + *tty-line-deletions* outs) + (queue delta-delta *tty-line-deletions* outs) + (incf cum-deletes delta-delta) + (decf net-delta delta-delta)) + ((minusp delta-delta) + (let ((eff-pos (the fixnum (+ start-pos delta-delta))) + (num (the fixnum (- delta-delta)))) + (queue eff-pos *tty-line-insertions* ins) + (queue num *tty-line-insertions* ins) + (incf net-delta num) + (incf cum-inserts num)))) + (loop + (if (logtest flags (logior changed-bit new-bit)) + (queue car-dl *tty-line-writes* writes) + (queue car-dl *tty-line-moves* moves)) + (next-dis-line) + (setf car-dl (car dl)) + (when (or (eq prev last-changed) + (/= (the fixnum (dis-line-delta car-dl)) curr-delta)) + (setf prev-delta curr-delta) + (return))))) + ((logtest flags (logior changed-bit new-bit)) + (queue (car dl) *tty-line-writes* writes) + (next-dis-line)) + (t + (next-dis-line))) + + (when (eq prev last-changed) + (unless (zerop net-delta) + (cond ((plusp net-delta) + (queue (the fixnum (- modeline-pos cum-deletes net-delta)) + *tty-line-deletions* outs) + (queue net-delta *tty-line-deletions* outs)) + (t (queue (the fixnum (+ modeline-pos net-delta)) + *tty-line-insertions* ins) + (queue (the fixnum (- net-delta)) + *tty-line-insertions* ins)))) + (return (values ins outs writes moves)))))) + + + +;;;; Smart window redisplay -- operation methods. + +;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk. +;;; It takes care not to clear a line unless it really has some characters +;;; displayed on it. It also maintains the device's screen image lines. +;;; +(defun tty-smart-clear-to-eow (hunk y) + (let* ((device (device-hunk-device hunk)) + (screen-image (tty-device-screen-image device)) + (clear-to-eol (tty-device-clear-to-eol device))) + (select-hunk hunk) + (do ((y y (1+ y)) + (si-idx (+ *hunk-top-line* y) (1+ si-idx)) + (last (tty-hunk-text-position hunk))) + ((> si-idx last)) + (declare (fixnum y si-idx last)) + (let ((si-line (si-line screen-image si-idx))) + (unless (zerop (si-line-length si-line)) + (funcall clear-to-eol hunk 0 y) + (setf (si-line-length si-line) 0) + (setf (si-line-fonts si-line) nil)))))) + +;;; NOTE-LINE-MOVES -- Internal +;;; +;;; Clear out the flags and delta of lines that have been moved. +;;; +(defun note-line-moves (moves) + (let ((i 0)) + (loop + (when (= i moves) (return)) + (let ((dl (dequeue *tty-line-moves* i))) + (setf (dis-line-flags dl) unaltered-bits) + (setf (dis-line-delta dl) 0))))) + +;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue, +;;; deleting lines from hunk's area of the screen. The internal screen +;;; image is updated, and the total number of lines deleted is returned. +;;; +(defun do-line-deletions (hunk outs) + (declare (fixnum outs)) + (let* ((i 0) + (device (device-hunk-device hunk)) + (fun (tty-device-delete-line device)) + (fsil 0)) ;free-screen-image-lines + (declare (fixnum i fsil)) + (loop + (when (= i outs) (return fsil)) + (let ((y (dequeue *tty-line-deletions* i)) + (num (dequeue *tty-line-deletions* i))) + (declare (fixnum y num)) + (funcall fun hunk 0 y num) + (select-hunk hunk) + (delete-si-lines (tty-device-screen-image device) + (+ *hunk-top-line* y) num fsil + (tty-device-lines device)) + (incf fsil num))))) + +;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue, +;;; inserting lines into hunk's area of the screen. The internal screen +;;; image is updated using free screen image lines pointed to by fsil. +;;; +(defun do-line-insertions (hunk ins fsil) + (declare (fixnum ins fsil)) + (let* ((i 0) + (device (device-hunk-device hunk)) + (fun (tty-device-open-line device))) + (declare (fixnum i)) + (loop + (when (= i ins) (return)) + (let ((y (dequeue *tty-line-insertions* i)) + (num (dequeue *tty-line-insertions* i))) + (declare (fixnum y num)) + (funcall fun hunk 0 y num) + (select-hunk hunk) + (insert-si-lines (tty-device-screen-image device) + (+ *hunk-top-line* y) num fsil + (tty-device-lines device)))))) + +;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying +;;; these dis-lines with TTY-SMART-LINE-REDISPLAY. We force output after +;;; each line, so the user can see how far we've gotten in case he chooses +;;; to give more editor commands which will abort redisplay until there's no +;;; more input. +;;; +(defun do-line-writes (hunk writes) + (declare (fixnum writes)) + (let* ((i 0) + (device (device-hunk-device hunk)) + (force-output (device-force-output device))) + (declare (fixnum i)) + (loop + (when (= i writes) (return)) + (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i)) + (when force-output (funcall force-output))))) + +;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to +;;; try to do minimal character shipping to the terminal. Roughly, we find +;;; the first different character when comparing what's on the screen and +;;; what should be there; we will start altering the line after this same +;;; initial substring. Then we find, from the end, the first character +;;; that is different, blasting out characters to the lesser of the two +;;; indexes. If the dis-line index is lesser, we have some characters to +;;; delete from the screen, and if the screen index is lesser, we have some +;;; additional dis-line characters to insert. There are a few special +;;; cases that allow us to punt out of the above algorithm sketch. If the +;;; terminal doesn't have insert mode or delete mode, we have blast out to +;;; the end of the dis-line and possibly clear to the end of the screen's +;;; line, as appropriate. Sometimes we don't use insert or delete mode +;;; because of the overhead cost in characters; it simply is cheaper to +;;; blast out characters and clear to eol. +;;; +(defun tty-smart-line-redisplay (device hunk dl + &optional (dl-pos (dis-line-position dl))) + (declare (fixnum dl-pos)) + (let* ((dl-chars (dis-line-chars dl)) + (dl-len (dis-line-length dl)) + (dl-fonts (compute-font-usages dl))) + (declare (fixnum dl-len) (simple-string dl-chars)) + (when (listen-editor-input *editor-input*) + (throw 'redisplay-catcher :editor-input)) + (select-hunk hunk) + (let* ((screen-image-line (si-line (tty-device-screen-image device) + (+ *hunk-top-line* dl-pos))) + (si-line-chars (si-line-chars screen-image-line)) + (si-line-length (si-line-length screen-image-line)) + (findex (find-identical-prefix dl dl-fonts screen-image-line))) + (declare (type (or fixnum null) findex) (simple-string si-line-chars)) + ;; + ;; When the dis-line and screen chars are not string=. + (when findex + (block tslr-main-body + ;; + ;; See if the screen shows an initial substring of the dis-line. + (when (= findex si-line-length) + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) + (replace-si-line si-line-chars dl-chars findex findex dl-len) + (return-from tslr-main-body t)) + ;; + ;; When the dis-line is an initial substring of what's on the screen. + (when (= findex dl-len) + (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos) + (return-from tslr-main-body t)) + ;; + ;; Find trailing substrings that are the same. + (multiple-value-bind + (sindex dindex) + (let ((count (find-identical-suffix dl dl-fonts + screen-image-line))) + (values (- si-line-length count) + (- dl-len count))) + (declare (fixnum sindex dindex)) + ;; + ;; No trailing substrings -- blast and clear to eol. + (when (= dindex dl-len) + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) + (when (< dindex sindex) + (funcall (tty-device-clear-to-eol device) + hunk dl-len dl-pos)) + (replace-si-line si-line-chars dl-chars findex findex dl-len) + (return-from tslr-main-body t)) + (let ((lindex (min sindex dindex))) + (cond ((< lindex findex) + ;; This can happen in funny situations -- believe me! + (setf lindex findex)) + (t + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars dl-fonts + findex lindex) + (replace-si-line si-line-chars dl-chars + findex findex lindex))) + (cond + ((= dindex sindex)) + ((< dindex sindex) + (let ((delete-char-num (- sindex dindex))) + (cond ((and (tty-device-delete-char device) + (worth-using-delete-mode + device delete-char-num (- si-line-length dl-len))) + (funcall (tty-device-delete-char device) + hunk dindex dl-pos delete-char-num)) + (t + (funcall (tty-device-display-string device) + hunk dindex dl-pos dl-chars dl-fonts + dindex dl-len) + (funcall (tty-device-clear-to-eol device) + hunk dl-len dl-pos))))) + (t + (if (and (tty-device-insert-string device) + (worth-using-insert-mode device (- dindex sindex) + (- dl-len sindex))) + (funcall (tty-device-insert-string device) + hunk sindex dl-pos dl-chars sindex dindex) + (funcall (tty-device-display-string device) + hunk sindex dl-pos dl-chars dl-fonts + sindex dl-len)))) + (replace-si-line si-line-chars dl-chars + lindex lindex dl-len)))) + (setf (si-line-length screen-image-line) dl-len) + (setf (si-line-fonts screen-image-line) dl-fonts))) + (setf (dis-line-flags dl) unaltered-bits) + (setf (dis-line-delta dl) 0))) + + + + +;;;; Device methods + +;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions). +;;; These can be found in Tty-Display-Rt.Lisp. + + +;;; Clearing the device (DEVICE-CLEAR functions). + +(defun clear-device (device) + (device-write-string (tty-device-clear-string device)) + (cursor-motion device 0 0) + (setf (tty-device-cursor-x device) 0) + (setf (tty-device-cursor-y device) 0)) + + +;;; Moving the cursor around (DEVICE-PUT-CURSOR) + +;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's +;;; axis to the screen's and determines the minimal cost cursor motion +;;; sequence. Currently, it does no cost analysis of relative motion +;;; compared to absolute motion but simply makes sure the cursor isn't +;;; already where we want it. +;;; +(defun tty-put-cursor (hunk x y) + (declare (fixnum x y)) + (select-hunk hunk) + (let ((y (the fixnum (+ *hunk-top-line* y))) + (device (device-hunk-device hunk))) + (declare (fixnum y)) + (unless (and (= (the fixnum (tty-device-cursor-x device)) x) + (= (the fixnum (tty-device-cursor-y device)) y)) + (cursor-motion device x y) + (setf (tty-device-cursor-x device) x) + (setf (tty-device-cursor-y device) y)))) + +;;; UPDATE-CURSOR is used in device redisplay methods to make sure the +;;; cursor is where it should be. +;;; +(eval-when (:compile-toplevel :execute) + (defmacro update-cursor (hunk x y) + `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y)) +) ;eval-when + +;;; CURSOR-MOTION takes two coordinates on the screen's axis, +;;; moving the cursor to that location. X is the column index, +;;; and y is the line index, but Unix and Termcap believe that +;;; the default order of indexes is first the line and then the +;;; column or (y,x). Because of this, when reversep is non-nil, +;;; we send first x and then y. +;;; +(defun cursor-motion (device x y) + (let ((x-add-char (tty-device-cm-x-add-char device)) + (y-add-char (tty-device-cm-y-add-char device)) + (x-condx-add (tty-device-cm-x-condx-char device)) + (y-condx-add (tty-device-cm-y-condx-char device)) + (one-origin (tty-device-cm-one-origin device))) + (when x-add-char (incf x x-add-char)) + (when (and x-condx-add (> x x-condx-add)) + (incf x (tty-device-cm-x-condx-add-char device))) + (when y-add-char (incf y y-add-char)) + (when (and y-condx-add (> y y-condx-add)) + (incf y (tty-device-cm-y-condx-add-char device))) + (when one-origin (incf x) (incf y))) + (device-write-string (tty-device-cm-string1 device)) + (let ((reversep (tty-device-cm-reversep device)) + (x-pad (tty-device-cm-x-pad device)) + (y-pad (tty-device-cm-y-pad device))) + (if reversep + (cm-output-coordinate x x-pad) + (cm-output-coordinate y y-pad)) + (device-write-string (tty-device-cm-string2 device)) + (if reversep + (cm-output-coordinate y y-pad) + (cm-output-coordinate x x-pad)) + (device-write-string (tty-device-cm-string3 device)))) + +;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad. If +;;; there is a pad, then the coordinate needs to be sent as digit-char's (for +;;; each digit in the coordinate), and if there is no pad, the coordinate needs +;;; to be converted into a character. Using CODE-CHAR here is not really +;;; portable. With a pad, the coordinate buffer is filled from the end as we +;;; truncate the coordinate by 10, generating ones digits. +;;; +(defconstant cm-coordinate-buffer-len 5) +(defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len)) +;;; +(defun cm-output-coordinate (coordinate pad) + (cond (pad + (let ((i (1- cm-coordinate-buffer-len))) + (loop + (when (= i -1) (error "Terminal has too many lines!")) + (multiple-value-bind (tens ones) + (truncate coordinate 10) + (setf (schar *cm-coordinate-buffer* i) (digit-char ones)) + (when (zerop tens) + (dotimes (n (- pad (- cm-coordinate-buffer-len i))) + (decf i) + (setf (schar *cm-coordinate-buffer* i) #\0)) + (device-write-string *cm-coordinate-buffer* i + cm-coordinate-buffer-len) + (return)) + (decf i) + (setf coordinate tens))))) + (t (tty-write-char (code-char coordinate))))) + + +;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions) + +;;; DISPLAY-STRING is used to put a string at (x,y) on the device. +;;; +(defun display-string (hunk x y string font-info + &optional (start 0) (end (strlen string))) + (declare (fixnum x y start end)) + (update-cursor hunk x y) + ;; Ignore font info for chars before the start of the string. + (loop + (if (or (null font-info) + (< start (cddar font-info))) + (return) + (pop font-info))) + (let ((posn start)) + (dolist (next-font font-info) + (let ((font (car next-font)) + (start (cadr next-font)) + (stop (cddr next-font))) + (when (<= end start) + (return)) + (when (< posn start) + (device-write-string string posn start) + (setf posn start)) + (let ((new-posn (min stop end)) + (font-strings (aref *tty-font-strings* font))) + (unwind-protect + (progn + (device-write-string (car font-strings)) + (device-write-string string posn new-posn)) + (device-write-string (cdr font-strings))) + (setf posn new-posn)))) + (when (< posn end) + (device-write-string string posn end))) + (setf (tty-device-cursor-x (device-hunk-device hunk)) + (the fixnum (+ x (the fixnum (- end start)))))) + +;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special +;;; case underlines doing an overstrike when they don't otherwise overstrike. +;;; Note: we do not know in this code whether the terminal can backspace (or +;;; what the sequence is), whether the terminal has insert-mode, or whether +;;; the terminal has delete-mode. +;;; +(defun display-string-checking-underlines (hunk x y string font-info + &optional (start 0) + (end (strlen string))) + (declare (ignore font-info)) + (declare (fixnum x y start end) (simple-string string)) + (update-cursor hunk x y) + (let ((upos (position #\_ string :test #'char= :start start :end end)) + (device (device-hunk-device hunk))) + (if upos + (let ((previous start) + (after-pos 0)) + (declare (fixnum previous after-pos)) + (loop (device-write-string string previous upos) + (setf after-pos (do ((i (1+ upos) (1+ i))) + ((or (= i end) + (char/= (schar string i) #\_)) i) + (declare (fixnum i)))) + (let ((ulen (the fixnum (- after-pos upos))) + (cursor-x (the fixnum (+ x (the fixnum + (- after-pos start)))))) + (declare (fixnum ulen)) + (dotimes (i ulen) (tty-write-char #\space)) + (setf (tty-device-cursor-x device) cursor-x) + (update-cursor hunk upos y) + (dotimes (i ulen) (tty-write-char #\_)) + (setf (tty-device-cursor-x device) cursor-x)) + (setf previous after-pos) + (setf upos (position #\_ string :test #'char= + :start previous :end end)) + (unless upos + (device-write-string string previous end) + (return)))) + (device-write-string string start end)) + (setf (tty-device-cursor-x device) + (the fixnum (+ x (the fixnum (- end start))))))) + + +;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless +;;; of cursor position. +;;; +(defun device-write-string (string &optional (start 0) (end (strlen string))) + (declare (fixnum start end)) + (unless (= start end) + (tty-write-string string start (the fixnum (- end start))))) + + +;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and +;;; TTY-DEVICE-CLEAR-TO-EOW functions.) + +(defun clear-to-eol (hunk x y) + (update-cursor hunk x y) + (device-write-string + (tty-device-clear-to-eol-string (device-hunk-device hunk)))) + +(defun space-to-eol (hunk x y) + (declare (fixnum x)) + (update-cursor hunk x y) + (let* ((device (device-hunk-device hunk)) + (num (- (the fixnum (tty-device-columns device)) + x))) + (declare (fixnum num)) + (dotimes (i num) (tty-write-char #\space)) + (setf (tty-device-cursor-x device) (+ x num)))) + +(defun clear-lines (hunk x y n) + (let* ((device (device-hunk-device hunk)) + (clear-to-eol (tty-device-clear-to-eol device))) + (funcall clear-to-eol hunk x y) + (do ((y (1+ y) (1+ y)) + (count (1- n) (1- count))) + ((zerop count) + (setf (tty-device-cursor-x device) 0) + (setf (tty-device-cursor-y device) (1- y))) + (declare (fixnum count y)) + (funcall clear-to-eol hunk 0 y)))) + +(defun clear-to-eow (hunk x y) + (declare (fixnum x y)) + (funcall (tty-device-clear-lines (device-hunk-device hunk)) + hunk x y + (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y)))) + + +;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE) + +(defun open-tty-line (hunk x y &optional (n 1)) + (update-cursor hunk x y) + (dotimes (i n) + (device-write-string (tty-device-open-line-string (device-hunk-device hunk))))) + +(defun delete-tty-line (hunk x y &optional (n 1)) + (update-cursor hunk x y) + (dotimes (i n) + (device-write-string (tty-device-delete-line-string (device-hunk-device hunk))))) + + +;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR) + +(defun tty-insert-string (hunk x y string + &optional (start 0) (end (strlen string))) + (declare (fixnum x y start end)) + (update-cursor hunk x y) + (let* ((device (device-hunk-device hunk)) + (init-string (tty-device-insert-init-string device)) + (char-init-string (tty-device-insert-char-init-string device)) + (char-end-string (tty-device-insert-char-end-string device)) + (end-string (tty-device-insert-end-string device))) + (declare (type (or simple-string null) char-init-string char-end-string)) + (when init-string (device-write-string init-string)) + (if char-init-string + (let ((cis-len (length char-init-string)) + (ces-len (length char-end-string))) + (do ((i start (1+ i))) + ((= i end)) + (device-write-string char-init-string 0 cis-len) + (tty-write-char (schar string i)) + (when char-end-string + (device-write-string char-end-string 0 ces-len)))) + (device-write-string string start end)) + (when end-string (device-write-string end-string)) + (setf (tty-device-cursor-x device) + (the fixnum (+ x (the fixnum (- end start))))))) + +(defun worth-using-insert-mode (device insert-char-num chars-saved) + (let* ((init-string (tty-device-insert-init-string device)) + (char-init-string (tty-device-insert-char-init-string device)) + (char-end-string (tty-device-insert-char-end-string device)) + (end-string (tty-device-insert-end-string device)) + (cost 0)) + (when init-string (incf cost (length (the simple-string init-string)))) + (when char-init-string + (incf cost (* insert-char-num (+ (length (the simple-string + char-init-string)) + (if char-end-string + (length (the simple-string + char-end-string)) + 0))))) + (when end-string (incf cost (length (the simple-string end-string)))) + (< cost chars-saved))) + +(defun delete-char (hunk x y &optional (n 1)) + (declare (fixnum x y n)) + (update-cursor hunk x y) + (let* ((device (device-hunk-device hunk)) + (init-string (tty-device-delete-init-string device)) + (end-string (tty-device-delete-end-string device)) + (delete-char-string (tty-device-delete-char-string device))) + (when init-string (device-write-string init-string)) + (dotimes (i n) + (device-write-string delete-char-string)) + (when end-string (device-write-string end-string)))) + +(defun worth-using-delete-mode (device delete-char-num clear-char-num) + (declare (fixnum delete-char-num clear-char-num)) + (let ((init-string (tty-device-delete-init-string device)) + (end-string (tty-device-delete-end-string device)) + (delete-char-string (tty-device-delete-char-string device)) + (clear-to-eol-string (tty-device-clear-to-eol-string device)) + (cost 0)) + (declare (type (or simple-string null) init-string end-string + delete-char-string) + (fixnum cost)) + (when init-string (incf cost (the fixnum (length init-string)))) + (when end-string (incf cost (the fixnum (length end-string)))) + (incf cost (the fixnum + (* (the fixnum (length delete-char-string)) + delete-char-num))) + (< cost (+ delete-char-num + (if clear-to-eol-string + (length clear-to-eol-string) + clear-char-num))))) + + +;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END) + +(defun standout-init (hunk) + (device-write-string + (tty-device-standout-init-string (device-hunk-device hunk)))) + +(defun standout-end (hunk) + (device-write-string + (tty-device-standout-end-string (device-hunk-device hunk)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-screen.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-screen.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/tty/tty-screen.lisp (revision 8058) @@ -0,0 +1,404 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles, except for the code that implements random typeout, +;;; which was done by Blaine Burks and Bill Chiles. The code for splitting +;;; windows was rewritten by Blaine Burks to allow more than a 50/50 split. +;;; +;;; Terminal device screen management functions. +;;; + +(in-package :hemlock-internals) + + + + +;;;; Terminal screen initialization + +(declaim (special *parse-starting-mark*)) + +(defun init-tty-screen-manager (tty-name) + (setf *line-wrap-char* #\!) + (setf *window-list* ()) + (let* ((device (make-tty-device tty-name)) + (width (tty-device-columns device)) + (height (tty-device-lines device)) + (echo-height (value hemlock::echo-area-height)) + (main-lines (- height echo-height 1)) ;-1 for echo modeline. + (main-text-lines (1- main-lines)) ;also main-modeline-pos. + (last-text-line (1- main-text-lines))) + (setf (device-bottom-window-base device) last-text-line) + ;; + ;; Make echo area. + (let* ((echo-hunk (make-tty-hunk :position (1- height) :height echo-height + :text-position (- height 2) + :text-height echo-height :device device)) + (echo (internal-make-window :hunk echo-hunk))) + (setf *echo-area-window* echo) + (setf (device-hunk-window echo-hunk) echo) + (setup-window-image *parse-starting-mark* echo echo-height width) + (setup-modeline-image *echo-area-buffer* echo) + (setf (device-hunk-previous echo-hunk) echo-hunk + (device-hunk-next echo-hunk) echo-hunk) + (prepare-window-for-redisplay echo)) + ;; + ;; Make the main window. + (let* ((main-hunk (make-tty-hunk :position main-text-lines + :height main-lines + :text-position last-text-line + :text-height main-text-lines + :device device)) + (main (internal-make-window :hunk main-hunk))) + (setf (device-hunk-window main-hunk) main) + (setf *current-window* main) + (setup-window-image (buffer-point *current-buffer*) + main main-text-lines width) + (setup-modeline-image *current-buffer* main) + (prepare-window-for-redisplay main) + (setf (device-hunk-previous main-hunk) main-hunk + (device-hunk-next main-hunk) main-hunk) + (setf (device-hunks device) main-hunk)) + (defhvar "Paren Pause Period" + "This is how long commands that deal with \"brackets\" shows the cursor at + the matching \"bracket\" for this number of seconds." + :value 0.5 + :mode "Lisp"))) + + + + +;;;; Building devices from termcaps. + +;;; MAKE-TTY-DEVICE returns a device built from a termcap. Some function +;;; slots are set to the appropriate function even though the capability +;;; might not exist; in this case, we simply set the control string value +;;; to the empty string. Some function slots are set differently depending +;;; on available capability. +;;; +(defun make-tty-device (name) + (let ((termcap (get-termcap name)) + (device (%make-tty-device :name name))) + (when (termcap :overstrikes termcap) + (error "Terminal sufficiently irritating -- not currently supported.")) + ;; + ;; Similar device slots. + (setf (device-init device) #'init-tty-device) + (setf (device-exit device) #'exit-tty-device) + (setf (device-smart-redisplay device) + (if (and (termcap :open-line termcap) (termcap :delete-line termcap)) + #'tty-smart-window-redisplay + #'tty-semi-dumb-window-redisplay)) + (setf (device-dumb-redisplay device) #'tty-dumb-window-redisplay) + (setf (device-clear device) #'clear-device) + (setf (device-put-cursor device) #'tty-put-cursor) + (setf (device-show-mark device) #'tty-show-mark) + (setf (device-next-window device) #'tty-next-window) + (setf (device-previous-window device) #'tty-previous-window) + (setf (device-make-window device) #'tty-make-window) + (setf (device-delete-window device) #'tty-delete-window) + (setf (device-random-typeout-setup device) #'tty-random-typeout-setup) + (setf (device-random-typeout-cleanup device) #'tty-random-typeout-cleanup) + (setf (device-random-typeout-full-more device) #'do-tty-full-more) + (setf (device-random-typeout-line-more device) + #'update-tty-line-buffered-stream) + (setf (device-force-output device) #'tty-force-output) + (setf (device-finish-output device) #'tty-finish-output) + (setf (device-beep device) #'tty-beep) + ;; + ;; A few useful values. + (setf (tty-device-dumbp device) + (not (and (termcap :open-line termcap) + (termcap :delete-line termcap)))) + ;; + ;; Get size and speed. + (multiple-value-bind (lines cols speed) + (get-terminal-attributes) + (setf (tty-device-lines device) (or lines (termcap :lines termcap))) + (let ((cols (or cols (termcap :columns termcap)))) + (setf (tty-device-columns device) + (if (termcap :auto-margins-p termcap) + (1- cols) cols))) + (setf (tty-device-speed device) speed)) + ;; + ;; Some function slots. + (setf (tty-device-display-string device) + (if (termcap :underlines termcap) + #'display-string-checking-underlines + #'display-string)) + (setf (tty-device-standout-init device) #'standout-init) + (setf (tty-device-standout-end device) #'standout-end) + (setf (tty-device-open-line device) + (if (termcap :open-line termcap) + #'open-tty-line + ;; look for scrolling region stuff + )) + (setf (tty-device-delete-line device) + (if (termcap :delete-line termcap) + #'delete-tty-line + ;; look for reverse scrolling stuff + )) + (setf (tty-device-clear-to-eol device) + (if (termcap :clear-to-eol termcap) + #'clear-to-eol + #'space-to-eol)) + (setf (tty-device-clear-lines device) #'clear-lines) + (setf (tty-device-clear-to-eow device) #'clear-to-eow) + ;; + ;; Insert and delete modes. + (let ((init-insert-mode (termcap :init-insert-mode termcap)) + (init-insert-char (termcap :init-insert-char termcap)) + (end-insert-char (termcap :end-insert-char termcap))) + (when (and init-insert-mode (string/= init-insert-mode "")) + (setf (tty-device-insert-string device) #'tty-insert-string) + (setf (tty-device-insert-init-string device) init-insert-mode) + (setf (tty-device-insert-end-string device) + (termcap :end-insert-mode termcap))) + (when init-insert-char + (setf (tty-device-insert-string device) #'tty-insert-string) + (setf (tty-device-insert-char-init-string device) init-insert-char)) + (when (and end-insert-char (string/= end-insert-char "")) + (setf (tty-device-insert-char-end-string device) end-insert-char))) + (let ((delete-char (termcap :delete-char termcap))) + (when delete-char + (setf (tty-device-delete-char device) #'delete-char) + (setf (tty-device-delete-char-string device) delete-char) + (setf (tty-device-delete-init-string device) + (termcap :init-delete-mode termcap)) + (setf (tty-device-delete-end-string device) + (termcap :end-delete-mode termcap)))) + ;; + ;; Some string slots. + (setf (tty-device-standout-init-string device) + (or (termcap :init-standout-mode termcap) "")) + (setf (tty-device-standout-end-string device) + (or (termcap :end-standout-mode termcap) "")) + (setf (tty-device-clear-to-eol-string device) + (termcap :clear-to-eol termcap)) + (let ((clear-string (termcap :clear-display termcap))) + (unless clear-string + (error "Terminal not sufficiently powerful enough to run Hemlock.")) + (setf (tty-device-clear-string device) clear-string)) + (setf (tty-device-open-line-string device) + (termcap :open-line termcap)) + (setf (tty-device-delete-line-string device) + (termcap :delete-line termcap)) + (let* ((init-string (termcap :init-string termcap)) + (init-file (termcap :init-file termcap)) + (init-file-string (if init-file (get-init-file-string init-file))) + (init-cm-string (termcap :init-cursor-motion termcap))) + (setf (tty-device-init-string device) + (concatenate 'simple-string (or init-string "") + (or init-file-string "") (or init-cm-string "")))) + (setf (tty-device-cm-end-string device) + (or (termcap :end-cursor-motion termcap) "")) + ;; + ;; Cursor motion slots. + (let ((cursor-motion (termcap :cursor-motion termcap))) + (unless cursor-motion + (error "Terminal not sufficiently powerful enough to run Hemlock.")) + (let ((x-add-char (getf cursor-motion :x-add-char)) + (y-add-char (getf cursor-motion :y-add-char)) + (x-condx-char (getf cursor-motion :x-condx-char)) + (y-condx-char (getf cursor-motion :y-condx-char))) + (when x-add-char + (setf (tty-device-cm-x-add-char device) (char-code x-add-char))) + (when y-add-char + (setf (tty-device-cm-y-add-char device) (char-code y-add-char))) + (when x-condx-char + (setf (tty-device-cm-x-condx-char device) (char-code x-condx-char)) + (setf (tty-device-cm-x-condx-add-char device) + (char-code (getf cursor-motion :x-condx-add-char)))) + (when y-condx-char + (setf (tty-device-cm-y-condx-char device) (char-code y-condx-char)) + (setf (tty-device-cm-y-condx-add-char device) + (char-code (getf cursor-motion :y-condx-add-char))))) + (setf (tty-device-cm-string1 device) (getf cursor-motion :string1)) + (setf (tty-device-cm-string2 device) (getf cursor-motion :string2)) + (setf (tty-device-cm-string3 device) (getf cursor-motion :string3)) + (setf (tty-device-cm-one-origin device) (getf cursor-motion :one-origin)) + (setf (tty-device-cm-reversep device) (getf cursor-motion :reversep)) + (setf (tty-device-cm-x-pad device) (getf cursor-motion :x-pad)) + (setf (tty-device-cm-y-pad device) (getf cursor-motion :y-pad))) + ;; + ;; Screen image initialization. + (let* ((lines (tty-device-lines device)) + (columns (tty-device-columns device)) + (screen-image (make-array lines))) + (dotimes (i lines) + (setf (svref screen-image i) (make-si-line columns))) + (setf (tty-device-screen-image device) screen-image)) + device)) + + + + +;;;; Making a window + +(defun tty-make-window (device start modelinep window font-family + ask-user x y width height proportion) + (declare (ignore window font-family ask-user x y width height)) + (let* ((old-window (current-window)) + (victim (window-hunk old-window)) + (text-height (tty-hunk-text-height victim)) + (availability (if modelinep (1- text-height) text-height))) + (when (> availability 1) + (let* ((new-lines (truncate (* availability proportion))) + (old-lines (- availability new-lines)) + (pos (device-hunk-position victim)) + (new-height (if modelinep (1+ new-lines) new-lines)) + (new-text-pos (if modelinep (1- pos) pos)) + (new-hunk (make-tty-hunk :position pos + :height new-height + :text-position new-text-pos + :text-height new-lines + :device device)) + (new-window (internal-make-window :hunk new-hunk))) + (declare (fixnum new-lines old-lines pos new-height new-text-pos)) + (setf (device-hunk-window new-hunk) new-window) + (let* ((old-text-pos-diff (- pos (tty-hunk-text-position victim))) + (old-win-new-pos (- pos new-height))) + (declare (fixnum old-text-pos-diff old-win-new-pos)) + (setf (device-hunk-height victim) + (- (device-hunk-height victim) new-height)) + (setf (tty-hunk-text-height victim) old-lines) + (setf (device-hunk-position victim) old-win-new-pos) + (setf (tty-hunk-text-position victim) + (- old-win-new-pos old-text-pos-diff))) + (setup-window-image start new-window new-lines + (window-width old-window)) + (prepare-window-for-redisplay new-window) + (when modelinep + (setup-modeline-image (line-buffer (mark-line start)) new-window)) + (change-window-image-height old-window old-lines) + (shiftf (device-hunk-previous new-hunk) + (device-hunk-previous (device-hunk-next victim)) + new-hunk) + (shiftf (device-hunk-next new-hunk) (device-hunk-next victim) new-hunk) + (setf *currently-selected-hunk* nil) + (setf *screen-image-trashed* t) + new-window)))) + + + + +;;;; Deleting a window + +(defun tty-delete-window (window) + (let* ((hunk (window-hunk window)) + (prev (device-hunk-previous hunk)) + (next (device-hunk-next hunk)) + (device (device-hunk-device hunk))) + (setf (device-hunk-next prev) next) + (setf (device-hunk-previous next) prev) + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delq window (buffer-windows buffer)))) + (let ((new-lines (device-hunk-height hunk))) + (declare (fixnum new-lines)) + (cond ((eq hunk (device-hunks (device-hunk-device next))) + (incf (device-hunk-height next) new-lines) + (incf (tty-hunk-text-height next) new-lines) + (let ((w (device-hunk-window next))) + (change-window-image-height w (+ new-lines (window-height w))))) + (t + (incf (device-hunk-height prev) new-lines) + (incf (device-hunk-position prev) new-lines) + (incf (tty-hunk-text-height prev) new-lines) + (incf (tty-hunk-text-position prev) new-lines) + (let ((w (device-hunk-window prev))) + (change-window-image-height w (+ new-lines (window-height w))))))) + (when (eq hunk (device-hunks device)) + (setf (device-hunks device) next))) + (setf *currently-selected-hunk* nil) + (setf *screen-image-trashed* t)) + + + + +;;;; Next and Previous window operations. + +(defun tty-next-window (window) + (device-hunk-window (device-hunk-next (window-hunk window)))) + +(defun tty-previous-window (window) + (device-hunk-window (device-hunk-previous (window-hunk window)))) + + + + +;;;; Random typeout support + +(defun tty-random-typeout-setup (device stream height) + (declare (fixnum height)) + (let* ((*more-prompt-action* :empty) + (height (min (1- (device-bottom-window-base device)) height)) + (old-hwindow (random-typeout-stream-window stream)) + (new-hwindow (if old-hwindow + (change-tty-random-typeout-window old-hwindow height) + (setf (random-typeout-stream-window stream) + (make-tty-random-typeout-window + device + (buffer-start-mark + (line-buffer + (mark-line + (random-typeout-stream-mark stream)))) + height))))) + (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0))) + +(defun change-tty-random-typeout-window (window height) + (update-modeline-field (window-buffer window) window :more-prompt) + (let* ((height-1 (1- height)) + (hunk (window-hunk window))) + (setf (device-hunk-position hunk) height-1 + (device-hunk-height hunk) height + (tty-hunk-text-position hunk) (1- height-1) + (tty-hunk-text-height hunk) height-1) + (change-window-image-height window height-1) + window)) + +(defun make-tty-random-typeout-window (device mark height) + (let* ((height-1 (1- height)) + (hunk (make-tty-hunk :position height-1 + :height height + :text-position (1- height-1) + :text-height height-1 + :device device)) + (window (internal-make-window :hunk hunk))) + (setf (device-hunk-window hunk) window) + (setf (device-hunk-device hunk) device) + (setup-window-image mark window height-1 (tty-device-columns device)) + (setf *window-list* (delete window *window-list*)) + (prepare-window-for-redisplay window) + (setup-modeline-image (line-buffer (mark-line mark)) window) + (update-modeline-field (window-buffer window) window :more-prompt) + window)) + +(defun tty-random-typeout-cleanup (stream degree) + (declare (ignore degree)) + (let* ((window (random-typeout-stream-window stream)) + (stream-hunk (window-hunk window)) + (last-line-affected (device-hunk-position stream-hunk)) + (device (device-hunk-device stream-hunk)) + (*more-prompt-action* :normal)) + (declare (fixnum last-line-affected)) + (update-modeline-field (window-buffer window) window :more-prompt) + (funcall (tty-device-clear-to-eow device) stream-hunk 0 0) + (do* ((hunk (device-hunks device) (device-hunk-next hunk)) + (window (device-hunk-window hunk) (device-hunk-window hunk)) + (last (device-hunk-previous hunk))) + ((>= (device-hunk-position hunk) last-line-affected) + (if (= (device-hunk-position hunk) last-line-affected) + (redisplay-window-all window) + (tty-redisplay-n-lines window + (- (+ last-line-affected + (tty-hunk-text-height hunk)) + (tty-hunk-text-position hunk))))) + (redisplay-window-all window) + (when (eq hunk last) (return))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/unixcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/unixcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/unixcoms.lisp (revision 8058) @@ -0,0 +1,258 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; +;;; This file contains Commands useful when running on a Unix box. Hopefully +;;; there are no CMU Unix dependencies though there are probably CMU Common +;;; Lisp dependencies, such as RUN-PROGRAM. +;;; +;;; Written by Christopher Hoover. + +(in-package :hemlock) + + + + +;;;; Region and File printing commands. + +(defhvar "Print Utility" + "UNIX(tm) program to invoke (via EXT:RUN-PROGRAM) to do printing. + The program should act like lpr: if a filename is given as an argument, + it should print that file, and if no name appears, standard input should + be assumed." + :value "lpr") + +(defhvar "Print Utility Switches" + "Switches to pass to the \"Print Utility\" program. This should be a list + of strings." + :value ()) + + +;;; PRINT-SOMETHING calls RUN-PROGRAM on the utility-name and args. Output +;;; and error output are done to the echo area, and errors are ignored for +;;; now. Run-program-keys are other keywords to pass to RUN-PROGRAM in +;;; addition to :wait, :output, and :error. +;;; +(defmacro print-something (&optional (run-program-keys) + (utility-name '(value print-utility)) + (args '(value print-utility-switches))) + (let ((pid (gensym)) + (error-code (gensym))) + `(multiple-value-bind (,pid ,error-code) + (ext:run-program ,utility-name ,args + ,@run-program-keys + :wait t + :output *echo-area-stream* + :error *echo-area-stream*) + (declare (ignore ,pid ,error-code)) + (force-output *echo-area-stream*) + ;; Keep the echo area from being cleared at the top of the command loop. + (setf (buffer-modified *echo-area-buffer*) nil)))) + + +;;; PRINT-REGION -- Interface +;;; +;;; Takes a region and outputs the text to the program defined by +;;; the hvar "Print Utility" with options form the hvar "Print +;;; Utility Options" using PRINT-SOMETHING. +;;; +(defun print-region (region) + (with-input-from-region (s region) + (print-something (:input s)))) + + +(defcommand "Print Buffer" (p) + "Prints the current buffer using the program defined by the hvar + \"Print Utility\" with the options from the hvar \"Print Utility + Options\". Errors appear in the echo area." + "Prints the contents of the buffer." + (declare (ignore p)) + (message "Printing buffer...~%") + (print-region (buffer-region (current-buffer)))) + +(defcommand "Print Region" (p) + "Prints the current region using the program defined by the hvar + \"Print Utility\" with the options from the hvar \"Print Utility + Options\". Errors appear in the echo area." + "Prints the current region." + (declare (ignore p)) + (message "Printing region...~%") + (print-region (current-region))) + +(defcommand "Print File" (p) + "Prompts for a file and prints it usings the program defined by + the hvar \"Print Utility\" with the options from the hvar \"Print + Utility Options\". Errors appear in the echo area." + "Prints a file." + (declare (ignore p)) + (let* ((pn (prompt-for-file :prompt "File to print: " + :help "Name of file to print." + :default (buffer-default-pathname (current-buffer)) + :must-exist t)) + (ns (namestring (truename pn)))) + (message "Printing file...~%") + (print-something () (value print-utility) + (append (value print-utility-switches) (list ns))))) + + + +;;;; Scribe. + +(defcommand "Scribe File" (p) + "Scribe a file with the default directory set to the directory of the + specified file. The output from running Scribe is sent to the + \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility + Switches\"." + "Scribe a file with the default directory set to the directory of the + specified file." + (declare (ignore p)) + (scribe-file (prompt-for-file :prompt "Scribe file: " + :default + (buffer-default-pathname (current-buffer))))) + +(defhvar "Scribe Buffer File Confirm" + "When set, \"Scribe Buffer File\" prompts for confirmation before doing + anything." + :value t) + +(defcommand "Scribe Buffer File" (p) + "Scribe the file associated with the current buffer. The default directory + set to the directory of the file. The output from running Scribe is sent to + the \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility + Switches\". Before doing anything the user is asked to confirm saving and + Scribe'ing the file. This prompting can be inhibited by with \"Scribe Buffer + File Confirm\"." + "Scribe a file with the default directory set to the directory of the + specified file." + (declare (ignore p)) + (let* ((buffer (current-buffer)) + (pathname (buffer-pathname buffer)) + (modified (buffer-modified buffer))) + (when (or (not (value scribe-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "~:[S~;Save and s~]cribe file ~A? " + modified (namestring pathname)))) + (when modified (write-buffer-file buffer pathname)) + (scribe-file pathname)))) + +(defhvar "Scribe Utility" + "Program name to invoke (via EXT:RUN-PROGRAM) to do text formatting." + :value "scribe") + +(defhvar "Scribe Utility Switches" + "Switches to pass to the \"Scribe Utility\" program. This should be a list + of strings." + :value ()) + +(defun scribe-file (pathname) + (let* ((pathname (truename pathname)) + (out-buffer (or (getstring "Scribe Warnings" *buffer-names*) + (make-buffer "Scribe Warnings"))) + (out-point (buffer-end (buffer-point out-buffer))) + (stream (make-hemlock-output-stream out-point :line)) + (orig-cwd (default-directory))) + (buffer-end out-point) + (insert-character out-point #\newline) + (insert-character out-point #\newline) + (unwind-protect + (progn + (setf (default-directory) (directory-namestring pathname)) + (ext:run-program (namestring (value scribe-utility)) + (list* (namestring pathname) + (value scribe-utility-switches)) + :output stream :error stream + :wait nil)) + (setf (default-directory) orig-cwd)))) + + + +;;;; UNIX Filter Region + +(defcommand "Unix Filter Region" (p) + "Unix Filter Region prompts for a UNIX program and then passes the current + region to the program as standard input. The standard output from the + program is used to replace the region. This command is undo-able." + "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal + Hemlock commands; use UNIX-FILTER-REGION instead." + (declare (ignore p)) + (let* ((region (current-region)) + (filter-and-args (prompt-for-string + :prompt "Filter: " + :help "Unix program to filter the region through.")) + (filter-and-args-list (listify-unix-filter-string filter-and-args)) + (filter (car filter-and-args-list)) + (args (cdr filter-and-args-list)) + (new-region (unix-filter-region region filter args)) + (start (copy-mark (region-start region) :right-inserting)) + (end (copy-mark (region-end region) :left-inserting)) + (old-region (region start end)) + (undo-region (delete-and-save-region old-region))) + (ninsert-region end new-region) + (make-region-undo :twiddle "Unix Filter Region" old-region undo-region))) + +(defun unix-filter-region (region command args) + "Passes the region REGION as standard input to the program COMMAND + with arguments ARGS and returns the standard output as a freshly + cons'ed region." + (let ((new-region (make-empty-region))) + (with-input-from-region (input region) + (with-output-to-mark (output (region-end new-region) :full) + (ext:run-program command args + :input input + :output output + :error output))) + new-region)) + +(defun listify-unix-filter-string (str) + (declare (simple-string str)) + (let ((result nil) + (lastpos 0)) + (loop + (let ((pos (position #\Space str :start lastpos :test #'char=))) + (push (subseq str lastpos pos) result) + (unless pos + (return)) + (setf lastpos (1+ pos)))) + (nreverse result))) + + + + +;;;; Man pages. + +(defcommand "Manual Page" (p) + "Read the Unix manual pages in a View buffer. + If given an argument, this will put the man page in a Pop-up display." + "Read the Unix manual pages in a View buffer. + If given an argument, this will put the man page in a Pop-up display." + (let ((topic (prompt-for-string :prompt "Man topic: "))) + (if p + (with-pop-up-display (stream) + (execute-man topic stream)) + (let* ((buf-name (format nil "Man Page ~a" topic)) + (new-buffer (make-buffer buf-name :modes '("Fundamental" "View"))) + (buffer (or new-buffer (getstring buf-name *buffer-names*))) + (point (buffer-point buffer))) + (change-to-buffer buffer) + (when new-buffer + (setf (value view-return-function) #'(lambda ())) + (with-writable-buffer (buffer) + (with-output-to-mark (s point :full) + (execute-man topic s)))) + (buffer-start point buffer))))) + +(defun execute-man (topic stream) + (ext:run-program + "/bin/sh" + (list "-c" + (format nil "man ~a| ul -t adm3" topic)) + :output stream)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/window.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/window.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/window.lisp (revision 8058) @@ -0,0 +1,690 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains implementation independent code which implements +;;; the Hemlock window primitives and most of the code which defines +;;; other aspects of the interface to redisplay. +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; + +(in-package :hemlock-internals) + +(defconstant unaltered-bits #b000 + "This is the value of the dis-line-flags when a line is neither moved nor + changed nor new.") +(defconstant changed-bit #b001 + "This bit is set in the dis-line-flags when a line is found to be changed.") +(defconstant moved-bit #b010 + "This bit is set in the dis-line-flags when a line is found to be moved.") +(defconstant new-bit #b100 + "This bit is set in the dis-line-flags when a line is found to be new.") + + + +;;;; CURRENT-WINDOW. + +(defvar *current-window* nil "The current window object.") +(defvar *window-list* () "A list of all window objects.") + +(declaim (inline current-window)) + +(defun current-window () + "Return the current window. The current window is specially treated by + redisplay in several ways, the most important of which is that is does + recentering, ensuring that the Buffer-Point of the current window's + Window-Buffer is always displayed. This may be set with Setf." + *current-window*) + +(defun %set-current-window (new-window) + (invoke-hook hemlock::set-window-hook new-window) + (move-mark (window-point *current-window*) + (buffer-point (window-buffer *current-window*))) + (move-mark (buffer-point (window-buffer new-window)) + (window-point new-window)) + (setq *current-window* new-window)) + + + + +;;;; Window structure support. + +(defun %print-hwindow (obj stream depth) + (declare (ignore depth)) + (write-string "#" stream)) + + +(defun window-buffer (window) + "Return the buffer which is displayed in Window." + (window-%buffer window)) + +(defun %set-window-buffer (window new-buffer) + (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer)) + (unless (windowp window) (error "~S is not a window." window)) + (unless (eq new-buffer (window-buffer window)) + (invoke-hook hemlock::window-buffer-hook window new-buffer) + ;; + ;; Move the window's marks to the new start. + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) + (move-mark (buffer-display-start buffer) (window-display-start window)) + (push window (buffer-windows new-buffer)) + (move-mark (window-point window) (buffer-point new-buffer)) + (move-mark (window-display-start window) (buffer-display-start new-buffer)) + (move-mark (window-display-end window) (buffer-display-start new-buffer))) + ;; + ;; Delete all the dis-lines, and nil out the line and chars so they get + ;; gc'ed. + (let ((first (window-first-line window)) + (last (window-last-line window)) + (free (window-spare-lines window))) + (unless (eq (cdr first) *the-sentinel*) + (shiftf (cdr last) free (cdr first) *the-sentinel*)) + (dolist (dl free) + (setf (dis-line-line dl) nil (dis-line-old-chars dl) nil)) + (setf (window-spare-lines window) free)) + ;; + ;; Set the last line and first&last changed so we know there's nothing there. + (setf (window-last-line window) *the-sentinel* + (window-first-changed window) *the-sentinel* + (window-last-changed window) *the-sentinel*) + ;; + ;; Make sure the window gets updated, and set the buffer. + (setf (window-tick window) -3) + (setf (window-%buffer window) new-buffer))) + + + + +;;; %INIT-REDISPLAY sets up redisplay's internal data structures. We create +;;; initial windows, setup some hooks to cause modeline recomputation, and call +;;; any device init necessary. This is called from ED. +;;; +(defun %init-redisplay (display) + (%init-screen-manager display) + (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change) + (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change) + (add-hook hemlock::buffer-name-hook 'queue-buffer-change) + (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change) + (add-hook hemlock::buffer-modified-hook 'queue-buffer-change) + (add-hook hemlock::window-buffer-hook 'queue-window-change) + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-init device) device)) + (center-window *current-window* (current-point))) + + + + +;;;; Modelines-field structure support. + +(defun print-modeline-field (obj stream ignore) + (declare (ignore ignore)) + (write-string "#" stream)) + +(defun print-modeline-field-info (obj stream ignore) + (declare (ignore ignore)) + (write-string "#" stream)) + + +(defvar *modeline-field-names* (make-hash-table)) + +(defun make-modeline-field (&key name width function) + "Returns a modeline-field object." + (unless (or (eq width nil) (and (integerp width) (plusp width))) + (error "Width must be nil or a positive integer.")) + (when (gethash name *modeline-field-names*) + (with-simple-restart (continue + "Use the new definition for this modeline field.") + (error "Modeline field ~S already exists." + (gethash name *modeline-field-names*)))) + (setf (gethash name *modeline-field-names*) + (%make-modeline-field name function width))) + +(defun modeline-field (name) + "Returns the modeline-field object named name. If none exists, return nil." + (gethash name *modeline-field-names*)) + + +(declaim (inline modeline-field-name modeline-field-width + modeline-field-function)) + +(defun modeline-field-name (ml-field) + "Returns the name of a modeline field object." + (modeline-field-%name ml-field)) + +(defun %set-modeline-field-name (ml-field name) + (check-type ml-field modeline-field) + (when (gethash name *modeline-field-names*) + (error "Modeline field ~S already exists." + (gethash name *modeline-field-names*))) + (remhash (modeline-field-%name ml-field) *modeline-field-names*) + (setf (modeline-field-%name ml-field) name) + (setf (gethash name *modeline-field-names*) ml-field)) + +(defun modeline-field-width (ml-field) + "Returns the width of a modeline field." + (modeline-field-%width ml-field)) + +(declaim (special *buffer-list*)) + +(defun %set-modeline-field-width (ml-field width) + (check-type ml-field modeline-field) + (unless (or (eq width nil) (and (integerp width) (plusp width))) + (error "Width must be nil or a positive integer.")) + (unless (eql width (modeline-field-%width ml-field)) + (setf (modeline-field-%width ml-field) width) + (dolist (b *buffer-list*) + (when (buffer-modeline-field-p b ml-field) + (dolist (w (buffer-windows b)) + (update-modeline-fields b w))))) + width) + +(defun modeline-field-function (ml-field) + "Returns the function of a modeline field object. It returns a string." + (modeline-field-%function ml-field)) + +(defun %set-modeline-field-function (ml-field function) + (check-type ml-field modeline-field) + (check-type function (or symbol function)) + (setf (modeline-field-%function ml-field) function) + (dolist (b *buffer-list*) + (when (buffer-modeline-field-p b ml-field) + (dolist (w (buffer-windows b)) + (update-modeline-field b w ml-field)))) + function) + + + + +;;;; Modelines maintenance. + +;;; Each window stores a modeline-buffer which is a string hunk-width-limit +;;; long. Whenever a field is updated, we must maintain a maximally long +;;; representation of the modeline in case the window is resized. Updating +;;; then first gets the modeline-buffer setup, and second blasts the necessary +;;; portion into the window's modeline-dis-line, setting the dis-line's changed +;;; flag. +;;; + +(defun update-modeline-fields (buffer window) + "Recompute all the fields of buffer's modeline for window, so the next + redisplay will reflect changes." + (let ((ml-buffer (window-modeline-buffer window))) + (declare (simple-string ml-buffer)) + (when ml-buffer + (let* ((ml-buffer-len + (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos)) + (start 0 (blt-modeline-field-buffer + ml-buffer (car finfos) buffer window start))) + ((null finfos) start))) + (dis-line (window-modeline-dis-line window)) + (len (min (window-width window) ml-buffer-len))) + (replace (the simple-string (dis-line-chars dis-line)) ml-buffer + :end1 len :end2 len) + (setf (window-modeline-buffer-len window) ml-buffer-len) + (setf (dis-line-length dis-line) len) + (setf (dis-line-flags dis-line) changed-bit))))) + +;;; UPDATE-MODELINE-FIELD must replace the entire dis-line-chars with ml-buffer +;;; after blt'ing into buffer. Otherwise it has to do all the work +;;; BLT-MODELINE-FIELD-BUFFER to figure out how to adjust dis-line-chars. It +;;; isn't worth it. Since things could have shifted around, after calling +;;; BLT-MODELINE-FIELD-BUFFER, we get the last field's end to know how long +;;; the buffer is now. +;;; +(defun update-modeline-field (buffer window field) + "Recompute the field of the buffer's modeline for window, so the next + redisplay will reflect the change. Field is either a modeline-field object + or the name of one for buffer." + (let ((finfo (internal-buffer-modeline-field-p buffer field))) + (unless finfo + (error "~S is not a modeline-field or the name of one for buffer ~S." + field buffer)) + (let ((ml-buffer (window-modeline-buffer window)) + (dis-line (window-modeline-dis-line window))) + (declare (simple-string ml-buffer)) + (blt-modeline-field-buffer ml-buffer finfo buffer window + (ml-field-info-start finfo) t) + (let* ((ml-buffer-len (ml-field-info-end + (car (last (buffer-%modeline-fields buffer))))) + (dis-len (min (window-width window) ml-buffer-len))) + (replace (the simple-string (dis-line-chars dis-line)) ml-buffer + :end1 dis-len :end2 dis-len) + (setf (window-modeline-buffer-len window) ml-buffer-len) + (setf (dis-line-length dis-line) dis-len) + (setf (dis-line-flags dis-line) changed-bit))))) + +(defvar *truncated-field-char* #\!) + +;;; BLT-MODELINE-FIELD-BUFFER takes a Hemlock buffer, Hemlock window, the +;;; window's modeline buffer, a modeline-field-info object, a start in the +;;; modeline buffer, and an optional indicating whether a variable width field +;;; should be handled carefully. When the field is fixed-width, this is +;;; simple. When it is variable, we possibly have to shift all the text in the +;;; buffer right or left before storing the new string, updating all the +;;; finfo's after the one we're updating. It is an error for the +;;; modeline-field-function to return anything but a simple-string with +;;; standard-chars. This returns the end of the field blasted into ml-buffer. +;;; +(defun blt-modeline-field-buffer (ml-buffer finfo buffer window start + &optional fix-other-fields-p) + (declare (simple-string ml-buffer)) + (let* ((f (ml-field-info-field finfo)) + (width (modeline-field-width f)) + (string (funcall (modeline-field-function f) buffer window)) + (str-len (length string))) + (declare (simple-string string)) + (setf (ml-field-info-start finfo) start) + (setf (ml-field-info-end finfo) + (cond + ((not width) + (let ((end (min (+ start str-len) hunk-width-limit)) + (last-end (ml-field-info-end finfo))) + (when (and fix-other-fields-p (/= end last-end)) + (blt-ml-field-buffer-fix ml-buffer finfo buffer window + end last-end)) + (replace ml-buffer string :start1 start :end1 end :end2 str-len) + end)) + ((= str-len width) + (let ((end (min (+ start width) hunk-width-limit))) + (replace ml-buffer string :start1 start :end1 end :end2 width) + end)) + ((> str-len width) + (let* ((end (min (+ start width) hunk-width-limit)) + (end-1 (1- end))) + (replace ml-buffer string :start1 start :end1 end-1 :end2 width) + (setf (schar ml-buffer end-1) *truncated-field-char*) + end)) + (t + (let ((buf-replace-end (min (+ start str-len) hunk-width-limit)) + (buf-field-end (min (+ start width) hunk-width-limit))) + (replace ml-buffer string + :start1 start :end1 buf-replace-end :end2 str-len) + (fill ml-buffer #\space :start buf-replace-end :end buf-field-end) + buf-field-end)))))) + +;;; BLT-ML-FIELD-BUFFER-FIX shifts the contents of ml-buffer in the direction +;;; of last-end to end. finfo is a modeline-field-info structure in buffer's +;;; list of these. If there are none following finfo, then we simply store the +;;; new end of the buffer. After blt'ing the text around, we have to update +;;; all the finfos' starts and ends making sure nobody gets to stick out over +;;; the ml-buffer's end. +;;; +(defun blt-ml-field-buffer-fix (ml-buffer finfo buffer window end last-end) + (declare (simple-string ml-buffer)) + (let ((finfos (do ((f (buffer-%modeline-fields buffer) (cdr f))) + ((null f) (error "This field must be here.")) + (if (eq (car f) finfo) + (return (cdr f)))))) + (cond + ((not finfos) + (setf (window-modeline-buffer-len window) (min end hunk-width-limit))) + (t + (let ((buffer-len (window-modeline-buffer-len window))) + (replace ml-buffer ml-buffer + :start1 end + :end1 (min (+ end (- buffer-len last-end)) hunk-width-limit) + :start2 last-end :end2 buffer-len) + (let ((diff (- end last-end))) + (macrolet ((frob (f) + `(setf ,f (min (+ ,f diff) hunk-width-limit)))) + (dolist (f finfos) + (frob (ml-field-info-start f)) + (frob (ml-field-info-end f))) + (frob (window-modeline-buffer-len window))))))))) + + + + +;;;; Default modeline and update hooks. + +(make-modeline-field :name :hemlock-literal :width 8 + :function #'(lambda (buffer window) + "Returns \"Hemlock \"." + (declare (ignore buffer window)) + "Hemlock ")) + +(make-modeline-field + :name :package + :function #'(lambda (buffer window) + "Returns the value of buffer's \"Current Package\" followed + by a colon and two spaces, or a string with one space." + (declare (ignore window)) + (if (hemlock-bound-p 'hemlock::current-package :buffer buffer) + (let ((val (variable-value 'hemlock::current-package + :buffer buffer))) + (if val + (format nil "~A: " val) + " ")) + " "))) + +(make-modeline-field + :name :modes + :function #'(lambda (buffer window) + "Returns buffer's modes followed by one space." + (declare (ignore window)) + (format nil "~A " (buffer-modes buffer)))) + +(make-modeline-field + :name :modifiedp + :function #'(lambda (buffer window) + "Returns \"* \" if buffer is modified, or the empty string." + (declare (ignore window)) + (let ((modifiedp (buffer-modified buffer))) + (if modifiedp + "* " + "")))) + +(make-modeline-field + :name :buffer-name + :function #'(lambda (buffer window) + "Returns buffer's name followed by a colon and a space if the + name is not derived from the buffer's pathname, or the empty + string." + (declare (ignore window)) + (let ((pn (buffer-pathname buffer)) + (name (buffer-name buffer))) + (cond ((not pn) + (format nil "~A: " name)) + ((string/= (hemlock::pathname-to-buffer-name pn) name) + (format nil "~A: " name)) + (t ""))))) + + +;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline +;;; Pathname Length" is set. +;;; +(defun maximum-modeline-pathname-length-hook (name kind where new-value) + (declare (ignore name new-value)) + (if (eq kind :buffer) + (hi::queue-buffer-change where) + (dolist (buffer *buffer-list*) + (when (and (buffer-modeline-field-p buffer :buffer-pathname) + (buffer-windows buffer)) + (hi::queue-buffer-change buffer))))) + +(defun buffer-pathname-ml-field-fun (buffer window) + "Returns the namestring of buffer's pathname if there is one. When + \"Maximum Modeline Pathname Length\" is set, and the namestring is too long, + return a truncated namestring chopping off leading directory specifications." + (declare (ignore window)) + (let ((pn (buffer-pathname buffer))) + (if pn + (let* ((name (namestring pn)) + (length (length name)) + ;; Prefer a buffer local value over the global one. + ;; Because variables don't work right, blow off looking for + ;; a value in the buffer's modes. In the future this will + ;; be able to get the "current" value as if buffer were current. + (max (if (hemlock-bound-p 'hemlock::maximum-modeline-pathname-length + :buffer buffer) + (variable-value 'hemlock::maximum-modeline-pathname-length + :buffer buffer) + (variable-value 'hemlock::maximum-modeline-pathname-length + :global)))) + (declare (simple-string name)) + (if (or (not max) (<= length max)) + name + (let* ((extra-chars (+ (- length max) 3)) + (slash (or (position #\/ name :start extra-chars) + ;; If no slash, then file-namestring is very + ;; long, and we should include all of it: + (position #\/ name :from-end t + :end extra-chars)))) + (if slash + (concatenate 'simple-string "..." (subseq name slash)) + name)))) + ""))) + +(make-modeline-field + :name :buffer-pathname + :function 'buffer-pathname-ml-field-fun) + + +(defvar *default-modeline-fields* + (list (modeline-field :hemlock-literal) + (modeline-field :package) + (modeline-field :modes) + (modeline-field :modifiedp) + (modeline-field :buffer-name) + (modeline-field :buffer-pathname)) + "This is the default value for \"Default Modeline Fields\".") + + + +;;; QUEUE-BUFFER-CHANGE is used for various buffer hooks (e.g., mode changes, +;;; name changes, etc.), so it takes some arguments to ignore. These hooks are +;;; invoked at a bad time to update the actual modeline-field, and user's may +;;; have fields that change as a function of the changes this function handles. +;;; This makes his update easier. It doesn't cost much update the entire line +;;; anyway. +;;; +(defun queue-buffer-change (buffer &optional something-else another-else) + (declare (ignore something-else another-else)) + (push (list #'update-modelines-for-buffer buffer) *things-to-do-once*)) + +(defun update-modelines-for-buffer (buffer) + (unless (eq buffer *echo-area-buffer*) + (dolist (w (buffer-windows buffer)) + (update-modeline-fields buffer w)))) + + +;;; QUEUE-WINDOW-CHANGE is used for the "Window Buffer Hook". We ignore the +;;; argument since this hook function is invoked before any changes are made, +;;; and the changes must be made before the fields can be set according to the +;;; window's buffer's properties. Therefore, we must queue the change to +;;; happen sometime before redisplay but after the change takes effect. +;;; +(defun queue-window-change (window &optional something-else) + (declare (ignore something-else)) + (push (list #'update-modeline-for-window window) *things-to-do-once*)) + +(defun update-modeline-for-window (window) + (update-modeline-fields (window-buffer window) window)) + + + + +;;;; Bitmap setting up new windows and modifying old. + +(defvar dummy-line (make-window-dis-line "") + "Dummy dis-line that we put at the head of window's dis-lines") +(setf (dis-line-position dummy-line) -1) + + +;;; WINDOW-FOR-HUNK makes a Hemlock window and sets up its dis-lines and marks +;;; to display starting at start. +;;; +(defun window-for-hunk (hunk start modelinep) + (check-type start mark) + (setf (bitmap-hunk-changed-handler hunk) #'window-changed) + (let ((buffer (line-buffer (mark-line start))) + (first (cons dummy-line *the-sentinel*)) + (width (bitmap-hunk-char-width hunk)) + (height (bitmap-hunk-char-height hunk))) + (when (or (< height minimum-window-lines) + (< width minimum-window-columns)) + (error "Window too small.")) + (unless buffer (error "Window start is not in a buffer.")) + (let ((window + (internal-make-window + :hunk hunk + :display-start (copy-mark start :right-inserting) + :old-start (copy-mark start :temporary) + :display-end (copy-mark start :right-inserting) + :%buffer buffer + :point (copy-mark (buffer-point buffer)) + :height height + :width width + :first-line first + :last-line *the-sentinel* + :first-changed *the-sentinel* + :last-changed first + :tick -1))) + (push window *window-list*) + (push window (buffer-windows buffer)) + ;; + ;; Make the dis-lines. + (do ((i (- height) (1+ i)) + (res () + (cons (make-window-dis-line (make-string width)) res))) + ((= i height) (setf (window-spare-lines window) res))) + ;; + ;; Make the image up to date. + (update-window-image window) + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) + ;; + ;; If there is a modeline, set it up. + (when modelinep + (setup-modeline-image buffer window) + (setf (bitmap-hunk-modeline-dis-line hunk) + (window-modeline-dis-line window))) + window))) + +;;; SETUP-MODELINE-IMAGE sets up the modeline-dis-line for window using the +;;; modeline-fields list. This is used by tty redisplay too. +;;; +(defun setup-modeline-image (buffer window) + (setf (window-modeline-buffer window) (make-string hunk-width-limit)) + (setf (window-modeline-dis-line window) + (make-window-dis-line (make-string (window-width window)))) + (update-modeline-fields buffer window)) + +;;; Window-Changed -- Internal +;;; +;;; The bitmap-hunk changed handler for windows. This is only called if +;;; the hunk is not locked. We invalidate the window image and change its +;;; size, then do a full redisplay. +;;; +(defun window-changed (hunk) + (let ((window (bitmap-hunk-window hunk))) + ;; + ;; Nuke all the lines in the window image. + (unless (eq (cdr (window-first-line window)) *the-sentinel*) + (shiftf (cdr (window-last-line window)) + (window-spare-lines window) + (cdr (window-first-line window)) + *the-sentinel*)) + (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) + ;; + ;; Add some new spare lines if needed. If width is greater, + ;; reallocate the dis-line-chars. + (let* ((res (window-spare-lines window)) + (new-width (bitmap-hunk-char-width hunk)) + (new-height (bitmap-hunk-char-height hunk)) + (width (length (the simple-string (dis-line-chars (car res)))))) + (declare (list res)) + (when (> new-width width) + (setq width new-width) + (dolist (dl res) + (setf (dis-line-chars dl) (make-string new-width)))) + (setf (window-height window) new-height (window-width window) new-width) + (do ((i (- (* new-height 2) (length res)) (1- i))) + ((minusp i)) + (push (make-window-dis-line (make-string width)) res)) + (setf (window-spare-lines window) res) + ;; + ;; Force modeline update. + (let ((ml-buffer (window-modeline-buffer window))) + (when ml-buffer + (let ((dl (window-modeline-dis-line window)) + (chars (make-string new-width)) + (len (min new-width (window-modeline-buffer-len window)))) + (setf (dis-line-old-chars dl) nil) + (setf (dis-line-chars dl) chars) + (replace chars ml-buffer :end1 len :end2 len) + (setf (dis-line-length dl) len) + (setf (dis-line-flags dl) changed-bit))))) + ;; + ;; Prepare for redisplay. + (setf (window-tick window) (tick)) + (update-window-image window) + (when (eq window *current-window*) (maybe-recenter-window window)) + hunk)) + + + + +;;; EDITOR-FINISH-OUTPUT is used to synch output to a window with the rest of the +;;; system. +;;; +(defun editor-finish-output (window) + (let* ((device (device-hunk-device (window-hunk window))) + (finish-output (device-finish-output device))) + (when finish-output + (funcall finish-output device window)))) + + + + +;;;; Tty setting up new windows and modifying old. + +;;; setup-window-image -- Internal +;;; +;;; Set up the dis-lines and marks for Window to display starting +;;; at Start. Height and Width are the number of lines and columns in +;;; the window. +;;; +(defun setup-window-image (start window height width) + (check-type start mark) + (let ((buffer (line-buffer (mark-line start))) + (first (cons dummy-line *the-sentinel*))) + (unless buffer (error "Window start is not in a buffer.")) + (setf (window-display-start window) (copy-mark start :right-inserting) + (window-old-start window) (copy-mark start :temporary) + (window-display-end window) (copy-mark start :right-inserting) + (window-%buffer window) buffer + (window-point window) (copy-mark (buffer-point buffer)) + (window-height window) height + (window-width window) width + (window-first-line window) first + (window-last-line window) *the-sentinel* + (window-first-changed window) *the-sentinel* + (window-last-changed window) first + (window-tick window) -1) + (push window *window-list*) + (push window (buffer-windows buffer)) + ;; + ;; Make the dis-lines. + (do ((i (- height) (1+ i)) + (res () + (cons (make-window-dis-line (make-string width)) res))) + ((= i height) (setf (window-spare-lines window) res))) + ;; + ;; Make the image up to date. + (update-window-image window))) + +;;; change-window-image-height -- Internal +;;; +;;; Milkshake. +;;; +(defun change-window-image-height (window new-height) + ;; Nuke all the lines in the window image. + (unless (eq (cdr (window-first-line window)) *the-sentinel*) + (shiftf (cdr (window-last-line window)) + (window-spare-lines window) + (cdr (window-first-line window)) + *the-sentinel*)) + ;; Add some new spare lines if needed. + (let* ((res (window-spare-lines window)) + (width (length (the simple-string (dis-line-chars (car res)))))) + (declare (list res)) + (setf (window-height window) new-height) + (do ((i (- (* new-height 2) (length res)) (1- i))) + ((minusp i)) + (push (make-window-dis-line (make-string width)) res)) + (setf (window-spare-lines window) res))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/winimage.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/winimage.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/winimage.lisp (revision 8058) @@ -0,0 +1,327 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file contains implementation independant functions that +;;; build window images from the buffer structure. +;;; +(in-package :hemlock-internals) + +(defvar *the-sentinel* + (list (make-window-dis-line "")) + "This dis-line, which has several interesting properties, is used to end + lists of dis-lines.") +(setf (dis-line-line (car *the-sentinel*)) + (make-line :number most-positive-fixnum :chars "")) +(setf (dis-line-position (car *the-sentinel*)) most-positive-fixnum) +(setf (dis-line-old-chars (car *the-sentinel*)) :unique-thing) + + + + + +;;; move-lines -- Internal +;;; +;;; This function is called by Maybe-Change-Window when it believes that +;;; a line needs to be inserted or deleted. When called it finishes the +;;; image-update for the entire rest of the window. Here and many other +;;; places the phrase "dis-line" is often used to mean a pointer into the +;;; window's list of dis-lines. +;;; +;;; Window - The window whose image needs to be updated. +;;; Changed - True if the first-changed line has already been set, if false +;;; we must set it. +;;; String - The overhang string to be added to the beginning of the first +;;; line image we build. If no overhang then this is NIL. +;;; Underhang - The number of trailing chars of String to use. +;;; Line - The line at which we are to continue building the image. This +;;; may be NIL, in which case we are at the end of the buffer. +;;; Offset - The charpos within Line to continue at. +;;; Current - The dis-line which caused Maybe-Change-Window to choke; it +;;; may be *the-sentinel*, it may not be the dummy line at head of the +;;; window's dis-lines. This is the dis-line at which Maybe-Change-Window +;;; turns over control, it should not be one whose image it built. +;;; Trail - This is the dis-line which immediately precedes Current in the +;;; dis-line list. It may be the dummy dis-line, it may not be the sentinel. +;;; Width - (window-width window) +(defun move-lines (window changed string underhang line offset trail current + width) + + (do* ((delta 0) + (cc (car current)) + (old-line (dis-line-line cc)) + ;; Can't use current, since might be *the-sentinel*. + (pos (1+ (dis-line-position (car trail)))) + ;; Are we on an extension line? + (is-wrapped (eq line (dis-line-line (car trail)))) + (last (window-last-line window)) + (last-line (dis-line-line (car last))) + (save trail) + (height (window-height window)) + (spare-lines (window-spare-lines window)) + ;; Make *the-sentinel* in this buffer so we don't delete it. + (buffer (setf (line-%buffer (dis-line-line (car *the-sentinel*))) + (window-buffer window))) + (start offset) new-num) + ((or (= pos height) (null line)) + ;; If we have run off the bottom or run out of lines then we are + ;; done. At this point Trail is the last line displayed and Current is + ;; whatever comes after it, possibly *the-sentinel*. + ;; We always say that last-changed is the last line so that we + ;; don't have to max in the old last-changed. + (setf (window-last-changed window) trail) + ;; If there are extra lines at the end that need to be deleted + ;; and haven't been already then link them into the free-list. + (unless (eq last trail) + ;; This test works, because if the old last line was either + ;; deleted or another line was inserted after it then it's + ;; cdr would be something else. + (when (eq (cdr last) *the-sentinel*) + (shiftf (cdr last) spare-lines (cdr trail) *the-sentinel*)) + (setf (window-last-line window) trail)) + (setf (window-spare-lines window) spare-lines) + ;; If first-changed has not been set then we set the first-changed + ;; to the first line we looked at if it does not come after the + ;; new position of the old first-changed. + (unless changed + (when (> (dis-line-position (car (window-first-changed window))) + (dis-line-position (car save))) + (setf (window-first-changed window) (cdr save))))) + + (setq new-num (line-number line)) + ;; If a line has been deleted, it's line-%buffer is smashed; we unlink + ;; any dis-line which displayed such a line. + (cond + ((neq (line-%buffer old-line) buffer) + (do ((ptr (cdr current) (cdr ptr)) + (prev current ptr)) + ((eq (line-%buffer (dis-line-line (car ptr))) buffer) + (setq delta (- pos (1+ (dis-line-position (car prev))))) + (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) + (setq cc (car current) old-line (dis-line-line cc))) + ;; If the line-number of the old line is less than the line-number + ;; of the line we want to display then the old line must be off the top + ;; of the screen - delete it. *The-Sentinel* fails this test because + ;; it's line-number is most-positive-fixnum. + ((< (line-number old-line) new-num) + (do ((ptr (cdr current) (cdr ptr)) + (prev current ptr)) + ((>= (line-number (dis-line-line (car ptr))) new-num) + (setq delta (- pos (1+ (dis-line-position (car prev))))) + (shiftf (cdr trail) (cdr prev) spare-lines current ptr))) + (setq cc (car current) old-line (dis-line-line cc))) + ;; New line comes before old line, insert it, punting when + ;; we hit the bottom of the screen. + ((neq line old-line) + (do ((chars (unless is-wrapped (line-%chars line)) nil) new) + (()) + (setq new (car spare-lines)) + (setf (dis-line-old-chars new) chars + (dis-line-position new) pos + (dis-line-line new) line + (dis-line-delta new) 0 + (dis-line-flags new) new-bit) + (setq pos (1+ pos) delta (1+ delta)) + (multiple-value-setq (string underhang start) + (compute-line-image string underhang line start new width)) + (rotatef (cdr trail) spare-lines (cdr spare-lines)) + (setq trail (cdr trail)) + (cond ((= pos height) + (return nil)) + ((null underhang) + (setq start 0 line (line-next line)) + (return nil)))) + (setq is-wrapped nil)) + ;; The line is the same, possibly moved. We add in the delta and + ;; or in the moved bit so that if redisplay punts in the middle + ;; the information is not lost. + ((eq (line-%chars line) (dis-line-old-chars cc)) + ;; If the line is the old bottom line on the screen and it has moved and + ;; is full length, then mash the old-chars and quit so that the image + ;; will be recomputed the next time around the loop, since the line might + ;; have been wrapped off the bottom of the screen. + (cond + ((and (eq line last-line) + (= (dis-line-length cc) width) + (not (zerop delta))) + (setf (dis-line-old-chars cc) :another-unique-thing)) + (t + (do () + ((= pos height)) + (unless (zerop delta) + (setf (dis-line-position cc) pos) + (incf (dis-line-delta cc) delta) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) + (shiftf trail current (cdr current)) + (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) + (when (not (eq old-line line)) + (setq start 0 line (line-next line)) + (return nil)))))) + ;; The line is changed, possibly moved. + (t + (do ((chars (line-%chars line) nil)) + (()) + (multiple-value-setq (string underhang start) + (compute-line-image string underhang line start cc width)) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit) + (dis-line-old-chars cc) chars + (dis-line-position cc) pos) + (unless (zerop delta) + (incf (dis-line-delta cc) delta) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit))) + (shiftf trail current (cdr current)) + (setq cc (car current) old-line (dis-line-line cc) pos (1+ pos)) + (cond ((= pos height) + (return nil)) + ((null underhang) + (setq start 0 line (line-next line)) + (return nil)) + ((not (eq old-line line)) + (setq is-wrapped t) + (return nil)))))))) + + + +;;; maybe-change-window -- Internal +;;; +;;; This macro is "Called" in update-window-image whenever it finds that +;;; the chars of the line and the dis-line don't match. This may happen for +;;; several reasons: +;;; +;;; 1] The previous line was unchanged, but wrapped, so the dis-line-chars +;;; are nil. In this case we just skip over the extension lines. +;;; +;;; 2] A line is changed but not moved; update the line noting whether the +;;; next line is moved because of this, and bugging out to Move-Lines if +;;; it is. +;;; +;;; 3] A line is deleted, off the top of the screen, or moved. Bug out +;;; to Move-Lines. +;;; +;;; There are two possible results, either we return NIL, and Line, +;;; Trail and Current are updated, or we return T, in which case +;;; Update-Window-Image should terminate immediately. Changed is true +;;; if a changed line changed lines has been found. +;;; +(eval-when (:compile-toplevel :execute) +(defmacro maybe-change-window (window changed line offset trail current width) + `(let* ((cc (car ,current)) + (old-line (dis-line-line cc))) + (cond + ;; We have run into a continuation line, skip over any. + ((and (null (dis-line-old-chars cc)) + (eq old-line (dis-line-line (car ,trail)))) + (do ((ptr (cdr ,current) (cdr ptr)) + (prev ,current ptr)) + ((not (eq (dis-line-line (car ptr)) old-line)) + (setq ,trail prev ,current ptr) nil))) + ;; A line is changed. + ((eq old-line ,line) + (unless ,changed + (when (< (dis-line-position cc) + (dis-line-position (car (window-first-changed ,window)))) + (setf (window-first-changed ,window) ,current) + (setq ,changed t))) + (do ((chars (line-%chars ,line) nil) + (start ,offset) string underhang) + (()) + (multiple-value-setq (string underhang start) + (compute-line-image string underhang ,line start cc ,width)) + (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit)) + (setf (dis-line-old-chars cc) chars) + (setq ,trail ,current ,current (cdr ,current) cc (car ,current)) + (cond + ((eq (dis-line-line cc) ,line) + (unless underhang + (move-lines ,window t nil 0 (line-next ,line) 0 ,trail ,current + ,width) + (return t))) + (underhang + (move-lines ,window t string underhang ,line start ,trail + ,current ,width) + (return t)) + (t + (setq ,line (line-next ,line)) + (when (> (dis-line-position (car ,trail)) + (dis-line-position (car (window-last-changed ,window)))) + (setf (window-last-changed ,window) ,trail)) + (return nil))))) + (t + (move-lines ,window ,changed nil 0 ,line ,offset ,trail ,current + ,width) + t)))) +); eval-when + + +;;; update-window-image -- Internal +;;; +;;; This is the function which redisplay calls when it wants to ensure that +;;; a window-image is up-to-date. The main loop here is just to zoom through +;;; the lines and dis-lines, bugging out to Maybe-Change-Window whenever +;;; something interesting happens. +;;; +(defun update-window-image (window) + (let* ((trail (window-first-line window)) + (current (cdr trail)) + (display-start (window-display-start window)) + (line (mark-line display-start)) + (width (window-width window)) changed) + (cond + ;; If the first line or its charpos has changed then bug out. + ((cond ((and (eq (dis-line-old-chars (car current)) (line-%chars line)) + (mark= display-start (window-old-start window))) + (setq trail current current (cdr current) line (line-next line)) + nil) + (t + ;; Force the line image to be invalid in case the start moved + ;; and the line wrapped onto the screen. If we started at the + ;; beginning of the line then we don't need to. + (unless (zerop (mark-charpos (window-old-start window))) + (unless (eq current *the-sentinel*) + (setf (dis-line-old-chars (car current)) :another-unique-thing))) + (let ((start-charpos (mark-charpos display-start))) + (move-mark (window-old-start window) display-start) + (maybe-change-window window changed line start-charpos + trail current width))))) + (t + (prog () + (go TOP) + STEP + (setf (dis-line-line (car current)) line) + (setq trail current current (cdr current) line (line-next line)) + TOP + (cond ((null line) + (go DONE)) + ((eq (line-%chars line) (dis-line-old-chars (car current))) + (go STEP))) + ;; + ;; We found a suspect line. + ;; See if anything needs to be updated, if we bugged out, punt. + (when (and (eq current *the-sentinel*) + (= (dis-line-position (car trail)) + (1- (window-height window)))) + (return nil)) + (when (maybe-change-window window changed line 0 trail current width) + (return nil)) + (go TOP) + + DONE + ;; + ;; We hit the end of the buffer. If lines need to be deleted bug out. + (unless (eq current *the-sentinel*) + (maybe-change-window window changed line 0 trail current width)) + (return nil)))) + ;; + ;; Update the display-end mark. + (let ((dl (car (window-last-line window)))) + (move-to-position (window-display-end window) (dis-line-end dl) + (dis-line-line dl))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/Notes =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/Notes (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/Notes (revision 8058) @@ -0,0 +1,21 @@ +Wire was using its own buffer management -- how useful. We did away +with that an read/write directly from an binary stream for now. + +TODO + +- actually switch to binary streams +- invent something for strings (say define it as unicode or something) + +- can we do a reasonable attempt to make symbol lookup work across + lisp implementations? + +- can we make this at least somewhat work with CLISP? + +- conditions. + +- Do away with superfluous large macros + +- Can we again do with a serve event kind of interface for poor Lisp + which do not feature multiprocessing (like say CLISP)? + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/package.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/package.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/package.lisp (revision 8058) @@ -0,0 +1,40 @@ +(defpackage :hemlock.wire + (:use :common-lisp) + (:nicknames :wire) + (:export + ;; wire.lisp + #:remote-object-p + #:remote-object + #:remote-object-local-p + #:remote-object-eq + #:remote-object-value + #:make-remote-object + #:forget-remote-translation + #:make-wire + #:wire-p + #:wire-fd + #:wire-listen + #:wire-get-byte + #:wire-get-number + #:wire-get-string + #:wire-get-object + #:wire-force-output + #:wire-output-byte + #:wire-output-number + #:wire-output-string + #:wire-output-object + #:wire-output-funcall + #:wire-error + #:wire-eof + #:wire-io-error + #:*current-wire* + #:wire-get-bignum + #:wire-output-bignum + ;; remote.lisp + #:remote + #:remote-value + #:remote-value-bind + #:create-request-server + #:destroy-request-server + #:connect-to-remote-server)) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/port.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/port.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/port.lisp (revision 8058) @@ -0,0 +1,182 @@ +(defpackage :hemlock.wire + (:use :common-lisp)) + +(in-package :hemlock.wire) + +(defun ext-create-inet-listener (port) + #+CMU + (ext:create-inet-listener port) + #+EXCL + (socket:make-socket :connect :passive + :local-port port + :format :text) + #+CLISP + (socket:socket-server port) + #+SBCL + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol (sb-bsd-sockets:get-protocol-by-name "tcp")))) + (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port) + (sb-bsd-sockets:socket-listen socket 2) + socket) + #-(OR CMU EXCL CLISP SBCL) + #.(error "Configure")) + +(defun ext-accept-tcp-connection (socket) + #+CMU (ext:accept-tcp-connection socket) + #+EXCL + (values + (socket:accept-connection socket :wait t) + (socket:remote-host socket)) + #+CLISP + (let ((stream (socket:socket-accept socket))) + #+NIL (setf (stream-element-type stream) '(unsigned-byte 8)) + (values + stream + (multiple-value-list (socket:socket-stream-peer stream)))) + #+SBCL + (multiple-value-bind (socket peer-host peer-port) + (sb-bsd-sockets:socket-accept socket) + (values (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t) + peer-host)) + #-(OR CMU EXCL CLISP SBCL) + #.(error "Configure") + ) + +(defun ext-connect-to-inet-socket (host port) + #+CMU (ext:connect-to-inet-socket host port) + #+EXCL + (progn + #+(and allegro-version>= (version>= 5)) + (socket:make-socket :remote-host host + :remote-port port + :format :text) + #-(and allegro-version>= (version>= 5)) + (ipc:open-network-stream + :host host :port port + :element-type 'character + ;; :class EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM + )) + #+SBCL + (sb-bsd-sockets:socket-make-stream + (let ((host (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name host))))) + (when host + (let ((s (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect s host port) + s))) + :element-type 'character ;(unsigned-byte 8) + :input t :output t) + #+CLISP + (socket:socket-connect port host) + #-(OR CMU EXCL CLISP SBCL) + #.(error "Configure")) + +(defun ext-close-socket (socket) + #+CMU (ext:close-socket socket) + #+EXCL (close socket) + #+CLISP (socket:socket-server-close socket) + #+SBCL (sb-bsd-sockets:socket-close socket) + #-(OR CMU EXCL CLISP SBCL) + #.(error "Configure")) + +(defun ext-close-connection (connection) + #+CMU (ext:close-socket connection) + #+EXCL (close connection) + #+CLISP (close connection) + #+SBCL (close connection) + #-(OR CMU EXCL CLISP SBCL) + #.(error "Configure")) + +(defun unix-gethostid () + #.(or + #+CMU '(unix:unix-gethostid) + 398792)) + +(defun unix-getpid () + #.(or + #+CMU '(unix:unix-getpid) + #+SBCL '(sb-unix:unix-getpid) + #+ACL '(excl::getpid) + #+CLISP '(system::program-id))) + +#+(OR CLISP) +(eval-when (compile load eval) + (pushnew :hemlock.serve-event *features*) ) + +#-:hemlock.serve-event +(defun make-process (function &key name) + #+CMU (mp:make-process function :name name) + #+EXCL (mp:process-run-function name function) + #+SBCL (sb-thread:make-thread function) + #-(OR CMU EXCL SBCL) + #.(error "Configure")) + +#+:hemlock.serve-event +(progn + + (defstruct handler + predicate + function) + + (defvar *event-handlers* nil) + + ;; Sigh. CLISP barfs on (typep (ext-create-inet-listener 8981) 'SOCKET:SOCKET-SERVER) + ;; Bad! + + (defun add-fd-handler (fd direction handler-function) + (let (handler) + (setf handler + (make-handler + :predicate + (cond ((eql 'socket:socket-server + (type-of fd)) + (lambda () (socket:socket-wait fd 0))) + ((typep fd 'xlib:display) + (lambda () + (xlib:display-force-output fd) + (xlib:event-listen fd))) + (t + (lambda () + (cond ((open-stream-p fd) + (let ((c (read-char-no-hang fd nil :eof))) + #+NIL (progn (print `(read-char-no-hang ,fd -> ,c)) (finish-output)) + (if (characterp c) (unread-char c fd)) + c)) + (t + (setf *event-handlers* (delete handler *event-handlers*)) + nil))))) + :function + (lambda () (funcall handler-function fd)))) + (push handler *event-handlers*) + handler)) + + (defun remove-fd-handler (handler) + (setf *event-handlers* + (delete handler *event-handlers*))) + + (defun serve-all-events () + (loop + (let ((handler (find-if #'funcall *event-handlers* :key #'handler-predicate))) + (cond (handler + (funcall (handler-function handler)) + (return)) + (t + (sleep .01)))))) + + (defun serve-event (&optional timeout) + (let ((waited 0)) + (loop + (let ((handler (find-if #'funcall *event-handlers* :key #'handler-predicate))) + (cond (handler + (funcall (handler-function handler)) + (return t)) + ((>= waited timeout) + (return nil)) + (t + (incf waited .01) + (sleep .01))))))) + ) + +||# Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/remote.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/remote.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/remote.lisp (revision 8058) @@ -0,0 +1,403 @@ +;;; -*- Log: code.log; Package: wire -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+NIL +(ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file implements a simple remote procedure call mechanism on top +;;; of wire.lisp. +;;; +;;; Written by William Lott. +;;; + +(defpackage :hemlock.wire + (:use :common-lisp)) + +(in-package :hemlock.wire) + +(defstruct remote-wait + value1 value2 value3 value4 value5 + abort + finished) + +(defvar *pending-returns* nil + "AList of wire . remote-wait structs") + +;;; MAYBE-NUKE-REMOTE-WAIT -- internal +;;; +;;; If the remote wait has finished, remove the external translation. +;;; Otherwise, mark the remote wait as finished so the next call to +;;; MAYBE-NUKE-REMOTE-WAIT will really nuke it. +;;; +(defun maybe-nuke-remote-wait (remote) + (cond ((remote-wait-finished remote) + (forget-remote-translation remote) + t) + (t + (setf (remote-wait-finished remote) + t) + nil))) + +;;; REMOTE -- public +;;; +;;; Execute the body remotly. Subforms are executed locally in the lexical +;;; envionment of the macro call. No values are returned. +;;; +(defmacro remote (wire-form &body forms) + "Evaluates the given forms remotly. No values are returned, as the remote +evaluation is asyncronus." + (let ((wire (gensym))) + `(let ((,wire ,wire-form)) + ,@(mapcar #'(lambda (form) + `(wire-output-funcall ,wire + ',(car form) + ,@(cdr form))) + forms) + (values)))) + +;;; REMOTE-VALUE-BIND -- public +;;; +;;; Send to remote forms. First, a call to the correct dispatch routine based +;;; on the number of args, then the actual call. The dispatch routine will get +;;; the second funcall and fill in the correct number of arguments. +;;; Note: if there are no arguments, we don't even wait for the function to +;;; return, cause we can kind of guess at what the currect results would be. +;;; +(defmacro remote-value-bind (wire-form vars form &rest body) + "Bind vars to the multiple values of form (which is executed remotly). The +forms in body are only executed if the remote function returned as apposed +to aborting due to a throw." + (cond + ((null vars) + `(progn + (remote ,wire-form ,form) + ,@body)) + (t + (let ((remote (gensym)) + (wire (gensym))) + `(let* ((,remote (make-remote-wait)) + (,wire ,wire-form) + (*pending-returns* (cons (cons ,wire ,remote) + *pending-returns*))) + (unwind-protect + (let ,vars + (remote ,wire + (,(case (length vars) + (1 'do-1-value-call) + (2 'do-2-value-call) + (3 'do-3-value-call) + (4 'do-4-value-call) + (5 'do-5-value-call) + (t 'do-n-value-call)) + (make-remote-object ,remote)) + ,form) + (wire-force-output ,wire) + (loop + #+:hemlock.serve-event + (serve-all-events) + #-:hemlock.serve-event + (wire-get-object ,wire) + (when (remote-wait-finished ,remote) + (return))) + (unless (remote-wait-abort ,remote) + ,(case (length vars) + (1 `(setf ,(first vars) (remote-wait-value1 ,remote))) + (2 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote))) + (3 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote) + ,(third vars) (remote-wait-value3 ,remote))) + (4 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote) + ,(third vars) (remote-wait-value3 ,remote) + ,(fourth vars) (remote-wait-value4 ,remote))) + (5 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote) + ,(third vars) (remote-wait-value3 ,remote) + ,(fourth vars) (remote-wait-value4 ,remote) + ,(fifth vars) (remote-wait-value5 ,remote))) + (t + (do ((remaining-vars vars (cdr remaining-vars)) + (form (list 'setf) + (nconc form + (list (car remaining-vars) + `(pop values))))) + ((null remaining-vars) + `(let ((values (remote-wait-value1 ,remote))) + ,form))))) + ,@body)) + (maybe-nuke-remote-wait ,remote))))))) + + +;;; REMOTE-VALUE -- public +;;; +;;; Alternate interface to getting the single return value of a remote +;;; function. Works pretty much just the same, except the single value is +;;; returned. +;;; +(defmacro remote-value (wire-form form &optional + (on-server-unwind + `(error "Remote server unwound"))) + "Execute the single form remotly. The value of the form is returned. + The optional form on-server-unwind is only evaluated if the server unwinds + instead of returning." + (let ((remote (gensym)) + (wire (gensym))) + `(let* ((,remote (make-remote-wait)) + (,wire ,wire-form) + (*pending-returns* (cons (cons ,wire ,remote) + *pending-returns*))) + (unwind-protect + (progn + (remote ,wire + (do-1-value-call (make-remote-object ,remote)) + ,form) + (wire-force-output ,wire) + (loop + #+:hemlock.serve-event + (serve-all-events) + #-:hemlock.serve-event + (wire-get-object ,wire) + (when (remote-wait-finished ,remote) + (return)))) + (maybe-nuke-remote-wait ,remote)) + (if (remote-wait-abort ,remote) + ,on-server-unwind + (remote-wait-value1 ,remote))))) + +;;; DEFINE-FUNCTIONS -- internal +;;; +;;; Defines two functions, one that the client runs in the server, and one +;;; that the server runs in the client: +;;; +;;; DO-n-VALUE-CALL -- internal +;;; +;;; Executed by the remote process. Reads the next object off the wire and +;;; sends the value back. Unwind-protect is used to make sure we send something +;;; back so the requestor doesn't hang. +;;; +;;; RETURN-n-VALUE -- internal +;;; +;;; The remote procedure returned the given value, so fill it in the +;;; remote-wait structure. Note, if the requestor has aborted, just throw +;;; the value away. +;;; +(defmacro define-functions (values) + (let ((do-call (intern (format nil "~:@(do-~D-value-call~)" values))) + (return-values (intern (format nil "~:@(return-~D-value~:P~)" values))) + (vars nil)) + (dotimes (i values) + (push (gensym) vars)) + (setf vars (nreverse vars)) + `(progn + (defun ,do-call (result) + (let (worked ,@vars) + (unwind-protect + (progn + (multiple-value-setq ,vars + (wire-get-object *current-wire*)) + (setf worked t)) + (if worked + (remote *current-wire* + (,return-values result ,@vars)) + (remote *current-wire* + (remote-return-abort result))) + (wire-force-output *current-wire*)))) + (defun ,return-values (remote ,@vars) + (let ((result (remote-object-value remote))) + (unless (maybe-nuke-remote-wait result) + ,@(let ((setf-forms nil)) + (dotimes (i values) + (push `(setf (,(intern (format nil + "~:@(remote-wait-value~D~)" + (1+ i))) + result) + ,(nth i vars)) + setf-forms)) + (nreverse setf-forms)))) + nil)))) + +(define-functions 1) +(define-functions 2) +(define-functions 3) +(define-functions 4) +(define-functions 5) + + +;;; DO-N-VALUE-CALL -- internal +;;; +;;; For more values then 5, all the values are rolled into a list and passed +;;; back as the first value, so we use RETURN-1-VALUE to return it. +;;; +(defun do-n-value-call (result) + (let (worked values) + (unwind-protect + (progn + (setf values + (multiple-value-list (wire-get-object *current-wire*))) + (setf worked t)) + (if worked + (remote *current-wire* + (return-1-values result values)) + (remote *current-wire* + (remote-return-abort result))) + (wire-force-output *current-wire*)))) + +;;; REMOTE-RETURN-ABORT -- internal +;;; +;;; The remote call aborted instead of returned. +;;; +(defun remote-return-abort (result) + (setf result (remote-object-value result)) + (unless (maybe-nuke-remote-wait result) + (setf (remote-wait-abort result) t))) + +#+:hemlock.serve-event +;;; SERVE-REQUESTS -- internal +;;; +;;; Serve all pending requests on the given wire. +;;; +(defun serve-requests (wire on-death) + (handler-bind + ((wire-eof #'(lambda (condition) + (declare (ignore condition)) + (close (wire-stream wire)) + #+NILGB(system:invalidate-descriptor (wire-fd wire)) + #+NILGB(unix:unix-close (wire-fd wire)) + (dolist (pending *pending-returns*) + (when (eq (car pending) + wire) + (unless (maybe-nuke-remote-wait (cdr pending)) + (setf (remote-wait-abort (cdr pending)) + t)))) + (when on-death + (funcall on-death)) + (return-from serve-requests (values)))) + (wire-error #'(lambda (condition) + (declare (ignore condition)) + #+NILGB + (system:invalidate-descriptor (wire-fd wire))))) + (progn #+NILGB loop + #+NILGB + (unless (wire-listen wire) + (return)) + (wire-get-object wire))) + (values)) + +;;; NEW-CONNECTION -- internal +;;; +;;; Maybe build a new wire and add it to the servers list of fds. If the user +;;; Supplied a function, close the socket if it returns NIL. Otherwise, install +;;; the wire. +;;; +(defun new-connection (socket addr on-connect) + (let ((wire (make-wire socket)) + (on-death nil)) + (if (or (null on-connect) + (multiple-value-bind (okay death-fn) + (funcall on-connect wire addr) + (setf on-death death-fn) + okay)) + #+:hemlock.serve-event + (add-fd-handler socket :input + #'(lambda (socket) + (declare (ignore socket)) + (serve-requests wire on-death))) + #-:hemlock.serve-event + (make-process (lambda () + (loop (wire-get-object wire))) + :name (format nil "Wire process for ~S." wire)) + (ext-close-connection socket)))) + +;;; REQUEST-SERVER structure +;;; +;;; Just a simple handle on the socket and system:serve-event handler that make +;;; up a request server. +;;; +(defstruct (request-server + (:print-function %print-request-server)) + socket + handler) + +(defun %print-request-server (rs stream depth) + (declare (ignore depth)) + (print-unreadable-object (rs stream :type t) + (format stream "for ~D" (request-server-socket rs)))) + +;;; CREATE-REQUEST-SERVER -- Public. +;;; +;;; Create a TCP/IP listener on the given port. If anyone tries to connect to +;;; it, call NEW-CONNECTION to do the connecting. +;;; +#+:hemlock.serve-event +(defun create-request-server (port &optional on-connect) + "Create a request server on the given port. Whenever anyone connects to it, + call the given function with the newly created wire and the address of the + connector. If the function returns NIL, the connection is destroyed; + otherwise, it is accepted. This returns a manifestation of the server that + DESTROY-REQUEST-SERVER accepts to kill the request server." + (let* ((socket (ext-create-inet-listener port)) + (handler (add-fd-handler socket :input + #'(lambda (socket) + (multiple-value-bind + (newconn addr) + (ext-accept-tcp-connection socket) + (new-connection newconn addr on-connect)))))) + (make-request-server :socket socket + :handler handler))) + +#-:hemlock.serve-event +(defun create-request-server (port &optional on-connect) + "Create a request server on the given port. Whenever anyone connects to it, + call the given function with the newly created wire and the address of the + connector. If the function returns NIL, the connection is destroyed; + otherwise, it is accepted. This returns a manifestation of the server that + DESTROY-REQUEST-SERVER accepts to kill the request server." + (let* ((socket (ext-create-inet-listener port)) + (handler (make-process + (lambda () + (loop + (multiple-value-bind + (newconn addr) + (ext-accept-tcp-connection socket) + (new-connection newconn addr on-connect))))))) + (make-request-server :socket socket + :handler handler))) + +;;; DESTROY-REQUEST-SERVER -- Public. +;;; +;;; Removes the request server from SERVER's list of file descriptors and +;;; closes the socket behind it. +;;; +(defun destroy-request-server (server) + "Quit accepting connections to the given request server." + #+:hemlock.serve-event + (remove-fd-handler (request-server-handler server)) + ;; + (ext-close-socket (request-server-socket server)) + nil) + +;;; CONNECT-TO-REMOTE-SERVER -- Public. +;;; +;;; Just like the doc string says, connect to a remote server. A handler is +;;; installed to handle return values, etc. +;;; +#-NIL +(defun connect-to-remote-server (hostname port &optional on-death) + "Connect to a remote request server addressed with the given host and port + pair. This returns the created wire." + (let* ((socket (ext-connect-to-inet-socket hostname port)) + (wire (make-wire socket))) + #+:hemlock.serve-event + ;; hmm, what exactly should this accomplish? + (add-fd-handler socket :input + #'(lambda (socket) + (declare (ignore socket)) + (serve-requests wire on-death))) + wire)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/wire.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/wire.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/wire/wire.lisp (revision 8058) @@ -0,0 +1,563 @@ +;;; -*- Log: code.log; Package: wire -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+NIL +(ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains an interface to internet domain sockets. +;;; +;;; Written by William Lott. +;;; + +(defpackage :hemlock.wire + (:use :common-lisp) + (:nicknames :wire) + (:export + ;; wire.lisp + #:remote-object-p + #:remote-object + #:remote-object-local-p + #:remote-object-eq + #:remote-object-value + #:make-remote-object + #:forget-remote-translation + #:make-wire + #:wire-p + #:wire-fd + #:wire-listen + #:wire-get-byte + #:wire-get-number + #:wire-get-string + #:wire-get-object + #:wire-force-output + #:wire-output-byte + #:wire-output-number + #:wire-output-string + #:wire-output-object + #:wire-output-funcall + #:wire-error + #:wire-eof + #:wire-io-error + #:*current-wire* + #:wire-get-bignum + #:wire-output-bignum + ;; remote.lisp + #:remote + #:remote-value + #:remote-value-bind + #:create-request-server + #:destroy-request-server + #:connect-to-remote-server)) + +(in-package :hemlock.wire) + +;;; Stuff that needs to be ported: + +(eval-when (compile load eval) ;For macros in remote.lisp. + +(defconstant buffer-size 2048) + +(defconstant initial-cache-size 16) + +(defconstant funcall0-op 0) +(defconstant funcall1-op 1) +(defconstant funcall2-op 2) +(defconstant funcall3-op 3) +(defconstant funcall4-op 4) +(defconstant funcall5-op 5) +(defconstant funcall-op 6) +(defconstant number-op 7) +(defconstant string-op 8) +(defconstant symbol-op 9) +(defconstant save-op 10) +(defconstant lookup-op 11) +(defconstant remote-op 12) +(defconstant cons-op 13) +(defconstant bignum-op 14) + +) ;eval-when + + +(defvar *current-wire* nil + "The wire the form we are currently evaluating came across.") + +(defvar *this-host* nil + "Unique identifier for this host.") +(defvar *this-pid* nil + "Unique identifier for this process.") + +(defvar *object-to-id* (make-hash-table :test 'eq) + "Hash table mapping local objects to the corresponding remote id.") +(defvar *id-to-object* (make-hash-table :test 'eql) + "Hash table mapping remote id's to the curresponding local object.") +(defvar *next-id* 0 + "Next available id for remote objects.") + + +(defstruct (wire + (:constructor make-wire (stream)) + (:print-function + (lambda (wire stream depth) + (declare (ignore depth)) + (format stream + "#" + (wire-stream wire))))) + stream + (object-cache (make-array initial-cache-size)) + (cache-index 0) + (object-hash (make-hash-table :test 'eq))) + +(defstruct (remote-object + (:constructor %make-remote-object (host pid id)) + (:print-function + (lambda (obj stream depth) + (declare (ignore depth)) + (format stream "#" + (remote-object-host obj) + (remote-object-pid obj) + (remote-object-id obj))))) + host + pid + id) + +(define-condition wire-error (error) + ((wire :reader wire-error-wire :initarg :wire)) + (:report (lambda (condition stream) + (format stream "There is a problem with ~A." + (wire-error-wire condition))))) + +(define-condition wire-eof (wire-error) + () + (:report (lambda (condition stream) + (format stream "Recieved EOF on ~A." + (wire-error-wire condition))))) + +(define-condition wire-io-error (wire-error) + ((when :reader wire-io-error-when :initarg :when :initform "using") + (msg :reader wire-io-error-msg :initarg :msg :initform "Failed.")) + (:report (lambda (condition stream) + (format stream "Error ~A ~A: ~A." + (wire-io-error-when condition) + (wire-error-wire condition) + (wire-io-error-msg condition))))) + + + +;;; Remote Object Randomness + +;;; REMOTE-OBJECT-LOCAL-P -- public +;;; +;;; First, make sure the *this-host* and *this-pid* are set. Then test to +;;; see if the remote object's host and pid fields are *this-host* and +;;; *this-pid* + +(defun remote-object-local-p (remote) + "Returns T iff the given remote object is defined locally." + (declare (type remote-object remote)) + (unless *this-host* + (setf *this-host* (unix-gethostid)) + (setf *this-pid* (unix-getpid))) + (and (eql (remote-object-host remote) *this-host*) + (eql (remote-object-pid remote) *this-pid*))) + +;;; REMOTE-OBJECT-EQ -- public +;;; +;;; Remote objects are considered EQ if they refer to the same object, ie +;;; Their host, pid, and id fields are the same (eql, cause they are all +;;; numbers). + +(defun remote-object-eq (remote1 remote2) + "Returns T iff the two objects refer to the same (eq) object in the same + process." + (declare (type remote-object remote1 remote2)) + (and (eql (remote-object-host remote1) + (remote-object-host remote2)) + (eql (remote-object-pid remote1) + (remote-object-pid remote2)) + (eql (remote-object-id remote1) + (remote-object-id remote2)))) + +;;; REMOTE-OBJECT-VALUE --- public +;;; +;;; First assure that the remote object is defined locally. If so, look up +;;; the id in *id-to-objects*. +;;; table. This will only happen if FORGET-REMOTE-TRANSLATION has been called +;;; on the local object. + +(defun remote-object-value (remote) + "Return the associated value for the given remote object. It is an error if + the remote object was not created in this process or if + FORGET-REMOTE-TRANSLATION has been called on this remote object." + (declare (type remote-object remote)) + (unless (remote-object-local-p remote) + (error "~S is defined is a different process." remote)) + (multiple-value-bind + (value found) + (gethash (remote-object-id remote) + *id-to-object*) + (unless found + (cerror + "Use the value of NIL" + "No value for ~S -- FORGET-REMOTE-TRANSLATION was called to early." + remote)) + value)) + +;;; MAKE-REMOTE-OBJECT --- public +;;; +;;; Convert the given local object to a remote object. If the local object is +;;; alread entered in the *object-to-id* hash table, just use the old id. +;;; Otherwise, grab the next id and put add both mappings to the two hash +;;; tables. + +(defun make-remote-object (local) + "Convert the given local object to a remote object." + (unless *this-host* + (setf *this-host* (unix-gethostid)) + (setf *this-pid* (unix-getpid))) + (let ((id (gethash local *object-to-id*))) + (unless id + (setf id *next-id*) + (setf (gethash local *object-to-id*) id) + (setf (gethash id *id-to-object*) local) + (incf *next-id*)) + (%make-remote-object *this-host* *this-pid* id))) + +;;; FORGET-REMOTE-TRANSLATION -- public +;;; +;;; Remove any translation information about the given object. If there is +;;; currenlt no translation for the object, don't bother doing anything. +;;; Otherwise remove it from the *object-to-id* hashtable, and remove the id +;;; from the *id-to-object* hashtable. + +(defun forget-remote-translation (local) + "Forget the translation from the given local to the corresponding remote +object. Passing that remote object to remote-object-value will new return NIL." + (let ((id (gethash local *object-to-id*))) + (when id + (remhash local *object-to-id*) + (remhash id *id-to-object*))) + (values)) + + + +;;; Wire input routeins. + +;;; WIRE-LISTEN -- public +;;; +;;; If nothing is in the current input buffer, select on the file descriptor. + +(defun wire-listen (wire) + "Return T iff anything is in the input buffer or available on the socket." + (or + (listen (wire-stream wire)))) + +;;; WIRE-GET-BYTE -- public +;;; +;;; Return the next byte. + +(defun wire-get-byte (wire) + "Return the next byte from the wire." + (let ((c (read-char (wire-stream wire) nil :eof))) + (cond ((eql c :eof) + (error 'wire-eof :wire wire)) + (t + (char-int c))))) + +;;; WIRE-GET-NUMBER -- public +;;; +;;; Just read four bytes and pack them together with normal math ops. + +(defun wire-get-number (wire &optional (signed t)) + "Read a number off the wire. Numbers are 4 bytes in network order. +The optional argument controls weather or not the number should be considered +signed (defaults to T)." + (let* ((b1 (wire-get-byte wire)) + (b2 (wire-get-byte wire)) + (b3 (wire-get-byte wire)) + (b4 (wire-get-byte wire)) + (unsigned + (+ b4 (* 256 (+ b3 (* 256 (+ b2 (* 256 b1)))))))) + (if (and signed (> b1 127)) + (logior (ash -1 32) unsigned) + unsigned))) + +;;; WIRE-GET-BIGNUM -- public +;;; +;;; Extracts a number, which might be a bignum. +;;; +(defun wire-get-bignum (wire) + "Reads an arbitrary integer sent by WIRE-OUTPUT-BIGNUM from the wire and + return it." + (let ((count-and-sign (wire-get-number wire))) + (do ((count (abs count-and-sign) (1- count)) + (result 0 (+ (ash result 32) (wire-get-number wire nil)))) + ((not (plusp count)) + (if (minusp count-and-sign) + (- result) + result))))) + +;;; WIRE-GET-STRING -- public +;;; +;;; Use WIRE-GET-NUMBER to read the length, and then read the string +;;; contents. + +(defun wire-get-string (wire) + "Reads a string from the wire. The first four bytes spec the size." + (let* ((length (wire-get-number wire)) + (result (make-string length))) + (declare (simple-string result) + (integer length)) + (read-sequence result (wire-stream wire)) + result)) + +;;; WIRE-GET-OBJECT -- public +;;; +;;; First, read a byte to determine the type of the object to read. Then, +;;; depending on the type, call WIRE-GET-NUMBER, WIRE-GET-STRING, or whatever +;;; to read the necessary data. Note, funcall objects are funcalled. + +(defun wire-get-object (wire) + "Reads the next object from the wire and returns it." + (let ((identifier (wire-get-byte wire)) + (*current-wire* wire)) + (declare (fixnum identifier)) + (cond ((eql identifier lookup-op) + (let ((index (wire-get-number wire)) + (cache (wire-object-cache wire))) + (declare (integer index)) + (declare (simple-vector cache)) + (when (< index (length cache)) + (svref cache index)))) + ((eql identifier number-op) + (wire-get-number wire)) + ((eql identifier bignum-op) + (wire-get-bignum wire)) + ((eql identifier string-op) + (wire-get-string wire)) + ((eql identifier symbol-op) + (let* ((symbol-name (wire-get-string wire)) + (package-name (wire-get-string wire)) + (package (find-package package-name))) + (unless package + (error "Attempt to read symbol, ~A, of wire into non-existent ~ + package, ~A." + symbol-name package-name)) + (intern symbol-name package))) + ((eql identifier cons-op) + (cons (wire-get-object wire) + (wire-get-object wire))) + ((eql identifier remote-op) + (let ((host (wire-get-number wire nil)) + (pid (wire-get-number wire)) + (id (wire-get-number wire))) + (%make-remote-object host pid id))) + ((eql identifier save-op) + (let ((index (wire-get-number wire)) + (cache (wire-object-cache wire))) + (declare (integer index)) + (declare (simple-vector cache)) + (when (>= index (length cache)) + (do ((newsize (* (length cache) 2) + (* newsize 2))) + ((< index newsize) + (let ((newcache (make-array newsize))) + (declare (simple-vector newcache)) + (replace newcache cache) + (setf cache newcache) + (setf (wire-object-cache wire) cache))))) + (setf (svref cache index) + (wire-get-object wire)))) + ((eql identifier funcall0-op) + (funcall (wire-get-object wire))) + ((eql identifier funcall1-op) + (funcall (wire-get-object wire) + (wire-get-object wire))) + ((eql identifier funcall2-op) + (funcall (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire))) + ((eql identifier funcall3-op) + (funcall (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire))) + ((eql identifier funcall4-op) + (funcall (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire))) + ((eql identifier funcall5-op) + (funcall (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire) + (wire-get-object wire))) + ((eql identifier funcall-op) + (let ((arg-count (wire-get-byte wire)) + (function (wire-get-object wire)) + (args '()) + (last-cons nil) + (this-cons nil)) + (loop + (when (zerop arg-count) + (return nil)) + (setf this-cons (cons (wire-get-object wire) + nil)) + (if (null last-cons) + (setf args this-cons) + (setf (cdr last-cons) this-cons)) + (setf last-cons this-cons) + (decf arg-count)) + (apply function args)))))) + + + +;;; Wire output routines. + +;;; WIRE-FORCE-OUTPUT -- internal +;;; +;;; Output any stuff remaining in the output buffer. + +(defun wire-force-output (wire) + "Send any info still in the output buffer down the wire and clear it. Nothing +harmfull will happen if called when the output buffer is empty." + (force-output (wire-stream wire)) + (values)) + +;;; WIRE-OUTPUT-BYTE -- public +;;; +;;; Stick the byte in the output buffer. If there is no space, flush the +;;; buffer using WIRE-FORCE-OUTPUT. + +(defun wire-output-byte (wire byte) + "Output the given (8-bit) byte on the wire." + (declare (integer byte)) + (write-char (code-char byte) (wire-stream wire)) + (values)) + +;;; WIRE-OUTPUT-NUMBER -- public +;;; +;;; Output the number. Note, we don't care if the number is signed or not, +;;; because we just crank out the low 32 bits. +;;; +(defun wire-output-number (wire number) + "Output the given (32-bit) number on the wire." + (declare (integer number)) + (wire-output-byte wire (+ 0 (ldb (byte 8 24) number))) + (wire-output-byte wire (ldb (byte 8 16) number)) + (wire-output-byte wire (ldb (byte 8 8) number)) + (wire-output-byte wire (ldb (byte 8 0) number)) + (values)) + +;;; WIRE-OUTPUT-BIGNUM -- public +;;; +;;; Output an arbitrary integer. +;;; +(defun wire-output-bignum (wire number) + "Outputs an arbitrary integer, but less effeciently than WIRE-OUTPUT-NUMBER." + (do ((digits 0 (1+ digits)) + (remaining (abs number) (ash remaining -32)) + (words nil (cons (ldb (byte 32 0) remaining) words))) + ((zerop remaining) + (wire-output-number wire + (if (minusp number) + (- digits) + digits)) + (dolist (word words) + (wire-output-number wire word))))) + +;;; WIRE-OUTPUT-STRING -- public +;;; +;;; Output the string. Strings are represented by the length as a number, +;;; followed by the bytes of the string. +;;; +(defun wire-output-string (wire string) + "Output the given string. First output the length using WIRE-OUTPUT-NUMBER, +then output the bytes." + (declare (simple-string string)) + (let ((length (length string))) + (declare (integer length)) + (wire-output-number wire length) + (write-sequence string (wire-stream wire))) + (values)) + +;;; WIRE-OUTPUT-OBJECT -- public +;;; +;;; Output the given object. If the optional argument is non-nil, cache +;;; the object to enhance the performance of sending it multiple times. +;;; Caching defaults to yes for symbols, and nil for everything else. + +(defun wire-output-object (wire object &optional (cache-it (symbolp object))) + "Output the given object on the given wire. If cache-it is T, enter this +object in the cache for future reference." + (let ((cache-index (gethash object + (wire-object-hash wire)))) + (cond + (cache-index + (wire-output-byte wire lookup-op) + (wire-output-number wire cache-index)) + (t + (when cache-it + (wire-output-byte wire save-op) + (let ((index (wire-cache-index wire))) + (wire-output-number wire index) + (setf (gethash object (wire-object-hash wire)) + index) + (setf (wire-cache-index wire) (1+ index)))) + (typecase object + (integer + (cond ((typep object '(signed-byte 32)) + (wire-output-byte wire number-op) + (wire-output-number wire object)) + (t + (wire-output-byte wire bignum-op) + (wire-output-bignum wire object)))) + (simple-string + (wire-output-byte wire string-op) + (wire-output-string wire object)) + (symbol + (wire-output-byte wire symbol-op) + (wire-output-string wire (symbol-name object)) + (wire-output-string wire (package-name (symbol-package object)))) + (cons + (wire-output-byte wire cons-op) + (wire-output-object wire (car object)) + (wire-output-object wire (cdr object))) + (remote-object + (wire-output-byte wire remote-op) + (wire-output-number wire (remote-object-host object)) + (wire-output-number wire (remote-object-pid object)) + (wire-output-number wire (remote-object-id object))) + (t + (error "Error: Cannot output objects of type ~s across a wire." + (type-of object))))))) + (values)) + +;;; WIRE-OUTPUT-FUNCALL -- public +;;; +;;; Send the funcall down the wire. Arguments are evaluated locally in the +;;; lexical environment of the WIRE-OUTPUT-FUNCALL. + +(defmacro wire-output-funcall (wire-form function &rest args) + "Send the function and args down the wire as a funcall." + (let ((num-args (length args)) + (wire (gensym))) + `(let ((,wire ,wire-form)) + ,@(if (> num-args 5) + `((wire-output-byte ,wire funcall-op) + (wire-output-byte ,wire ,num-args)) + `((wire-output-byte ,wire ,(+ funcall0-op num-args)))) + (wire-output-object ,wire ,function) + ,@(mapcar #'(lambda (arg) + `(wire-output-object ,wire ,arg)) + args) + (values)))) + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/xcoms.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/xcoms.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/archive/xcoms.lisp (revision 8058) @@ -0,0 +1,40 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains commands and support specifically for X related features. +;;; +;;; Written by Bill Chiles. +;;; + +(in-package :hemlock) + + +(defcommand "Region to Cut Buffer" (p) + "Place the current region into the X cut buffer." + "Place the current region into the X cut buffer." + (declare (ignore p)) + (store-cut-string (hi::bitmap-device-display + (hi::device-hunk-device (hi::window-hunk (current-window)))) + (region-to-string (current-region)))) + +(defcommand "Insert Cut Buffer" (p) + "Insert the X cut buffer at current point." + "Insert the X cut buffer at current point. Returns nil when it is empty." + (declare (ignore p)) + (let ((str (fetch-cut-string (hi::bitmap-device-display + (hi::device-hunk-device + (hi::window-hunk (current-window))))))) + (if str + (let ((point (current-point))) + (push-buffer-mark (copy-mark point)) + (insert-string (current-point) str)) + (editor-error "X cut buffer empty."))) + (setf (last-command-type) :ephemerally-active)) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/bit-stream.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/bit-stream.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/bit-stream.lisp (revision 8058) @@ -0,0 +1,147 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Some stuff to make streams that write out on bitmap hunks. +;;; +;;; Written by Rob MacLachlan. +;;; Modified by Bill Chiles to run under X on the IBM RT. +;;; +(in-package "HEMLOCK-INTERNALS") + + +;;; These streams have an associated bitmap-hunk that is used for its +;;; font-family, foreground and background color, and X window pointer. +;;; The hunk need not be associated with any Hemlock window, and the low +;;; level painting routines that use hunk dimensions are not used for +;;; output. Only BITMAP-HUNK-WRITE-STRING is used. The hunk is not +;;; registered for any event service, so resizing the associated X window +;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the +;;; hunk's input and changed handler slots are not set. +;;; +(defstruct (bitmap-hunk-output-stream (:include sys:lisp-stream + (out #'bitmap-hunk-out) + (sout #'bitmap-hunk-sout) + (misc #'bitmap-hunk-misc)) + (:constructor + make-bitmap-hunk-output-stream (hunk))) + hunk ; bitmap-hunk we display on. + (cursor-x 0) ; Character position of output cursor. + (cursor-y 0) + (buffer (make-string hunk-width-limit) :type simple-string) + (old-bottom 0)) ; # of lines of scrolling before next "--More--" prompt. + +;;; Bitmap-Hunk-Stream-Newline -- Internal +;;; +;;; Flush the stream's output buffer and then move the cursor down +;;; or scroll the window up if there is no room left. +;;; +(defun bitmap-hunk-stream-newline (stream) + (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) + (height (bitmap-hunk-char-height hunk)) + (y (bitmap-hunk-output-stream-cursor-y stream))) + (when (zerop (bitmap-hunk-output-stream-old-bottom stream)) + (hunk-write-string hunk 0 y "--More--" 0 8) + (let ((device (device-hunk-device hunk))) + (when (device-force-output device) + (funcall (device-force-output device)))) + (wait-for-more) + (hunk-clear-lines hunk y 1) + (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height))) + (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0 + (bitmap-hunk-output-stream-cursor-x stream)) + (setf (bitmap-hunk-output-stream-cursor-x stream) 0) + (decf (bitmap-hunk-output-stream-old-bottom stream)) + (incf y) + (when (= y height) + (decf y) + (hunk-copy-lines hunk 1 0 y) + (hunk-clear-lines hunk y 1)) + (setf (bitmap-hunk-output-stream-cursor-y stream) y))) + +;;; Bitmap-Hunk-Misc -- Internal +;;; +;;; This is the misc method for bitmap-hunk-output-streams. It just +;;; writes out the contents of the buffer, and does the element type. +;;; +(defun bitmap-hunk-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (values (bitmap-hunk-output-stream-cursor-x stream) + (bitmap-hunk-output-stream-cursor-y stream))) + ((:finish-output :force-output) + (hunk-write-string (bitmap-hunk-output-stream-hunk stream) + 0 (bitmap-hunk-output-stream-cursor-y stream) + (bitmap-hunk-output-stream-buffer stream) 0 + (bitmap-hunk-output-stream-cursor-x stream)) + (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream)))) + (when (device-force-output device) + (funcall (device-force-output device))))) + (:line-length + (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream))) + (:element-type 'base-char))) + + +;;; Bitmap-Hunk-Out -- Internal +;;; +;;; Throw a character in a bitmap-hunk-stream's buffer. If we wrap or hit a +;;; newline then call bitmap-hunk-stream-newline. +;;; +(defun bitmap-hunk-out (stream character) + (let ((hunk (bitmap-hunk-output-stream-hunk stream)) + (x (bitmap-hunk-output-stream-cursor-x stream))) + (cond ((char= character #\newline) + (bitmap-hunk-stream-newline stream) + (return-from bitmap-hunk-out nil)) + ((= x (bitmap-hunk-char-width hunk)) + (setq x 0) + (bitmap-hunk-stream-newline stream))) + (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character) + (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x)))) + + +;;; Bitmap-Hunk-Sout -- Internal +;;; +;;; Write a string out to a bitmap-hunk, calling ourself recursively if the +;;; string contains newlines. +;;; +(defun bitmap-hunk-sout (stream string start end) + (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) + (buffer (bitmap-hunk-output-stream-buffer stream)) + (x (bitmap-hunk-output-stream-cursor-x stream)) + (dst-end (+ x (- end start))) + (width (bitmap-hunk-char-width hunk))) + (cond ((%primitive find-character string start end #\newline) + (do ((current (%primitive find-character string start end #\newline) + (%primitive find-character string (1+ current) + end #\newline)) + (previous start (1+ current))) + ((null current) + (bitmap-hunk-sout stream string previous end)) + (bitmap-hunk-sout stream string previous current) + (bitmap-hunk-stream-newline stream))) + ((> dst-end width) + (let ((new-start (+ start (- width x)))) + (%primitive byte-blt string start buffer x width) + (setf (bitmap-hunk-output-stream-cursor-x stream) width) + (bitmap-hunk-stream-newline stream) + (do ((idx (+ new-start width) (+ idx width)) + (prev new-start idx)) + ((>= idx end) + (let ((dst-end (- end prev))) + (%primitive byte-blt string prev buffer 0 dst-end) + (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))) + (%primitive byte-blt string prev buffer 0 width) + (setf (bitmap-hunk-output-stream-cursor-x stream) width) + (bitmap-hunk-stream-newline stream)))) + (t + (%primitive byte-blt string start buffer x dst-end) + (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/clx-ext.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/clx-ext.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/clx-ext.lisp (revision 8058) @@ -0,0 +1,387 @@ +;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains code to extend CLX in the CMU Common Lisp environment. +;;; +;;; Written by Bill Chiles and Chris Hoover. +;;; + +(in-package "EXTENSIONS") + +(export '(open-clx-display with-clx-event-handling enable-clx-event-handling + disable-clx-event-handling object-set-event-handler + default-clx-event-handler + flush-display-events carefully-add-font-paths + + serve-key-press serve-key-release serve-button-press + serve-button-release serve-motion-notify serve-enter-notify + serve-leave-notify serve-focus-in serve-focus-out + serve-exposure serve-graphics-exposure serve-no-exposure + serve-visibility-notify serve-create-notify serve-destroy-notify + serve-unmap-notify serve-map-notify serve-map-request + serve-reparent-notify serve-configure-notify serve-gravity-notify + serve-resize-request serve-configure-request serve-circulate-notify + serve-circulate-request serve-property-notify serve-selection-clear + serve-selection-request serve-selection-notify serve-colormap-notify + serve-client-message)) + + + + +;;;; OPEN-CLX-DISPLAY. + +(defun open-clx-display (&optional (string (cdr (assoc :display + *environment-list* + :test #'eq)))) + "Parses a display specification including display and screen numbers. + This returns nil when there is no DISPLAY environment variable. If string + is non-nil, and any fields are missing in the specification, this signals an + error. If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN + to that screen since CLX initializes this form to the first of + XLIB:SCREEN-ROOTS. This returns the display and screen objects." + (when string + (let* ((string (coerce string 'simple-string)) + (length (length string)) + ;;pw-- "unix" is a signal to the connect_to_inet C code + ;; to open an AF_UNIX socket instead of an AF_INET one. + ;; This is supposed to be faster on a local server. + (host-name "unix") + (auth-name nil) + (auth-data nil) + (display-num nil) + (screen-num nil)) + (declare (simple-string string)) + (let ((colon (position #\: string :test #'char=))) + (cond ((null colon) + (error "Missing display number in DISPLAY environment variable.")) + (t + (unless (zerop colon) (setf host-name (subseq string 0 colon))) + (let* ((start (1+ colon)) + (first-dot (position #\. string + :test #'char= :start start))) + (cond ((= start (or first-dot length)) + (error "Badly formed display number in DISPLAY ~ + environment variable.")) + ((null first-dot) + (setf display-num (parse-integer string :start start))) + (t + (setf display-num (parse-integer string :start start + :end first-dot)) + (let* ((start (1+ first-dot)) + (second-dot (position #\. string :test #'char= + :start start))) + (cond ((= start (or second-dot length)) + (error "Badly formed screen number in ~ + DISPLAY environment variable.")) + (t + (setf screen-num + (parse-integer string :start start + :end second-dot))))))))))) + (if (equal host-name "unix") + (multiple-value-setq (auth-name auth-data) + (xlib::get-best-authorization (machine-instance) display-num :tcp))) + (let ((display (xlib:open-display host-name + :display display-num + :authorization-name auth-name + :authorization-data auth-data))) + (when screen-num + (let* ((screens (xlib:display-roots display)) + (num-screens (length screens))) + (when (>= screen-num num-screens) + (xlib:close-display display) + (error "No such screen number (~D)." screen-num)) + (setf (xlib:display-default-screen display) + (elt screens screen-num)))) + (values display (xlib:display-default-screen display)))))) + + + +;;;; Font Path Manipulation + +(defun carefully-add-font-paths (display font-pathnames + &optional (operation :append)) + "Adds the list of font pathnames, Font-Pathnames, to the font path of + the server Display but does so carefully by checking to make sure that + the font pathnames are not already on the server's font path. If any + of the font pathnames are on the server's font path, they will remain + in their current positions. Operation may be specified as either + :prepend or :append and specifies whether to add the additional font + pathnames to the beginning or the end of the server's original font + path." + (let ((font-path (xlib:font-path display)) + (result ())) + (dolist (elt font-pathnames) + (enumerate-search-list (pathname elt) + (lisp::enumerate-matches (name pathname) + (unless (member name font-path :test #'string=) + (push name result))))) + (when result + (ecase operation + (:prepend + (setf (xlib:font-path display) (revappend result font-path))) + (:append + (setf (xlib:font-path display) + (append font-path (nreverse result)))))))) + + + +;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT. + +(defvar *clx-fds-to-displays* (make-hash-table :test #'eql) + "This is a hash table that maps CLX file descriptors to CLX display + structures. For every CLX file descriptor know to SYSTEM:SERVE-EVENT, + there must be a mapping from that file descriptor to its CLX display + structure when events are handled via SYSTEM:SERVE-EVENT.") + +(defmacro with-clx-event-handling ((display handler) &rest body) + "Evaluates body in a context where events are handled for the display + by calling handler on the display. This destroys any previously established + handler for display." + `(unwind-protect + (progn + (enable-clx-event-handling ,display ,handler) + ,@body) + (disable-clx-event-handling ,display))) + +;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in +;;; *display-event-handlers*. It also uses SYSTEM:ADD-FD-HANDLER to have +;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows +;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a +;;; file descriptor, the file descriptor is also mapped to the display in +;;; *clx-fds-to-displays*, so the user's handler can be called on the display. +;;; +(defun enable-clx-event-handling (display handler) + "After calling this, when SYSTEM:SERVE-EVENT notices input on display's + connection to the X11 server, handler is called on the display. Handler + is invoked in a dynamic context with an error handler bound that will + flush all events from the display and return. By returning, it declines + to handle the error, but it will have cleared all events; thus, entering + the debugger will not result in infinite errors due to streams that wait + via SYSTEM:SERVE-EVENT for input. Calling this repeatedly on the same + display establishes handler as a new handler, replacing any previous one + for display." + (check-type display xlib:display) + (let ((change-handler (assoc display *display-event-handlers*))) + (if change-handler + (setf (cdr change-handler) handler) + (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) + (system:add-fd-handler fd :input #'call-display-event-handler) + (setf (gethash fd *clx-fds-to-displays*) display) + (push (cons display handler) *display-event-handlers*))))) + +;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps +;;; the display to its handler. If we can't find the display, we remove the +;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the +;;; display from *display-event-handlers*. This is necessary to try to keep +;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and +;;; over. This is possible since many CMU Common Lisp streams loop over +;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are +;;; possible. +;;; +(defun call-display-event-handler (file-descriptor) + (let ((display (gethash file-descriptor *clx-fds-to-displays*))) + (unless display + (system:invalidate-descriptor file-descriptor) + (setf *display-event-handlers* + (delete file-descriptor *display-event-handlers* + :key #'(lambda (d/h) + (fd-stream-fd + (xlib::display-input-stream + (car d/h)))))) + (error "File descriptor ~S not associated with any CLX display.~%~ + It has been removed from system:serve-event's knowledge." + file-descriptor)) + (let ((handler (cdr (assoc display *display-event-handlers*)))) + (unless handler + (flush-display-events display) + (error "Display ~S not associated with any event handler." display)) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (funcall handler display))))) + +(defun disable-clx-event-handling (display) + "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING." + (setf *display-event-handlers* + (delete display *display-event-handlers* :key #'car)) + (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) + (remhash fd *clx-fds-to-displays*) + (system:invalidate-descriptor fd))) + + + + +;;;; Object set event handling. + +;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear +;;; events on the display before signalling any errors. This is necessary +;;; since reading on certain CMU Common Lisp streams involves SERVER, and +;;; getting an error while trying to handle an event causes repeated attempts +;;; to handle the same event. +;;; +(defvar *process-clx-event-display* nil) + +(defvar *object-set-event-handler-print* nil) + +(declaim (declaration values)) + +(defun object-set-event-handler (display) + "This display event handler uses object sets to map event windows cross + event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots + of each event, calling the handlers on all these values in addition to + the event key and send-event-p. Describe EXT:SERVE-MUMBLE, where mumble + is an event keyword name for the exact order of arguments. + :mapping-notify and :keymap-notify events are ignored since they do not + occur on any particular window. After calling a handler, each branch + returns t to discard the event. While the handler is executing, all + errors go through a handler that flushes all the display's events and + returns. This prevents infinite errors since the debug and terminal + streams loop over SYSTEM:SERVE-EVENT. This function returns t if there + were some event to handle, nil otherwise. It returns immediately if + there is no event to handle." + (macrolet ((dispatch (event-key &rest args) + `(multiple-value-bind (object object-set) + (lisp::map-xwindow event-window) + (unless object + (cond ((not (typep event-window 'xlib:window)) + (xlib:discard-current-event display) + (warn "Discarding ~S event on non-window ~S." + ,event-key event-window) + (return-from object-set-event-handler nil)) + (t + (flush-display-events display) + (error "~S not a known X window.~%~ + Received event ~S." + event-window ,event-key)))) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (when *object-set-event-handler-print* + (print ,event-key) (force-output)) + (funcall (gethash ,event-key + (lisp::object-set-table object-set) + (lisp::object-set-default-handler + object-set)) + object ,event-key + ,@args)) + (setf result t)))) + (let ((*process-clx-event-display* display) + (result nil)) + (xlib:event-case (display :timeout 0) + ((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE) + (event-key event-window root child same-screen-p + x y root-x root-y state time code send-event-p) + (dispatch event-key event-window root child same-screen-p + x y root-x root-y state time code send-event-p)) + (:MOTION-NOTIFY (event-window root child same-screen-p + x y root-x root-y state time hint-p send-event-p) + (dispatch :motion-notify event-window root child same-screen-p + x y root-x root-y state time hint-p send-event-p)) + (:ENTER-NOTIFY (event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (dispatch :enter-notify event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (:LEAVE-NOTIFY (event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (dispatch :leave-notify event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (:EXPOSURE (event-window x y width height count send-event-p) + (dispatch :exposure event-window x y width height count send-event-p)) + (:GRAPHICS-EXPOSURE (event-window x y width height count major minor + send-event-p) + (dispatch :graphics-exposure event-window x y width height + count major minor send-event-p)) + (:NO-EXPOSURE (event-window major minor send-event-p) + (dispatch :no-exposure event-window major minor send-event-p)) + (:FOCUS-IN (event-window mode kind send-event-p) + (dispatch :focus-in event-window mode kind send-event-p)) + (:FOCUS-OUT (event-window mode kind send-event-p) + (dispatch :focus-out event-window mode kind send-event-p)) + (:KEYMAP-NOTIFY () + (warn "Ignoring keymap notify event.") + (when *object-set-event-handler-print* + (print :keymap-notify) (force-output)) + (setf result t)) + (:VISIBILITY-NOTIFY (event-window state send-event-p) + (dispatch :visibility-notify event-window state send-event-p)) + (:CREATE-NOTIFY (event-window window x y width height border-width + override-redirect-p send-event-p) + (dispatch :create-notify event-window window x y width height + border-width override-redirect-p send-event-p)) + (:DESTROY-NOTIFY (event-window window send-event-p) + (dispatch :destroy-notify event-window window send-event-p)) + (:UNMAP-NOTIFY (event-window window configure-p send-event-p) + (dispatch :unmap-notify event-window window configure-p send-event-p)) + (:MAP-NOTIFY (event-window window override-redirect-p send-event-p) + (dispatch :map-notify event-window window override-redirect-p + send-event-p)) + (:MAP-REQUEST (event-window window send-event-p) + (dispatch :map-request event-window window send-event-p)) + (:REPARENT-NOTIFY (event-window window parent x y override-redirect-p + send-event-p) + (dispatch :reparent-notify event-window window parent x y + override-redirect-p send-event-p)) + (:CONFIGURE-NOTIFY (event-window window x y width height border-width + above-sibling override-redirect-p send-event-p) + (dispatch :configure-notify event-window window x y width height + border-width above-sibling override-redirect-p + send-event-p)) + (:GRAVITY-NOTIFY (event-window window x y send-event-p) + (dispatch :gravity-notify event-window window x y send-event-p)) + (:RESIZE-REQUEST (event-window width height send-event-p) + (dispatch :resize-request event-window width height send-event-p)) + (:CONFIGURE-REQUEST (event-window window x y width height border-width + stack-mode above-sibling value-mask send-event-p) + (dispatch :configure-request event-window window x y width height + border-width stack-mode above-sibling value-mask + send-event-p)) + (:CIRCULATE-NOTIFY (event-window window place send-event-p) + (dispatch :circulate-notify event-window window place send-event-p)) + (:CIRCULATE-REQUEST (event-window window place send-event-p) + (dispatch :circulate-request event-window window place send-event-p)) + (:PROPERTY-NOTIFY (event-window atom state time send-event-p) + (dispatch :property-notify event-window atom state time send-event-p)) + (:SELECTION-CLEAR (event-window selection time send-event-p) + (dispatch :selection-notify event-window selection time send-event-p)) + (:SELECTION-REQUEST (event-window requestor selection target property + time send-event-p) + (dispatch :selection-request event-window requestor selection target + property time send-event-p)) + (:SELECTION-NOTIFY (event-window selection target property time + send-event-p) + (dispatch :selection-notify event-window selection target property time + send-event-p)) + (:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p) + (dispatch :colormap-notify event-window colormap new-p installed-p + send-event-p)) + (:MAPPING-NOTIFY (request) + (warn "Ignoring mapping notify event -- ~S." request) + (when *object-set-event-handler-print* + (print :mapping-notify) (force-output)) + (setf result t)) + (:CLIENT-MESSAGE (event-window format data send-event-p) + (dispatch :client-message event-window format data send-event-p))) + result))) + +(defun default-clx-event-handler (object event-key event-window &rest ignore) + (declare (ignore ignore)) + (flush-display-events *process-clx-event-display*) + (error "No handler for event type ~S on ~S in ~S." + event-key object (lisp::map-xwindow event-window))) + +(defun flush-display-events (display) + "Dumps all the events in display's event queue including the current one + in case this is called from within XLIB:EVENT-CASE, etc." + (xlib:discard-current-event display) + (xlib:event-case (display :discard-p t :timeout 0) + (t () nil))) + + Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/ed-integrity.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/ed-integrity.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/ed-integrity.lisp (revision 8058) @@ -0,0 +1,165 @@ +;;; -*- Package: hemlock; Log: hemlock.log; Mode: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This stuff can be used for testing tty redisplay. There are four +;;; commands that, given "Setup Tty Buffer", that test +;;; HI::COMPUTE-TTY-CHANGES: "Two Deletes", "Two Inserts", "One Delete One +;;; Insert", and "One Insert One Delete. Each can be called with an +;;; argument to generate a grand total of eight screen permutations. +;;; "Setup Tty Buffer" numbers the lines of the main window 0 through 19 +;;; inclusively. +;;; +;;; "Setup for Debugging" and "Cleanup for Debugging" were helpful in +;;; conjunction with some alternate versions of COMPUTE-TTY-CHANGES and +;;; TTY-SMART-WINDOW-REDISPLAY. When something went wrong with on + +(in-package "ED") + + +(declaim (special hemlock-internals::*debugging-tty-redisplay* + hemlock-internals::*testing-delete-queue* + hemlock-internals::*testing-insert-queue* + hemlock-internals::*testing-moved* + hemlock-internals::*testing-writes*)) + + +(defcommand "Setup Tty Buffer" (p) + "Clear buffer and insert numbering strings 0..19." + "Clear buffer and insert numbering strings 0..19." + (declare (ignore p)) + (delete-region (buffer-region (current-buffer))) + (let ((point (current-point))) + (dotimes (i 20) + (insert-string point (prin1-to-string i)) + (insert-character point #\newline)) + (buffer-start point))) + +(defcommand "Setup for Debugging" (p) + "Set *debugging-tty-redisplay* to t, and some other stuff to nil." + "Set *debugging-tty-redisplay* to t, and some other stuff to nil." + (declare (ignore p)) + (setf hi::*debugging-tty-redisplay* t) + (setf hi::*testing-delete-queue* nil) + (setf hi::*testing-insert-queue* nil) + (setf hi::*testing-moved* nil) + (setf hi::*testing-writes* nil)) + +(defcommand "Cleanup for Debugging" (p) + "Set *debugging-tty-redisplay* to nil." + "Set *debugging-tty-redisplay* to nil." + (declare (ignore p)) + (setf hi::*debugging-tty-redisplay* nil)) + +;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, 5, 10, 11, 12, +;;; 13, and 14. With argument, 3..7 and 12..14. +;;; +(defcommand "Two Deletes" (p) + "At line 3, delete 3 lines. At line 3+4, delete 5 lines. + With an argument, switch the number deleted." + "At line 3, delete 3 lines. At line 3+4, delete 5 lines. + With an argument, switch the number deleted." + (multiple-value-bind (dnum1 dnum2) + (if p (values 5 3) (values 3 5)) + (let ((point (current-point))) + (move-mark point (window-display-start (current-window))) + (line-offset point 3) + (with-mark ((end point :left-inserting)) + (line-offset end dnum1) + (delete-region (region point end)) + (line-offset point 4) + (line-offset (move-mark end point) dnum2) + (delete-region (region point end)))))) + + +;;; Given "Setup Tty Buffer", opens two blank lines between 2 and 3, and +;;; opens four blank lines between 6 and 7, leaving line numbered 13 at +;;; the bottom. With argument, four lines between 2 and 3, two lines +;;; between 6 and 7, and line 13 at the bottom of the window. +;;; +(defcommand "Two Inserts" (p) + "At line 3, open 2 lines. At line 3+2+4, open 4 lines. + With an argument, switch the number opened." + "At line 3, open 2 lines. At line 3+2+4, open 4 lines. + With an argument, switch the number opened." + (multiple-value-bind (onum1 onum2) + (if p (values 4 2) (values 2 4)) + (let ((point (current-point))) + (move-mark point (window-display-start (current-window))) + (line-offset point 3) + (dotimes (i onum1) + (insert-character point #\newline)) + (line-offset point 4) + (dotimes (i onum2) + (insert-character point #\newline))))) + + +;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, and 5, and +;;; opens five lines between lines numbered 9 and 10, leaving line numbered +;;; 17 on the bottom. With an argument, deletes lines numbered 3, 4, 5, 6, +;;; and 7, and opens three lines between 11 and 12, creating two blank lines +;;; at the end of the screen. +;;; +(defcommand "One Delete One Insert" (p) + "At line 3, delete 3 lines. At line 3+4, open 5 lines. + With an argument, switch the number of lines affected." + "At line 3, delete 3 lines. At line 3+4, open 5 lines. + With an argument, switch the number of lines affected." + (multiple-value-bind (dnum onum) + (if p (values 5 3) (values 3 5)) + (let ((point (current-point))) + (move-mark point (window-display-start (current-window))) + (line-offset point 3) + (with-mark ((end point :left-inserting)) + (line-offset end dnum) + (delete-region (region point end)) + (line-offset point 4) + (dotimes (i onum) + (insert-character point #\newline)))))) + +;;; Given "Setup Tty Buffer", opens three blank lines between lines numbered +;;; 2 and 3, and deletes lines numbered 7, 8, 9, 10, and 11, leaving two +;;; blank lines at the bottom of the window. With an argument, opens five +;;; blank lines between lines numbered 2 and 3, and deletes lines 7, 8, and +;;; 9, leaving line 17 at the bottom of the window. +;;; +(defcommand "One Insert One Delete" (p) + "At line 3, open 3 lines. At line 3+3+4, delete 5 lines. + With an argument, switch the number of lines affected." + "At line 3, open 3 lines. At line 3+3+4, delete 5 lines. + With an argument, switch the number of lines affected." + (multiple-value-bind (onum dnum) + (if p (values 5 3) (values 3 5)) + (let ((point (current-point))) + (move-mark point (window-display-start (current-window))) + (line-offset point 3) + (dotimes (i onum) + (insert-character point #\newline)) + (line-offset point 4) + (with-mark ((end point :left-inserting)) + (line-offset end dnum) + (delete-region (region point end)))))) + + +;;; This could be thrown away, but I'll leave it here. When I was testing +;;; the problem of generating EQ screen image lines due to faulty +;;; COMPUTE-TTY-CHANGES, this was a convenient command to get the editor +;;; back under control. +;;; +(defcommand "Fix Screen Image Lines" (p) + "" + "" + (declare (ignore p)) + (let* ((device (hi::device-hunk-device (hi::window-hunk (current-window)))) + (lines (hi::tty-device-lines device)) + (columns (hi::tty-device-columns device)) + (screen-image (hi::tty-device-screen-image device))) + (dotimes (i lines) + (setf (svref screen-image i) (hi::make-si-line columns))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/gosmacs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/gosmacs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/gosmacs.lisp (revision 8058) @@ -0,0 +1,33 @@ +;;; -*- Package: Hemlock; Log: Hemlock.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Stuff in this file provides some degree of upward compatibility +;;; for incurable Gosling Emacs users. +;;; +(in-package "HEMLOCK") + +(defcommand "Gosmacs Permute Characters" (p) + "Transpose the two characters before the point." + "Transpose the two characters before the point." + (declare (ignore p)) + (with-mark ((m (current-point) :left-inserting)) + (unless (and (mark-before m) (previous-character m)) + (editor-error "NIB You have addressed a character not in the buffer?")) + (rotatef (previous-character m) (next-character m)))) + +(bind-key "Gosmacs Permute Characters" #k"control-t") +(bind-key "Kill Previous Word" #k"meta-h") +(bind-key "Replace String" #k"meta-r") +(bind-key "Query Replace" #k"meta-q") +(bind-key "Fill Paragraph" #k"meta-j") +(bind-key "Visit File" #k"control-x control-r") +(bind-key "Find File" #k"control-x control-v") +(bind-key "Insert File" #k"control-x control-i") Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hacks.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hacks.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hacks.lisp (revision 8058) @@ -0,0 +1,22 @@ +(in-package "HI") + +(defun %sp-byte-blt (src start dest dstart end) + (%primitive byte-blt src start dest dstart end)) + +(defun lisp::sap-to-fixnum (x) (sap-int x)) +(defun lisp::fixnum-to-sap (x) (int-sap x)) +(defun lisp::%sp-make-fixnum (x) (%primitive make-fixnum x)) +(defun lisp::fast-char-upcase (x) (char-upcase x)) + +;;; prepare-window-for-redisplay -- Internal +;;; +;;; Called by make-window to do whatever redisplay wants to set up +;;; a new window. +;;; +(defun prepare-window-for-redisplay (window) + (setf (window-old-lines window) 0)) + +(defparameter hunk-width-limit 256) + +(defun reverse-video-hook-fun (&rest foo) + (declare (ignore foo))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hemcom.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hemcom.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hemcom.lisp (revision 8058) @@ -0,0 +1,297 @@ +;;; -*- Package: USER -*- +;;; +;;; ********************************************************************** +;;; +(ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file compiles all of Hemlock. +;;; + +#+bootstrap +(progn + (when (ext:get-command-line-switch "slave") + (error "Cannot compile Hemlock in a slave due to its clobbering needed + typescript routines by renaming the package.")) + + ;;; Blast the old packages in case they are around. We do this solely to + ;;; prove Hemlock can compile cleanly without its having to exist already. + ;;; + (copy-packages '("ED" "HI"))) + + +;;; Stuff to set up the packages Hemlock uses. +;;; +(unless (find-package "HEMLOCK-INTERNALS") + (make-package "HEMLOCK-INTERNALS" + :nicknames '("HI") + :use '("LISP" "EXTENSIONS" "SYSTEM"))) + +(unless (find-package "HEMLOCK") + (make-package "HEMLOCK" + :nicknames '("ED") + :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM"))) +;;; +(export 'c::compile-from-stream (find-package "C")) + + +(in-package "USER") + +(defvar *byte-compile* #+small t #-small :maybe) + +(pushnew :command-bits *features*) +(pushnew :buffered-lines *features*) + +#-clx +;;; If CLX has not been loaded, but has been compiled, then load it. +;;; +(when (probe-file (make-pathname :defaults "target:clx/clx-library" + :type (c:backend-fasl-file-type c:*backend*))) + #+(and (not pcl) (not no-pcl-clx)) + (load "target:pcl/pclload") + (load "target:clx/clx-library") + #+gencgc (gc :full t) + #-gencgc (ext:purify)) + +(with-compiler-log-file + ("target:compile-hemlock.log" + :optimize + '(optimize (debug #-small 2 #+small .5) + (speed 2) (inhibit-warnings 2) + (safety #-small 1 #+small 0)) + :optimize-interface + '(optimize-interface (debug .5)) + :context-declarations + '(((:or :external (:match "$%SET-")) + (declare (optimize (safety 2)) + (optimize-interface (debug 1)))) + (:macro (declare (optimize (speed 0)))))) + +(comf "target:code/globals") +(comf "target:code/struct") +(comf "target:hemlock/charmacs") +(comf "target:hemlock/key-event" :load t) +(comf "target:hemlock/struct") +;(comf "target:hemlock/struct-ed") +(comf "target:hemlock/rompsite") +;;; +;;; This is necessary since all the #k uses in Hemlock will expand into +;;; EXT:MAKE-KEY-EVENT calls with keysyms and bits from the compiling Lisp, not +;;; for the Lisp new code will run in. This destroys the compiling Lisp with +;;; respect to running code with #k's compiled for it, but it causes the +;;; compilation to see new keysyms, modifiers, and CLX modifier maps correctly +;;; for the new system. +;;; +(ext::re-initialize-key-events) +(comf "target:hemlock/keysym-defs") +(comf "target:hemlock/input") +(comf "target:hemlock/macros" :byte-compile t) +(comf "target:hemlock/line") +(comf "target:hemlock/ring") +(comf "target:hemlock/table") +(comf "target:hemlock/htext1") +(comf "target:hemlock/htext2") +(comf "target:hemlock/htext3") +(comf "target:hemlock/htext4") +(comf "target:hemlock/search1") +(comf "target:hemlock/search2") +(comf "target:hemlock/linimage") +(comf "target:hemlock/cursor") +(comf "target:hemlock/syntax") +(comf "target:hemlock/winimage") +#+clx (comf "target:hemlock/hunk-draw") +;(comf "target:hemlock/bit-stream") +(comf "target:hemlock/termcap") +(comf "target:hemlock/display") +#+clx (comf "target:hemlock/bit-display") +(comf "target:hemlock/tty-disp-rt") +(with-compilation-unit (:optimize '(optimize (safety 2) (debug 3))) + (comf "target:hemlock/tty-display")) ; Buggy... +;(comf "target:hemlock/tty-stream") +(comf "target:hemlock/pop-up-stream") +(comf "target:hemlock/screen") +#+clx (comf "target:hemlock/bit-screen") +(comf "target:hemlock/tty-screen") +(comf "target:hemlock/window") +(comf "target:hemlock/font") +(comf "target:hemlock/interp") +(comf "target:hemlock/vars") +(comf "target:hemlock/buffer") +(comf "target:hemlock/files") +(comf "target:hemlock/streams") +(comf "target:hemlock/echo" :byte-compile t) +(comf "target:hemlock/main" :byte-compile t) +(comf "target:hemlock/echocoms" :byte-compile t) +(comf "target:hemlock/defsyn") + +(comf "target:hemlock/ts-buf") +(comf "target:hemlock/ts-stream") + +(with-compilation-unit + (:optimize + '(optimize (safety 2) (speed 0)) + :context-declarations + '(((:match "-COMMAND$") + (declare (optimize (safety #+small 0 #-small 1)) + (optimize-interface (safety 2)))))) + +(comf "target:hemlock/command" :byte-compile t) +(comf "target:hemlock/morecoms" :byte-compile t) +(comf "target:hemlock/undo" :byte-compile t) +(comf "target:hemlock/killcoms" :byte-compile t) +(comf "target:hemlock/searchcoms" :byte-compile t) +(comf "target:hemlock/filecoms" :byte-compile t) +(comf "target:hemlock/indent" :byte-compile t) +(comf "target:hemlock/lispmode") +(comf "target:hemlock/comments" :byte-compile t) +(comf "target:hemlock/fill") +(comf "target:hemlock/text" :byte-compile t) +(comf "target:hemlock/doccoms" :byte-compile t) +(comf "target:hemlock/srccom" :byte-compile t) +(comf "target:hemlock/abbrev" :byte-compile t) +(comf "target:hemlock/group" :byte-compile t) +(comf "target:hemlock/overwrite" :byte-compile t) +(comf "target:hemlock/gosmacs" :byte-compile t) +(comf "target:hemlock/eval-server" :byte-compile t) +(comf "target:hemlock/dylan" :byte-compile t) +(comf "target:hemlock/lispbuf" :byte-compile t) +(comf "target:hemlock/lispeval" :byte-compile t) +(comf "target:hemlock/icom" :byte-compile t) +(comf "target:hemlock/hi-integrity" :byte-compile t) +(comf "target:hemlock/ed-integrity" :byte-compile t) +(comf "target:hemlock/scribe" :byte-compile t) +(comf "target:hemlock/pascal" :byte-compile t) +(comf "target:hemlock/edit-defs" :byte-compile t) +(comf "target:hemlock/auto-save" :byte-compile t) +(comf "target:hemlock/register" :byte-compile t) +(comf "target:hemlock/xcoms" :byte-compile t) +(comf "target:hemlock/unixcoms" :byte-compile t) +(comf "target:hemlock/mh") +(comf "target:hemlock/highlight" :byte-compile t) +(comf "target:hemlock/dired" :byte-compile t) +(comf "target:hemlock/diredcoms" :byte-compile t) +(comf "target:hemlock/bufed" :byte-compile t) +(comf "target:hemlock/lisp-lib" :byte-compile t) +(comf "target:hemlock/completion" :byte-compile t) +(comf "target:hemlock/shell" :byte-compile t) +(comf "target:hemlock/debug" :byte-compile t) +(comf "target:hemlock/netnews" :byte-compile t) +(comf "target:hemlock/rcs" :byte-compile t) + +) ;WITH-COMPILATION-UNIT for commands + +;; Stuff we want compiled native: + +(comf "target:hemlock/spell-rt") +(comf "target:hemlock/spell-corr") +(comf "target:hemlock/spell-aug") +(comf "target:hemlock/spell-build") +(comf "target:hemlock/spellcoms") +(comf "target:hemlock/kbdmac") + +(comf "target:hemlock/bindings") +(comf "target:hemlock/hacks") + +) ;WITH-COMPILER-LOG-FILE + +(unless (probe-file "target:hemlock/spell-dictionary.bin") + (load "target:hemlock/spell-rt") + (load "target:hemlock/spell-corr") + (load "target:hemlock/spell-aug") + (load "target:hemlock/spell-build") + (funcall (fdefinition (intern "BUILD-DICTIONARY" "SPELL")) + "target:hemlock/spell-dictionary.text" + "target:hemlock/spell-dictionary.bin")) + +(cat-if-anything-changed + "target:hemlock/hemlock-library" + "target:hemlock/rompsite" + "target:hemlock/struct" + ; "target:hemlock/struct-ed" + "target:hemlock/charmacs" + "target:hemlock/input" + "target:hemlock/line" + "target:hemlock/ring" + "target:hemlock/vars" + "target:hemlock/buffer" + "target:hemlock/macros" + "target:hemlock/interp" + "target:hemlock/syntax" + "target:hemlock/htext1" + "target:hemlock/htext2" + "target:hemlock/htext3" + "target:hemlock/htext4" + "target:hemlock/files" + "target:hemlock/search1" + "target:hemlock/search2" + "target:hemlock/table" + #+clx "target:hemlock/hunk-draw" + "target:hemlock/window" + "target:hemlock/screen" + "target:hemlock/winimage" + "target:hemlock/linimage" + "target:hemlock/display" + "target:hemlock/termcap" + #+clx "target:hemlock/bit-display" + "target:hemlock/tty-disp-rt" + "target:hemlock/tty-display" + "target:hemlock/pop-up-stream" + #+clx "target:hemlock/bit-screen" + "target:hemlock/tty-screen" + "target:hemlock/cursor" + "target:hemlock/font" + "target:hemlock/streams" + "target:hemlock/hacks" + "target:hemlock/main" + "target:hemlock/echo" + "target:hemlock/echocoms" + "target:hemlock/command" + "target:hemlock/indent" + "target:hemlock/comments" + "target:hemlock/morecoms" + "target:hemlock/undo" + "target:hemlock/killcoms" + "target:hemlock/searchcoms" + "target:hemlock/filecoms" + "target:hemlock/doccoms" + "target:hemlock/srccom" + "target:hemlock/group" + "target:hemlock/fill" + "target:hemlock/text" + "target:hemlock/lispmode" + "target:hemlock/ts-buf" + "target:hemlock/ts-stream" + "target:hemlock/eval-server" + "target:hemlock/lispbuf" + "target:hemlock/lispeval" + "target:hemlock/spell-rt" + "target:hemlock/spell-corr" + "target:hemlock/spell-aug" + "target:hemlock/spellcoms" + "target:hemlock/overwrite" + "target:hemlock/abbrev" + "target:hemlock/icom" + "target:hemlock/kbdmac" + "target:hemlock/defsyn" + "target:hemlock/scribe" + "target:hemlock/pascal" + "target:hemlock/dylan" + "target:hemlock/edit-defs" + "target:hemlock/auto-save" + "target:hemlock/register" + "target:hemlock/xcoms" + "target:hemlock/unixcoms" + "target:hemlock/mh" + "target:hemlock/highlight" + "target:hemlock/dired" + "target:hemlock/diredcoms" + "target:hemlock/bufed" + "target:hemlock/lisp-lib" + "target:hemlock/completion" + "target:hemlock/shell" + "target:hemlock/debug" + "target:hemlock/netnews" + "target:hemlock/rcs" + "target:hemlock/bindings") Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hi-integrity.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hi-integrity.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/hi-integrity.lisp (revision 8058) @@ -0,0 +1,52 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Skef Wholey +;;; +;;; Hack to check a buffer's integrity. +;;; +(in-package "HEMLOCK-INTERNALS") + +(defun checkit (&optional (buffer (current-buffer))) + "Returns NIL if the buffer's region is OK, or a losing line if it ain't. + If a malformed mark is found in the mark list it is returned as the + second value." + (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) + (previous nil line) + (lines nil (cons line lines))) + ((null line) nil) + (unless (eq (line-%buffer line) buffer) + (format t "~%Oh, Man! It's in the wrong buffer!~%") + (return line)) + (when (member line lines) + (format t "~%Oh, Man! It's circular!~%") + (return line)) + (unless (eq previous (line-previous line)) + (format t "~%Oh, Man! A back-pointer's screwed up!~%") + (return line)) + (when (and previous (>= (line-number previous) (line-number line))) + (format t "~%Oh, Man! A line number is screwed up!~%") + (return line)) + (let ((res + (do ((m (line-marks line) (cdr m))) + ((null m) nil) + (unless (<= 0 (mark-charpos (car m)) (line-length line)) + (format t "~%Oh, Man! A mark is pointing into hyperspace!~%") + (return (car m))) + (unless (member (mark-%kind (car m)) + '(:left-inserting :right-inserting)) + (format t "~%Oh, Man! A mark's type is bogus!.~%") + (return (car m))) + (unless (eq (mark-line (car m)) line) + (format t "~%Oh, Man! A mark's line pointer is messed up!~%") + (return (car m)))))) + (when res + (return (values line res)))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/keytran.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/keytran.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/keytran.lisp (revision 8058) @@ -0,0 +1,185 @@ +;;; -*- Log: hemlock.log; Package: extensions -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains a default character translation mechanism for X11 +;;; scan codes, keysyms, button codes, and modifier bits. +;;; +;;; Written by Bill Chiles. +;;; + +(in-package "EXTENSIONS") + +(export '(define-keysym define-mouse-code define-keyboard-modifier + translate-character translate-mouse-character)) + + + + +;;;; Keysym to character translation. + +;;; Hemlock uses its own keysym to character translation since this is easier +;;; and more versatile than the CLX design. Also, using CLX's mechanism is no +;;; more portable than writing our own translation based on the X11 protocol +;;; keysym specification. +;;; +;;; In the first table, nil indicates a non-event which is pertinent to +;;; ignoring modifier keys being pressed prior to pressing a key to be +;;; modified. In the second table, nil simply indicates that there is no +;;; special shift translation for the keysym, and that the CLX shifted keysym +;;; should be looked up as normal (see TRANSLATE-CHARACTER). +;;; +;;; This mapping is initialized with DEFINE-KEYSYM in Keytrandefs.Lisp +;;; +(defvar *keysym-translations* (make-hash-table)) +(defvar *shifted-keysym-translations* (make-hash-table)) + +(defun define-keysym (keysym char &optional shifted-char) + "Defines a keysym for Hemlock's translation. If shifted-char is supplied, + it is a character to use when the :shift modifier is on for an incoming + keysym. If shifted-char is not supplied, and the :shift modifier is set, + then XLIB:KEYCODE->KEYSYM is called with an index of 1 instead of 0. If + a :lock modifier is set, it is treated as a caps-lock. See + DEFINE-KEYBOARD-MODIFIER." + (check-type char character) + (setf (gethash keysym *keysym-translations*) char) + (when shifted-char + (check-type shifted-char character) + (setf (gethash keysym *shifted-keysym-translations*) shifted-char)) + t) + + +;;; X modifier bits translation +;;; +(defvar *modifier-translations* ()) + +(defun define-keyboard-modifier (clx-mask modifier-name) + "Causes clx-mask to be interpreted as modifier-name which must be one of + :control, :meta, :super, :hyper, :shift, or :lock." + (let ((map (assoc clx-mask *modifier-translations*))) + (if map + (rplacd map modifier-name) + (push (cons clx-mask modifier-name) *modifier-translations*)))) + +(define-keyboard-modifier (xlib:make-state-mask :control) :control) +(define-keyboard-modifier (xlib:make-state-mask :mod-1) :meta) +(define-keyboard-modifier (xlib:make-state-mask :shift) :shift) +(define-keyboard-modifier (xlib:make-state-mask :lock) :lock) + + +(defun translate-character (display scan-code bits) + "Translates scan-code and modifier bits to a Lisp character. The scan code + is first mapped to a keysym with index 0 for unshifted and index 1 for + shifted. If this keysym does not map to a character, and it is not a + modifier key (shift, ctrl, etc.), then an error is signaled. If the keysym + is a modifier key, then nil is returned. If we do have a character, and the + shift bit is off, and the lock bit is on, and the character is alphabetic, + then we get a new keysym with index 1, mapping it to a character. If this + does not result in a character, an error is signaled. If we have a + character, and the shift bit is on, then we look for a special shift mapping + for the original keysym. This allows for distinct characters for scan + codes that map to the same keysym, shifted or unshifted, (e.g., number pad + or arrow keys)." + (let ((dummy #\?) + shiftp lockp) + (dolist (ele *modifier-translations*) + (unless (zerop (logand (car ele) bits)) + (case (cdr ele) + (:shift (setf shiftp t)) + (:lock (setf lockp t)) + (t (setf dummy (set-char-bit dummy (cdr ele) t)))))) + (let* ((keysym (xlib:keycode->keysym display scan-code (if shiftp 1 0))) + (temp-char (gethash keysym *keysym-translations*))) + (cond ((not temp-char) + (if (<= 65505 keysym 65518) ;modifier keys. + nil + (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM." + keysym))) + ((and (not shiftp) lockp (alpha-char-p temp-char)) + (let* ((keysym (xlib:keycode->keysym display scan-code 1)) + (char (gethash keysym *keysym-translations*))) + (unless char + (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM." + keysym)) + (make-char char (logior (char-bits char) (char-bits dummy))))) + (shiftp + (let ((char (gethash keysym *shifted-keysym-translations*))) + (if char + (make-char char (logior (char-bits char) (char-bits dummy))) + (make-char temp-char (logior (char-bits temp-char) + (char-bits dummy)))))) + (t (make-char temp-char (logior (char-bits temp-char) + (char-bits dummy)))))))) + + + + +;;;; Mouse to character translations. + +;;; Mouse codes come from the server numbered one through five. This table is +;;; indexed by the code to retrieve a list. The CAR is a cons of the char and +;;; shifted char associated with a :button-press event. The CDR is a cons of +;;; the char and shifted char associated with a :button-release event. Each +;;; of these is potentially nil (not a cons at all). +;;; +(defvar *mouse-translations* (make-array 6 :initial-element nil)) +;;; +(defmacro mouse-press-chars (ele) `(car ,ele)) +(defmacro mouse-release-chars (ele) `(cadr ,ele)) + +(defun define-mouse-code (button char shifted-char event-key) + "Causes X button code to be interpreted as char. Shift and Lock modifiers + associated with button map to shifted-char. For the same button code, + event-key may be :button-press or :button-release." + (check-type char character) + (check-type shifted-char character) + (check-type event-key (member :button-press :button-release)) + (let ((stuff (svref *mouse-translations* button)) + (trans (cons char shifted-char))) + (if stuff + (case event-key + (:button-press (setf (mouse-press-chars stuff) trans)) + (:button-release (setf (mouse-release-chars stuff) trans))) + (case event-key + (:button-press + (setf (svref *mouse-translations* button) (list trans nil))) + (:button-release + (setf (svref *mouse-translations* button) (list nil trans)))))) + t) + +(define-mouse-code 1 #\leftdown #\super-leftdown :button-press) +(define-mouse-code 1 #\leftup #\super-leftup :button-release) + +(define-mouse-code 2 #\middledown #\super-middledown :button-press) +(define-mouse-code 2 #\middleup #\super-middleup :button-release) + +(define-mouse-code 3 #\rightdown #\super-rightdown :button-press) +(define-mouse-code 3 #\rightup #\super-rightup :button-release) + +(defun translate-mouse-character (scan-code bits event-key) + "Translates X button code, scan-code, and modifier bits, bits, for event-key + (either :button-press or :button-release) to a Lisp character." + (let ((temp (svref *mouse-translations* scan-code))) + (unless temp (error "Unknown mouse button -- ~S." scan-code)) + (let ((trans (ecase event-key + (:button-press (mouse-press-chars temp)) + (:button-release (mouse-release-chars temp))))) + (unless trans (error "Undefined ~S characters for mouse button ~S." + event-key scan-code)) + (let ((dummy #\?) + shiftp) + (dolist (ele *modifier-translations*) + (unless (zerop (logand (car ele) bits)) + (let ((bit (cdr ele))) + (if (or (eq bit :shift) (eq bit :lock)) + (setf shiftp t) + (setf dummy (set-char-bit dummy bit t)))))) + (let ((char (if shiftp (cdr trans) (car trans)))) + (make-char char (logior (char-bits char) (char-bits dummy)))))))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/keytrandefs.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/keytrandefs.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/keytrandefs.lisp (revision 8058) @@ -0,0 +1,184 @@ +;;; -*- Log: hemlock.log; Mode: Lisp; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file initializes character translation that would otherwise be done +;;; in Rompsite.Slisp, but there are no good hacks for mapping X11 keysyms +;;; to CMU Common Lisp character codes. +;;; +;;; Written by Bill Chiles. +;;; + +;;; The IBM RT keyboard has X11 keysyms defined for the following modifier +;;; keys, but we leave them mapped to nil indicating that they are non-events +;;; to be ignored: +;;; ctrl 65507 +;;; meta (left) 65513 +;;; meta (right) 65514 +;;; shift (left) 65505 +;;; shift (right) 65506 +;;; lock 65509 + +(in-package "HEMLOCK-INTERNALS") + + +;;; Function keys for the RT. +;;; +(define-keysym 65470 #\f1 #\s-f1) +(define-keysym 65471 #\f2 #\s-f2) +(define-keysym 65472 #\f3 #\s-f3) +(define-keysym 65473 #\f4 #\s-f4) +(define-keysym 65474 #\f5 #\s-f5) +(define-keysym 65475 #\f6 #\s-f6) +(define-keysym 65476 #\f7 #\s-f7) +(define-keysym 65477 #\f8 #\s-f8) +(define-keysym 65478 #\f9 #\s-f9) +(define-keysym 65479 #\f10 #\s-f10) +(define-keysym 65480 #\f11 #\s-f11) +(define-keysym 65481 #\f12 #\s-f12) + +;;; Function keys for the Sun (and other keyboards) -- L1-L10 and R1-R15. +;;; +(define-keysym 65482 #\f13 #\s-f13) +(define-keysym 65483 #\f14 #\s-f14) +(define-keysym 65484 #\f15 #\s-f15) +(define-keysym 65485 #\f16 #\s-f16) +(define-keysym 65486 #\f17 #\s-f17) +(define-keysym 65487 #\f18 #\s-f18) +(define-keysym 65488 #\f19 #\s-f19) +(define-keysym 65489 #\f20 #\s-f20) +(define-keysym 65490 #\f21 #\s-f21) +(define-keysym 65491 #\f22 #\s-f22) +(define-keysym 65492 #\f23 #\s-f23) +(define-keysym 65493 #\f24 #\s-f24) +(define-keysym 65494 #\f25 #\s-f25) +(define-keysym 65495 #\f26 #\s-f26) +(define-keysym 65496 #\f27 #\s-f27) +(define-keysym 65497 #\f28 #\s-f28) +(define-keysym 65498 #\f29 #\s-f29) +(define-keysym 65499 #\f30 #\s-f30) +(define-keysym 65500 #\f31 #\s-f31) +(define-keysym 65501 #\f32 #\s-f32) +(define-keysym 65502 #\f33 #\s-f33) +(define-keysym 65503 #\f34 #\s-f34) +(define-keysym 65504 #\f35 #\s-f35) + +;;; Upper right key bank. +;;; +(define-keysym 65377 #\printscreen #\s-printscreen) +;; Couldn't type scroll lock. +(define-keysym 65299 #\pause #\s-pause) + +;;; Middle right key bank. +;;; +(define-keysym 65379 #\insert #\s-insert) +(define-keysym 65535 #\delete #\delete) +(define-keysym 65360 #\home #\s-home) +(define-keysym 65365 #\pageup #\s-pageup) +(define-keysym 65367 #\end #\s-end) +(define-keysym 65366 #\pagedown #\s-pagedown) + +;;; Arrows. +;;; +(define-keysym 65361 #\leftarrow #\s-leftarrow) +(define-keysym 65362 #\uparrow #\s-uparrow) +(define-keysym 65364 #\downarrow #\s-downarrow) +(define-keysym 65363 #\rightarrow #\s-rightarrow) + +;;; Number pad. +;;; +(define-keysym 65407 #\numlock #\s-numlock) +(define-keysym 65421 #\s-return #\s-return) ;num-pad-enter +(define-keysym 65455 #\s-/ #\s-/) ;num-pad-/ +(define-keysym 65450 #\s-* #\s-*) ;num-pad-* +(define-keysym 65453 #\s-- #\s--) ;num-pad-- +(define-keysym 65451 #\s-+ #\s-+) ;num-pad-+ +(define-keysym 65456 #\s-0 #\s-0) ;num-pad-0 +(define-keysym 65457 #\s-1 #\s-1) ;num-pad-1 +(define-keysym 65458 #\s-2 #\s-2) ;num-pad-2 +(define-keysym 65459 #\s-3 #\s-3) ;num-pad-3 +(define-keysym 65460 #\s-4 #\s-4) ;num-pad-4 +(define-keysym 65461 #\s-5 #\s-5) ;num-pad-5 +(define-keysym 65462 #\s-6 #\s-6) ;num-pad-6 +(define-keysym 65463 #\s-7 #\s-7) ;num-pad-7 +(define-keysym 65464 #\s-8 #\s-8) ;num-pad-8 +(define-keysym 65465 #\s-9 #\s-9) ;num-pad-9 +(define-keysym 65454 #\s-. #\s-.) ;num-pad-. + +;;; "Named" keys. +;;; +(define-keysym 65289 #\tab #\tab) +(define-keysym 65307 #\escape #\escape) ;esc +(define-keysym 65288 #\backspace #\backspace) +(define-keysym 65293 #\return #\return) ;enter +(define-keysym 65512 #\linefeed #\linefeed) ;action +(define-keysym 32 #\space #\space) + +;;; Letters. +;;; +(define-keysym 97 #\a) (define-keysym 65 #\A) +(define-keysym 98 #\b) (define-keysym 66 #\B) +(define-keysym 99 #\c) (define-keysym 67 #\C) +(define-keysym 100 #\d) (define-keysym 68 #\D) +(define-keysym 101 #\e) (define-keysym 69 #\E) +(define-keysym 102 #\f) (define-keysym 70 #\F) +(define-keysym 103 #\g) (define-keysym 71 #\G) +(define-keysym 104 #\h) (define-keysym 72 #\H) +(define-keysym 105 #\i) (define-keysym 73 #\I) +(define-keysym 106 #\j) (define-keysym 74 #\J) +(define-keysym 107 #\k) (define-keysym 75 #\K) +(define-keysym 108 #\l) (define-keysym 76 #\L) +(define-keysym 109 #\m) (define-keysym 77 #\M) +(define-keysym 110 #\n) (define-keysym 78 #\N) +(define-keysym 111 #\o) (define-keysym 79 #\O) +(define-keysym 112 #\p) (define-keysym 80 #\P) +(define-keysym 113 #\q) (define-keysym 81 #\Q) +(define-keysym 114 #\r) (define-keysym 82 #\R) +(define-keysym 115 #\s) (define-keysym 83 #\S) +(define-keysym 116 #\t) (define-keysym 84 #\T) +(define-keysym 117 #\u) (define-keysym 85 #\U) +(define-keysym 118 #\v) (define-keysym 86 #\V) +(define-keysym 119 #\w) (define-keysym 87 #\W) +(define-keysym 120 #\x) (define-keysym 88 #\X) +(define-keysym 121 #\y) (define-keysym 89 #\Y) +(define-keysym 122 #\z) (define-keysym 90 #\Z) + +;;; Standard number keys. +;;; +(define-keysym 49 #\1) (define-keysym 33 #\!) +(define-keysym 50 #\2) (define-keysym 64 #\@) +(define-keysym 51 #\3) (define-keysym 35 #\#) +(define-keysym 52 #\4) (define-keysym 36 #\$) +(define-keysym 53 #\5) (define-keysym 37 #\%) +(define-keysym 54 #\6) (define-keysym 94 #\^) +(define-keysym 55 #\7) (define-keysym 38 #\&) +(define-keysym 56 #\8) (define-keysym 42 #\*) +(define-keysym 57 #\9) (define-keysym 40 #\() +(define-keysym 48 #\0) (define-keysym 41 #\)) + +;;; "Standard" symbol keys. +;;; +(define-keysym 96 #\`) (define-keysym 126 #\~) +(define-keysym 45 #\-) (define-keysym 95 #\_) +(define-keysym 61 #\=) (define-keysym 43 #\+) +(define-keysym 91 #\[) (define-keysym 123 #\{) +(define-keysym 93 #\]) (define-keysym 125 #\}) +(define-keysym 92 #\\) (define-keysym 124 #\|) +(define-keysym 59 #\;) (define-keysym 58 #\:) +(define-keysym 39 #\') (define-keysym 34 #\") +(define-keysym 44 #\,) (define-keysym 60 #\<) +(define-keysym 46 #\.) (define-keysym 62 #\>) +(define-keysym 47 #\/) (define-keysym 63 #\?) + + +;;; Sun keyboard. +;;; +(define-keysym 65387 #\break #\s-break) ;alternate (Sun). +(define-keysym 65290 #\linefeed #\s-linefeed) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/spell-build.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/spell-build.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/spell-build.lisp (revision 8058) @@ -0,0 +1,249 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This file contains code to build a new binary dictionary file from +;;; text in system space. This code relies on implementation dependent +;;; code from spell-rt.lisp. Also, it is expected that spell-corr.lisp +;;; and spell-aug.lisp have been loaded. In order to compile this file, +;;; you must first compile spell-rt, spell-corr.lisp, and spell-aug.lisp. + +;;; The text file must be in the following format: +;;; entry1/flag1/flag2/flag3 +;;; entry2 +;;; entry3/flag1/flag2/flag3/flag4/flag5. +;;; The flags are single letter indicators of legal suffixes for the entry; +;;; the available flags and their correct use may be found at the beginning +;;; of spell-corr.lisp in the Hemlock sources. There must be exactly one +;;; entry per line, and each line must be flushleft. + +;;; The dictionary is built in system space as three distinct +;;; blocks of memory: the dictionary which is a hash table whose elements +;;; are one machine word or of type '(unsigned-byte 16); a descriptors +;;; vector which is described below; and a string table. After all the +;;; entries are read in from the text file, one large block of memory is +;;; validated, and the three structures are moved into it. Then the file +;;; is written. When the large block of memory is validated, enough +;;; memory is allocated to write the three vector such that they are page +;;; aligned. This is important for the speed it allows in growing the +;;; "dictionary" when augmenting it from a user's text file (see +;;; spell-aug.lisp). + + +(in-package "SPELL") + + + + +;;;; Constants + +;;; This is an upper bound estimate of the number of stored entries in the +;;; dictionary. It should not be more than 21,845 because the dictionary +;;; is a vector of type '(unsigned-byte 16), and the descriptors' vector +;;; for the entries uses three '(unsigned-byte 16) elements per descriptor +;;; unit. See the beginning of Spell-Correct.Lisp. +;;; +(eval-when (compile load eval) + +(defconstant max-entry-count-estimate 15600) + +(defconstant new-dictionary-size 20011) + +(defconstant new-descriptors-size (1+ (* 3 max-entry-count-estimate))) + +(defconstant max-string-table-length (* 10 max-entry-count-estimate)) + +); eval-when + + + +;;;; Hashing + +;;; These hashing macros are different from the ones in Spell-Correct.Lisp +;;; simply because we are using separate space and global specials/constants. +;;; Of course, they should be identical, but it doesn't seem worth cluttering +;;; up Spell-Correct with macro generating macros for this file. + +(eval-when (compile eval) + +(defmacro new-hash2-increment (hash) + `(- new-dictionary-size + 2 + (the fixnum (rem ,hash (- new-dictionary-size 2))))) + +(defmacro new-hash2-loop (loc hash dictionary) + (let ((incr (gensym)) + (loop-loc (gensym))) + `(let* ((,incr (new-hash2-increment ,hash)) + (,loop-loc ,loc)) + (declare (fixnum ,incr ,loop-loc)) + (loop (setf ,loop-loc + (rem (+ ,loop-loc ,incr) new-dictionary-size)) + (when (zerop (the fixnum (aref ,dictionary ,loop-loc))) + (return ,loop-loc)) + (when (= ,loop-loc ,loc) (return nil)))))) + +(defmacro new-hash-entry (entry entry-len dictionary) + (let ((hash (gensym)) + (loc (gensym))) + `(let* ((,hash (string-hash ,entry ,entry-len)) + (,loc (rem ,hash new-dictionary-size))) + (declare (fixnum ,loc)) + (cond ((not (zerop (the fixnum (aref ,dictionary ,loc)))) + (incf *collision-count*) + (new-hash2-loop ,loc ,hash ,dictionary)) + (t ,loc))))) + +) ;eval-when + + + + +;;;; Build-Dictionary + +;;; An interesting value when building an initial dictionary. +(defvar *collision-count* 0) + +(defvar *new-dictionary*) +(defvar *new-descriptors*) +(defvar *new-string-table*) + +(defun build-dictionary (input output &optional save-structures-p) + (let ((dictionary (make-array new-dictionary-size + :element-type '(unsigned-byte 16))) + (descriptors (make-array new-descriptors-size + :element-type '(unsigned-byte 16))) + (string-table (make-string max-string-table-length))) + (write-line "Reading dictionary ...") + (force-output) + (setf *collision-count* 0) + (multiple-value-bind (entry-count string-table-length) + (read-initial-dictionary input dictionary + descriptors string-table) + (write-line "Writing dictionary ...") + (force-output) + (write-dictionary output dictionary descriptors entry-count + string-table string-table-length) + (when save-structures-p + (setf *new-dictionary* dictionary) + (setf *new-descriptors* descriptors) + (setf *new-string-table* string-table)) + (format t "~D entries processed with ~D collisions." + entry-count *collision-count*)))) + +(defun read-initial-dictionary (f dictionary descriptors string-table) + (let* ((filename (pathname f)) + (s (open filename :direction :input :if-does-not-exist nil))) + (unless s (error "File ~S does not exist." f)) + (multiple-value-prog1 + (let ((descriptor-ptr 1) + (string-ptr 0) + (entry-count 0)) + (declare (fixnum descriptor-ptr string-ptr entry-count)) + (loop (multiple-value-bind (line eofp) (read-line s nil nil) + (declare (type (or null simple-string) line)) + (unless line (return (values entry-count string-ptr))) + (incf entry-count) + (when (> entry-count max-entry-count-estimate) + (error "There are too many entries in text file!~%~ + Please change constants in spell-build.lisp, ~ + recompile the file, and reload it.~%~ + Be sure to understand the constraints of permissible ~ + values.")) + (let ((flags (or (position #\/ line :test #'char=) (length line)))) + (declare (fixnum flags)) + (cond ((> flags max-entry-length) + (format t "Entry ~s too long." (subseq line 0 flags)) + (force-output)) + (t (let ((new-string-ptr (+ string-ptr flags))) + (declare (fixnum new-string-ptr)) + (when (> new-string-ptr max-string-table-length) + (error "Spell string table overflow!~%~ + Please change constants in ~ + spell-build.lisp, recompile the file, ~ + and reload it.~%~ + Be sure to understand the constraints ~ + of permissible values.")) + (spell-place-entry line flags + dictionary descriptors string-table + descriptor-ptr string-ptr) + (incf descriptor-ptr 3) + (setf string-ptr new-string-ptr))))) + (when eofp (return (values entry-count string-ptr)))))) + (close s)))) + +(defun spell-place-entry (line word-end dictionary descriptors string-table + descriptor-ptr string-ptr) + (declare (simple-string line string-table) + (fixnum word-end descriptor-ptr string-ptr) + (type (array (unsigned-byte 16) (*)) dictionary descriptors)) + (nstring-upcase line :end word-end) + (let* ((hash-loc (new-hash-entry line word-end dictionary)) + (descriptor-ptr+1 (1+ descriptor-ptr)) + (descriptor-ptr+2 (1+ descriptor-ptr+1))) + (unless hash-loc (error "Dictionary Overflow!")) + (setf (aref dictionary hash-loc) descriptor-ptr) + (setf (aref descriptors descriptor-ptr) + (dpb (the fixnum + (ldb new-hash-byte (string-hash line word-end))) + stored-hash-byte + word-end)) + (setf (aref descriptors descriptor-ptr+1) + (ldb whole-index-low-byte string-ptr)) + (setf (aref descriptors descriptor-ptr+2) + (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) + stored-index-high-byte + 0)) + (new-add-flags descriptors descriptor-ptr+2 line word-end) + (replace string-table line :start1 string-ptr :end2 word-end))) + +(defun new-add-flags (descriptors loc line word-end) + (declare (simple-string line) + (fixnum word-end) + (type (array (unsigned-byte 16) (*)) descriptors)) + (do ((flag (1+ word-end) (+ 2 flag)) + (line-end (length line))) + ((>= flag line-end)) + (declare (fixnum flag line-end)) + (let ((flag-mask (flag-mask (schar line flag)))) + (declare (fixnum flag-mask)) + (if (zerop flag-mask) + (format t "Illegal flag ~S on word ~S." + (schar line flag) (subseq line 0 word-end)) + (setf (aref descriptors loc) + (logior flag-mask (aref descriptors loc))))))) + +(defun write-dictionary (f dictionary descriptors entry-count + string-table string-table-length) + (declare (type (array (unsigned-byte 16) (*)) dictionary descriptors) + (simple-string string-table) + (fixnum string-table-length)) + (let ((filename (ext:unix-namestring (pathname f) nil))) + (with-open-file (s filename :direction :output + :element-type '(unsigned-byte 16) + :if-exists :overwrite + :if-does-not-exist :create) + (let ((descriptors-size (1+ (* 3 entry-count)))) + (write-byte magic-file-id s) + (write-byte new-dictionary-size s) + (write-byte descriptors-size s) + (write-byte (ldb whole-index-low-byte string-table-length) s) + (write-byte (ldb whole-index-high-byte string-table-length) s) + (dotimes (i new-dictionary-size) + (write-byte (aref dictionary i) s)) + (dotimes (i descriptors-size) + (write-byte (aref descriptors i) s)))) + (with-open-file (s f :direction :output :element-type 'base-char + :if-exists :append) + (write-string string-table s :end string-table-length)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/struct-ed.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/struct-ed.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/struct-ed.lisp (revision 8058) @@ -0,0 +1,40 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Structures used by constucts in the HEMLOCK package. +;;; + +(in-package "HEMLOCK") + +;;; The server-info structure holds information about the connection to a +;;; particular eval server. For now, we don't separate the background I/O and +;;; random compiler output. The Notifications port and Terminal_IO will be the +;;; same identical object. This separation in the interface may be just +;;; gratuitous pseudo-generality, but it doesn't hurt. +;;; +(defstruct (server-info + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (format stream "#" (server-info-name s))))) + name ; String name of this server. + port ; Port we send requests to. + ; NullPort if no connection. + notifications ; List of notification objects for operations + ; which have not yet completed. + ts-info ; Ts-Info structure of typescript we use in + ; "background" buffer. + buffer ; Buffer "background" typescript is in. + slave-ts ; Ts-Info used in "Slave Lisp" buffer + ; (formerly the "Lisp Listener" buffer). + slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. + errors ; List of structures describing reported errors. + error-mark) ; Pointer after last error edited. Index: /branches/experimentation/later/source/cocoa-ide/hemlock/unused/tty-stream.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/unused/tty-stream.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/unused/tty-stream.lisp (revision 8058) @@ -0,0 +1,161 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; Some stuff to make streams that write out to terminal hunks. +;;; +;;; Written by Bill Chiles. +;;; +;;; This code is VERY similar to that in Pane-Stream.Lisp. The biggest +;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE. +;;; + +(in-package "HEMLOCK-INTERNALS") + + + + +;;;; Constants + +(defconstant tty-hunk-width-limit 200) + + + + +;;;; Structures + +;;; Tty-Hunk streams are inherently buffered by line. + +(defstruct (stream-hunk (:print-function %print-device-hunk) + (:include tty-hunk)) + (width 0 :type fixnum) + (point-x 0 :type fixnum) + (point-y 0 :type fixnum) + (buffer "" :type simple-string)) + +(defstruct (tty-hunk-output-stream (:include sys:lisp-stream + (out #'hunk-out) + (sout #'hunk-sout) + (misc #'hunk-misc)) + (:constructor + make-tty-hunk-output-stream ())) + (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit)))) + + + + +;;;; Tty-hunk-output-stream methods + +;;; HUNK-OUT puts a character into a hunk-stream buffer. If the character +;;; makes the current line wrap, or if the character is a newline, then +;;; call TTY-HUNK-NEWLINE. +;;; +(defun hunk-out (stream character) + (let* ((hunk (tty-hunk-output-stream-hunk stream)) + (x (stream-hunk-point-x hunk))) + (declare (fixnum x)) + (cond ((char= character #\newline) + (tty-hunk-stream-newline hunk) + (return-from hunk-out nil)) + ((= x (the fixnum (stream-hunk-width hunk))) + (setf x 0) + (tty-hunk-stream-newline hunk))) + (setf (schar (stream-hunk-buffer hunk) x) character) + (incf (stream-hunk-point-x hunk)))) + +;;; HUNK-MISC, when finishing or forcing output, only needs to blast +;;; out the buffer at y from 0 to x since these streams are inherently +;;; line buffered. Currently, these characters will be blasted out again +;;; since there isn't a separate buffer index from point-x, and we can't +;;; set point-x to zero since we haven't a newline. +;;; +(defun hunk-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (let ((hunk (tty-hunk-output-stream-hunk stream))) + (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk)))) + ((:finish-output :force-output) + (let* ((hunk (tty-hunk-output-stream-hunk stream)) + (device (device-hunk-device hunk))) + (funcall (tty-device-display-string device) + hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk) + 0 (stream-hunk-point-x hunk)) + (when (device-force-output device) + (funcall (device-force-output device))))) + (:line-length + (stream-hunk-width (tty-hunk-output-stream-hunk stream))) + (:element-type 'base-char))) + +;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer. +;;; When newlines are found, recurse on the substrings delimited by start, +;;; end, and newlines. If the string causes line wrapping, then we break +;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE. +;;; +(defun hunk-sout (stream string start end) + (declare (fixnum start end)) + (let* ((hunk (tty-hunk-output-stream-hunk stream)) + (buffer (stream-hunk-buffer hunk)) + (x (stream-hunk-point-x hunk)) + (dst-end (+ x (- end start))) + (width (stream-hunk-width hunk)) + (newlinep (%sp-find-character string start end #\newline))) + (declare (fixnum x dst-end width)) + (cond (newlinep + (let ((previous start) (current newlinep)) + (declare (fixnum previous)) + (loop (when (null current) + (hunk-sout stream string previous end) + (return)) + (hunk-sout stream string previous current) + (tty-hunk-stream-newline hunk) + (setf previous (the fixnum (1+ (the fixnum current)))) + (setf current + (%sp-find-character string previous end #\newline))))) + ((> dst-end width) + (let ((new-start (+ start (- width x)))) + (declare (fixnum new-start)) + (%primitive byte-blt string start buffer x width) + (setf (stream-hunk-point-x hunk) width) + (tty-hunk-stream-newline hunk) + (do ((idx (+ new-start width) (+ idx width)) + (prev new-start idx)) + ((>= idx end) + (let ((dst-end (- end prev))) + (%primitive byte-blt string prev buffer 0 dst-end) + (setf (stream-hunk-point-x hunk) dst-end))) + (declare (fixnum prev idx)) + (%primitive byte-blt string prev buffer 0 width) + (setf (stream-hunk-point-x hunk) width) + (tty-hunk-stream-newline hunk)))) + (t + (%primitive byte-blt string start buffer x dst-end) + (setf (stream-hunk-point-x hunk) dst-end))))) + +;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect +;;; point-y. We also blast out the buffer in HUNK-MISC. +;;; +(defun tty-hunk-stream-newline (hunk) + (let* ((device (device-hunk-device hunk)) + (force-output-fun (device-force-output device)) + (y (stream-hunk-point-y hunk))) + (declare (fixnum y)) + (when (= y (the fixnum (device-hunk-position hunk))) + (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8) + (when force-output-fun (funcall force-output-fun)) + (wait-for-more) + (funcall (tty-device-clear-to-eow device) hunk 0 0) + (setf (stream-hunk-point-y hunk) 0) + (setf y 0)) + (funcall (tty-device-display-string device) + hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk)) + (when force-output-fun (funcall force-output-fun)) + (setf (stream-hunk-point-x hunk) 0) + (incf (stream-hunk-point-y hunk)))) Index: /branches/experimentation/later/source/cocoa-ide/hemlock/website/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/website/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/website/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/cocoa-ide/hemlock/website/index.html.in =================================================================== --- /branches/experimentation/later/source/cocoa-ide/hemlock/website/index.html.in (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/hemlock/website/index.html.in (revision 8058) @@ -0,0 +1,158 @@ + + + + Portable Hemlock + + + + + +

+ +

Portable Hemlock

+

+Hemlock is an Emacs-like editor which for a long time was a part of CMUCL. It was believed that it +is tied to this particular implementation of Common Lisp. But this is +no longer true. + +

+So, here is Portable Hemlock! An attempt to free Hemlock from its CMUCL +prison. + +

+The stuff that works is opening files, editing them and saving your +work -- what you expect from an editor. Lisp mode works too. Missing +is: tty mode operation, typescript buffers (inferior shell and +inferior lisp), spell checking, netnews and mail. +

+Portable Hemlock was tested in: +

+ +

Download

+ +hemlock-%%DATE%%.tar.gz, have fun. + +

CVS access

+ +

+ Anonymouns [read-only] CVS access is available. Just follow the instructions below: + +

+$ export CVSROOT=:pserver:anonymous@bauhh.dyndns.org:/hemlock
+$ cvs login
+Logging in to :pserver:anonymous@bauhh.dyndns.org:2401/hemlock
+CVS password: anonymous
+$ cvs -z9 co -P hemlock
+

+ +non-anonymous CVS write access is also awailable, just drop +me a note if you want +access. + +

News/History

+ +
+
2003-08-05 +
I was a bit lazy updating the web page. Here is what happend: +
    + +
  • Ingvar Mattsson is hacking an elisp compatibility package. + +
  • I am currently working on providing the "Slave Lisp" +functionality, so that Portable Hemlock will be useful for actually +hacking Lisp code. + +
+ +
2003-03-06 +
Bug fix: auto-save.lisp was not compiling. +
2003-03-05 +
This web page was created.

+ New release having the SBCL patches in. +

2003-02-07 +
Portable Hemlock was announced to #lisp. +
2002-11-?? +
I made initial attempt to port Hemlock from CMUCL. Then put it aside to work on other stuff. +
+ +

Random Notes

+ +

+The source code of Hemlock showed unportability (or better its age) in +the following areas: +

    +

  • + Buffers sometimes also serve as streams. As Hemlock was written + there was no universal de-facto standard interface for user defined + streams and thus the authors defined CMUCL streams. These days we + have Gray streams. + +

  • + File I/O was tied to both CMUCL and Unix to accommodate probably + slow machines. The file I/O functions called + unix-read and unix-write beaming data directly to + and fro system areas. I changed that using standard CL functions + doing I/O on a line-by-line basis now. + +

  • + The TTY interface is inherently unportable. Currently it is + disabled altogether. I think we could reclaim some useful code from + Hemlock's TTY interface and morph it into a CLIM TTY port. And + since my graphics card cannot even display a text console interface + on my monitor, this has very low priority on my list, though other + people might want to have it. + +

  • + The X11 interface uses the SERVE-EVENT facility of CMUCL, + which naturally is only available there. I provided a thin + portability layer to provide the same API using just the standard + CLX interface. +

+

+This already summaries pretty well the current state of Portable +Hemlock. You can edit files using the X11 interface on an ANSI CL +which provides for CLX. + +

Future

+ +

+The next steps I have in mind are: + +

    +

  • Port the missing files except the TTY interface. + +

  • Hemlock has the idea that characters are 8-bit wide. We need to + teach it otherwise as we have Unicode strings now. This involves + syntax tables and probably searching. + +

  • I want a CLIM Hemlock. +

    + How exactly to do this is still not decided. I see two + possibilities: +

      +
    • Hemlock already provides for a kind of device interface. We can + implement a new device which is just a CLIM device. + +
    • Or we rip this device abstraction layer and state that CLIM + itself is the device layer. (Making the bet that we'll have a TTY + CLIM in the future). +
    +
+

After that is done, we can talk about extending Portable Hemlock in various +ways like syntax highlighting, color, new modes, ... you name it. + + +
+
+

Gilbert Baumann
+
+$Id$ + + Index: /branches/experimentation/later/source/cocoa-ide/ide-bundle.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-bundle.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-bundle.lisp (revision 8058) @@ -0,0 +1,55 @@ +;;-*-Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007 Clozure Associates +;;; + +(in-package "CCL") + +;;; We need to be able to point the CoreFoundation and Cocoa libraries +;;; at some bundle very early in the process, so do that before anything +;;; else. + +(defun create-ide-bundle (bundle-path &key (source "ccl:cocoa-ide;ide-contents;") + (source-ignore '(".svn" "cvs" ".cvsignore")) + (copy-headers *cocoa-application-copy-headers-p*) + (if-exists :overwrite)) + ;; TODO: Right now if the bundle exists, we leave alone any files that we don't replace. + ;; I'd like :if-exists :supersede mean to remove such files, for clean builds, but + ;; recursive-copy-directory doesn't support :if-exists :supersede yet... + (flet ((subdir (dir sub) + (ensure-directory-pathname (make-pathname :name sub :defaults dir))) + (ignore-test (p) + (flet ((backup-p (name) + (and (stringp name) + (let ((len (length name))) + (and (> len 0) + (or (eql (aref name (1- len)) #\~) + (eql (aref name 0) #\#))))))) + (not (or (member (car (last (pathname-directory p))) source-ignore :test #'equalp) + (backup-p (pathname-name p)) + (backup-p (pathname-type p)) + (member (pathname-name p) source-ignore :test #'equalp)))))) + (let* ((source-dir (ensure-directory-pathname source)) + (target-dir (ensure-directory-pathname bundle-path)) + (contents-dir (subdir target-dir "Contents"))) + (recursive-copy-directory source-dir contents-dir :if-exists if-exists :test #'ignore-test) + (when copy-headers + (let* ((subdirs (ccl::cdb-subdirectory-path)) + (ccl-headers (make-pathname :host "ccl" :directory `(:absolute ,@subdirs))) + (dest-headers (make-pathname :host (pathname-host contents-dir) + :directory (append (pathname-directory contents-dir) + (cons "Resources" subdirs))))) + (recursive-copy-directory ccl-headers dest-headers :if-exists if-exists :test #'ignore-test))) + ;; Is this necessary? + (let* ((image-name (ccl::standard-kernel-name)) + (ccl-image (make-pathname :name image-name :host "ccl")) + (dest-image (make-pathname :name image-name + :defaults (subdir contents-dir "MacOS")))) + (ensure-directories-exist dest-image) + (copy-file ccl-image dest-image :if-exists :supersede :preserve-attributes t)) + (ccl::touch target-dir)))) + +(progn + (require "FAKE-CFBUNDLE-PATH") + (create-ide-bundle *cocoa-application-path*) + (ccl::fake-cfbundle-path *cocoa-application-path* "ccl:cocoa-ide;Info.plist-proto" "com.clozure")) Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/PkgInfo =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/PkgInfo (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/PkgInfo (revision 8058) @@ -0,0 +1,1 @@ +APPLOMCL Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/.cvsignore =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.nib Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/Credits.html =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/Credits.html (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/Credits.html (revision 8058) @@ -0,0 +1,28 @@ + + + + + +

+This is still a very preliminary, barebones +implementation of a Cocoa development environment for +Clozure CL. It's improved some over time, and +will hopefully continue to do so. +

+

+To report bugs or request enhancements, please go to the +OpenMCL Trac +and create a ticket. +

+ + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/InfoPlist.strings =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/InfoPlist.strings (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/InfoPlist.strings (revision 8058) @@ -0,0 +1,6 @@ +/* Localized versions of Info.plist keys */ + +CFBundleName = "Clozure CL"; +CFBundleShortVersionString = "Clozure Common Lisp version 0.1"; +CFBundleGetInfoString = "Clozure Common Lisp version 0.1, Copyright 2002-2007 Clozure Associates and contributors."; +NSHumanReadableCopyright = "Copyright 2002-2007 Clozure Associates and contributors."; Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/classes.nib (revision 8058) @@ -0,0 +1,67 @@ + + + + + IBClasses + + + ACTIONS + + toggleTypeout + id + + CLASS + NSApplication + LANGUAGE + ObjC + SUPERCLASS + NSResponder + + + ACTIONS + + backtrace + id + compileAndLoadBuffer + id + compileBuffer + id + continue + id + evalSelection + id + exitBreak + id + hyperSpecLookUp + id + inspect + id + interrupt + id + loadBuffer + id + newListener + id + restarts + id + showAproposWindow + id + showListener + id + showPreferences + id + showProcessesWindow + id + + CLASS + FirstResponder + LANGUAGE + ObjC + SUPERCLASS + NSObject + + + IBVersion + 1 + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/info.nib (revision 8058) @@ -0,0 +1,18 @@ + + + + + IBFramework Version + 629 + IBOldestOS + 5 + IBOpenObjects + + 436 + + IBSystem Version + 9A581 + targetFramework + IBCocoaFramework + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/classes.nib (revision 8058) @@ -0,0 +1,32 @@ +{ + IBClasses = ( + {CLASS = FirstResponder; LANGUAGE = ObjC; SUPERCLASS = NSObject; }, + { + ACTIONS = {browserAction = id; browserDoubleAction = id; }; + CLASS = InspectorBrowserDelegate; + LANGUAGE = ObjC; + OUTLETS = {inspectorTableView = NSTableView; inspectorWindow = NSWindow; }; + SUPERCLASS = NSObject; + }, + {CLASS = InspectorNSBrowser; LANGUAGE = ObjC; SUPERCLASS = NSBrowser; }, + { + CLASS = InspectorTableViewDataSource; + LANGUAGE = ObjC; + OUTLETS = {inspectorBrowser = NSBrowser; inspectorWindow = NSWindow; }; + SUPERCLASS = NSObject; + }, + { + CLASS = InspectorTableViewDelegate; + LANGUAGE = ObjC; + OUTLETS = {inspectorWindow = NSWindow; }; + SUPERCLASS = NSObject; + }, + { + CLASS = InspectorWindowController; + LANGUAGE = ObjC; + OUTLETS = {inspectorBrowser = NSBrowser; }; + SUPERCLASS = NSWindowController; + } + ); + IBVersion = 1; +} Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/info.nib (revision 8058) @@ -0,0 +1,18 @@ + + + + + IBDocumentLocation + 58 65 356 240 0 0 1280 1002 + IBFramework Version + 446.1 + IBOpenObjects + + 21 + + IBSystem Version + 8L2127 + IBUsesTextArchiving + + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/keyedobjects.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/keyedobjects.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/OpenmclInspector.nib/keyedobjects.nib (revision 8058) @@ -0,0 +1,2299 @@ + + + + + $archiver + NSKeyedArchiver + $objects + + $null + + $class + + CF$UID + 168 + + NSAccessibilityConnectors + + CF$UID + 165 + + NSAccessibilityOidsKeys + + CF$UID + 166 + + NSAccessibilityOidsValues + + CF$UID + 167 + + NSClassesKeys + + CF$UID + 138 + + NSClassesValues + + CF$UID + 139 + + NSConnections + + CF$UID + 9 + + NSFontManager + + CF$UID + 0 + + NSFramework + + CF$UID + 5 + + NSNamesKeys + + CF$UID + 129 + + NSNamesValues + + CF$UID + 130 + + NSNextOid + 276 + NSObjectsKeys + + CF$UID + 126 + + NSObjectsValues + + CF$UID + 128 + + NSOidsKeys + + CF$UID + 140 + + NSOidsValues + + CF$UID + 141 + + NSRoot + + CF$UID + 2 + + NSVisibleWindows + + CF$UID + 7 + + + + $class + + CF$UID + 4 + + NSClassName + + CF$UID + 3 + + + InspectorWindowController + + $classes + + NSCustomObject + NSObject + + $classname + NSCustomObject + + + $class + + CF$UID + 6 + + NS.string + IBCocoaFramework + + + $classes + + NSMutableString + NSString + NSObject + + $classname + NSMutableString + + + $class + + CF$UID + 8 + + NS.objects + + + + $classes + + NSMutableSet + NSSet + NSObject + + $classname + NSMutableSet + + + $class + + CF$UID + 49 + + NS.objects + + + CF$UID + 10 + + + CF$UID + 58 + + + CF$UID + 62 + + + CF$UID + 107 + + + CF$UID + 109 + + + CF$UID + 111 + + + CF$UID + 113 + + + CF$UID + 115 + + + CF$UID + 117 + + + CF$UID + 119 + + + CF$UID + 122 + + + CF$UID + 124 + + + + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 54 + + NSLabel + + CF$UID + 56 + + NSSource + + CF$UID + 11 + + + + $class + + CF$UID + 53 + + NSBackgroundColor + + CF$UID + 39 + + NSColumnAutoresizingStyle + 4 + NSCornerView + + CF$UID + 18 + + NSDraggingSourceMaskForLocal + 15 + NSDraggingSourceMaskForNonLocal + 0 + NSEnabled + + NSFrameSize + + CF$UID + 13 + + NSGridColor + + CF$UID + 50 + + NSHeaderView + + CF$UID + 14 + + NSIntercellSpacingHeight + 2 + NSIntercellSpacingWidth + 3 + NSNextResponder + + CF$UID + 12 + + NSRowHeight + 17 + NSSuperview + + CF$UID + 12 + + NSTableColumns + + CF$UID + 22 + + NSTvFlags + 1379926016 + NSvFlags + 256 + + + $class + + CF$UID + 88 + + NSBGColor + + CF$UID + 85 + + NSDocView + + CF$UID + 11 + + NSFrame + + CF$UID + 84 + + NSNextKeyView + + CF$UID + 11 + + NSNextResponder + + CF$UID + 19 + + NSSubviews + + CF$UID + 83 + + NSSuperview + + CF$UID + 19 + + NScvFlags + 4 + NSvFlags + 2304 + + {525, 193} + + $class + + CF$UID + 17 + + NSFrameSize + + CF$UID + 16 + + NSNextResponder + + CF$UID + 15 + + NSSuperview + + CF$UID + 15 + + NSTableView + + CF$UID + 11 + + NSvFlags + 256 + + + $class + + CF$UID + 88 + + NSBGColor + + CF$UID + 85 + + NSDocView + + CF$UID + 14 + + NSFrame + + CF$UID + 97 + + NSNextKeyView + + CF$UID + 14 + + NSNextResponder + + CF$UID + 19 + + NSSubviews + + CF$UID + 96 + + NSSuperview + + CF$UID + 19 + + NScvFlags + 4 + NSvFlags + 2304 + + {525, 17} + + $classes + + NSTableHeaderView + NSView + NSResponder + NSObject + + $classname + NSTableHeaderView + + + $class + + CF$UID + 21 + + NSFrame + + CF$UID + 20 + + NSNextResponder + + CF$UID + 19 + + NSSuperview + + CF$UID + 19 + + NSvFlags + 256 + + + $class + + CF$UID + 99 + + NSContentView + + CF$UID + 12 + + NSCornerView + + CF$UID + 18 + + NSFrame + + CF$UID + 98 + + NSHScroller + + CF$UID + 93 + + NSHeaderClipView + + CF$UID + 15 + + NSNextKeyView + + CF$UID + 12 + + NSNextResponder + + CF$UID + 70 + + NSScrollAmts + + QSAAAEEgAABBmAAAQZgAAA== + + NSSubviews + + CF$UID + 82 + + NSSuperview + + CF$UID + 70 + + NSVScroller + + CF$UID + 89 + + NSsFlags + 50 + NSvFlags + 258 + + {{526, 0}, {16, 17}} + + $classes + + _NSCornerView + NSView + NSResponder + NSObject + + $classname + _NSCornerView + + + $class + + CF$UID + 49 + + NS.objects + + + CF$UID + 23 + + + CF$UID + 44 + + + + + $class + + CF$UID + 43 + + NSDataCell + + CF$UID + 37 + + NSHeaderCell + + CF$UID + 25 + + NSIdentifier + + CF$UID + 24 + + NSIsEditable + + NSIsResizeable + + NSMaxWidth + 1000 + NSMinWidth + 40 + NSResizingMask + 3 + NSTableView + + CF$UID + 11 + + NSWidth + 178 + + property + + $class + + CF$UID + 36 + + NSBackgroundColor + + CF$UID + 30 + + NSCellFlags + 75628032 + NSCellFlags2 + 0 + NSContents + + CF$UID + 26 + + NSSupport + + CF$UID + 27 + + NSTextColor + + CF$UID + 32 + + + Property + + $class + + CF$UID + 29 + + NSName + + CF$UID + 28 + + NSSize + 11 + NSfFlags + 16 + + LucidaGrande + + $classes + + NSFont + NSObject + + $classname + NSFont + + + $class + + CF$UID + 31 + + NSColorSpace + 3 + NSWhite + + MC4zMzMzMzMzNAA= + + + + $classes + + NSColor + NSObject + + $classname + NSColor + + + $class + + CF$UID + 31 + + NSCatalogName + + CF$UID + 33 + + NSColor + + CF$UID + 35 + + NSColorName + + CF$UID + 34 + + NSColorSpace + 6 + + System + headerTextColor + + $class + + CF$UID + 31 + + NSColorSpace + 3 + NSWhite + + MAA= + + + + $classes + + NSTableHeaderCell + NSTextFieldCell + NSActionCell + NSCell + NSObject + + $classname + NSTableHeaderCell + + + $class + + CF$UID + 42 + + NSBackgroundColor + + CF$UID + 39 + + NSCellFlags + 338820672 + NSCellFlags2 + 1024 + NSControlView + + CF$UID + 11 + + NSSupport + + CF$UID + 38 + + NSTextColor + + CF$UID + 40 + + + + $class + + CF$UID + 29 + + NSName + + CF$UID + 28 + + NSSize + 13 + NSfFlags + 1044 + + + $class + + CF$UID + 31 + + NSColorSpace + 3 + NSWhite + + MQA= + + + + $class + + CF$UID + 31 + + NSCatalogName + + CF$UID + 33 + + NSColor + + CF$UID + 35 + + NSColorName + + CF$UID + 41 + + NSColorSpace + 6 + + controlTextColor + + $classes + + NSTextFieldCell + NSActionCell + NSCell + NSObject + + $classname + NSTextFieldCell + + + $classes + + NSTableColumn + NSObject + + $classname + NSTableColumn + + + $class + + CF$UID + 43 + + NSDataCell + + CF$UID + 48 + + NSHeaderCell + + CF$UID + 46 + + NSIdentifier + + CF$UID + 45 + + NSIsEditable + + NSIsResizeable + + NSMaxWidth + 1000 + NSMinWidth + 37.4010009765625 + NSResizingMask + 3 + NSTableView + + CF$UID + 11 + + NSWidth + 341 + + value + + $class + + CF$UID + 36 + + NSBackgroundColor + + CF$UID + 30 + + NSCellFlags + 75628032 + NSCellFlags2 + 0 + NSContents + + CF$UID + 47 + + NSSupport + + CF$UID + 27 + + NSTextColor + + CF$UID + 32 + + + Value + + $class + + CF$UID + 42 + + NSBackgroundColor + + CF$UID + 39 + + NSCellFlags + 338820672 + NSCellFlags2 + 1024 + NSControlView + + CF$UID + 11 + + NSSupport + + CF$UID + 38 + + NSTextColor + + CF$UID + 40 + + + + $classes + + NSMutableArray + NSArray + NSObject + + $classname + NSMutableArray + + + $class + + CF$UID + 31 + + NSCatalogName + + CF$UID + 33 + + NSColor + + CF$UID + 52 + + NSColorName + + CF$UID + 51 + + NSColorSpace + 6 + + gridColor + + $class + + CF$UID + 31 + + NSColorSpace + 3 + NSWhite + + MC41AA== + + + + $classes + + NSTableView + %NSTableView + NSControl + NSView + NSResponder + NSObject + + $classname + NSTableView + + + $class + + CF$UID + 4 + + NSClassName + + CF$UID + 55 + + + InspectorTableViewDataSource + dataSource + + $classes + + NSNibOutletConnector + NSNibConnector + NSObject + + $classname + NSNibOutletConnector + + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 59 + + NSLabel + + CF$UID + 61 + + NSSource + + CF$UID + 11 + + + + $class + + CF$UID + 4 + + NSClassName + + CF$UID + 60 + + + InspectorTableViewDelegate + delegate + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 65 + + NSLabel + + CF$UID + 106 + + NSSource + + CF$UID + 63 + + + + $class + + CF$UID + 4 + + NSClassName + + CF$UID + 64 + + + InspectorBrowserDelegate + + $class + + CF$UID + 105 + + NSMaxSize + + CF$UID + 104 + + NSMinSize + + CF$UID + 103 + + NSScreenRect + + CF$UID + 102 + + NSViewClass + + CF$UID + 69 + + NSWTFlags + 1881669632 + NSWindowBacking + 2 + NSWindowClass + + CF$UID + 68 + + NSWindowRect + + CF$UID + 66 + + NSWindowStyleMask + 14 + NSWindowTitle + + CF$UID + 67 + + NSWindowView + + CF$UID + 70 + + + {{91, 144}, {582, 563}} + OpenMCL Inspector + NSWindow + + $class + + CF$UID + 6 + + NS.string + View + + + $class + + CF$UID + 101 + + NSFrame + + CF$UID + 100 + + NSNextResponder + + CF$UID + 0 + + NSSubviews + + CF$UID + 71 + + + + $class + + CF$UID + 49 + + NS.objects + + + CF$UID + 72 + + + CF$UID + 19 + + + + + $class + + CF$UID + 81 + + NSBrFlags + 403783680 + NSCellPrototype + + CF$UID + 76 + + NSClassName + + CF$UID + 73 + + NSColumnResizingType + 1 + NSEnabled + + NSFirstColumnTitle + + CF$UID + 80 + + NSFrame + + CF$UID + 75 + + NSMaxNumberOfVisibleColumns + 3 + NSMinColumnWidth + 1 + NSNextResponder + + CF$UID + 70 + + NSNumberOfVisibleColumns + 3 + NSOriginalClassName + + CF$UID + 74 + + NSPathSeparator + + CF$UID + 79 + + NSSuperview + + CF$UID + 70 + + NSvFlags + 274 + + InspectorNSBrowser + NSBrowser + {{20, 268}, {542, 275}} + + $class + + CF$UID + 78 + + NSCellFlags + 67239488 + NSCellFlags2 + 1024 + NSContents + + CF$UID + 77 + + NSSupport + + CF$UID + 38 + + + + $class + + CF$UID + 6 + + NS.string + BrowserItem + + + $classes + + NSBrowserCell + NSCell + NSObject + + $classname + NSBrowserCell + + + $class + + CF$UID + 6 + + NS.string + / + + Inspect: + + $classes + + NSClassSwapper + NSObject + + $classname + NSClassSwapper + + + $class + + CF$UID + 49 + + NS.objects + + + CF$UID + 12 + + + CF$UID + 89 + + + CF$UID + 93 + + + CF$UID + 15 + + + CF$UID + 18 + + + + + $class + + CF$UID + 49 + + NS.objects + + + CF$UID + 11 + + + + {{1, 17}, {525, 193}} + + $class + + CF$UID + 31 + + NSCatalogName + + CF$UID + 33 + + NSColor + + CF$UID + 87 + + NSColorName + + CF$UID + 86 + + NSColorSpace + 6 + + controlBackgroundColor + + $class + + CF$UID + 31 + + NSColorSpace + 3 + NSWhite + + MC42NjY2NjY2OQA= + + + + $classes + + NSClipView + NSView + NSResponder + NSObject + + $classname + NSClipView + + + $class + + CF$UID + 92 + + NSAction + + CF$UID + 91 + + NSFrame + + CF$UID + 90 + + NSNextResponder + + CF$UID + 19 + + NSPercent + 0.95263159275054932 + NSSuperview + + CF$UID + 19 + + NSTarget + + CF$UID + 19 + + NSvFlags + 256 + + {{526, 17}, {15, 193}} + _doScroller: + + $classes + + NSScroller + NSControl + NSView + NSResponder + NSObject + + $classname + NSScroller + + + $class + + CF$UID + 92 + + NSAction + + CF$UID + 95 + + NSFrame + + CF$UID + 94 + + NSNextResponder + + CF$UID + 19 + + NSPercent + 0.99047619104385376 + NSSuperview + + CF$UID + 19 + + NSTarget + + CF$UID + 19 + + NSsFlags + 1 + NSvFlags + 256 + + {{1, 210}, {525, 15}} + _doScroller: + + $class + + CF$UID + 49 + + NS.objects + + + CF$UID + 14 + + + + {{1, 0}, {525, 17}} + {{20, 20}, {542, 226}} + + $classes + + NSScrollView + NSView + NSResponder + NSObject + + $classname + NSScrollView + + {{1, 9}, {582, 563}} + + $classes + + NSView + NSResponder + NSObject + + $classname + NSView + + {{0, 0}, {1280, 1002}} + {582, 585} + {3.40282e+38, 3.40282e+38} + + $classes + + NSWindowTemplate + NSObject + + $classname + NSWindowTemplate + + inspectorWindow + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 65 + + NSLabel + + CF$UID + 108 + + NSSource + + CF$UID + 54 + + + inspectorWindow + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 65 + + NSLabel + + CF$UID + 110 + + NSSource + + CF$UID + 59 + + + inspectorWindow + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 65 + + NSLabel + + CF$UID + 112 + + NSSource + + CF$UID + 2 + + + window + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 2 + + NSLabel + + CF$UID + 114 + + NSSource + + CF$UID + 65 + + + delegate + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 72 + + NSLabel + + CF$UID + 116 + + NSSource + + CF$UID + 54 + + + inspectorBrowser + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 63 + + NSLabel + + CF$UID + 118 + + NSSource + + CF$UID + 72 + + + delegate + + $class + + CF$UID + 121 + + NSDestination + + CF$UID + 63 + + NSLabel + + CF$UID + 120 + + NSSource + + CF$UID + 72 + + + browserAction: + + $classes + + NSNibControlConnector + NSNibConnector + NSObject + + $classname + NSNibControlConnector + + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 72 + + NSLabel + + CF$UID + 123 + + NSSource + + CF$UID + 2 + + + inspectorBrowser + + $class + + CF$UID + 57 + + NSDestination + + CF$UID + 11 + + NSLabel + + CF$UID + 125 + + NSSource + + CF$UID + 63 + + + inspectorTableView + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 63 + + + CF$UID + 44 + + + CF$UID + 70 + + + CF$UID + 54 + + + CF$UID + 11 + + + CF$UID + 59 + + + CF$UID + 65 + + + CF$UID + 23 + + + CF$UID + 19 + + + CF$UID + 72 + + + + + $classes + + NSArray + NSObject + + $classname + NSArray + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 2 + + + CF$UID + 11 + + + CF$UID + 65 + + + CF$UID + 2 + + + CF$UID + 19 + + + CF$UID + 2 + + + CF$UID + 2 + + + CF$UID + 11 + + + CF$UID + 70 + + + CF$UID + 70 + + + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 63 + + + CF$UID + 44 + + + CF$UID + 54 + + + CF$UID + 11 + + + CF$UID + 59 + + + CF$UID + 65 + + + CF$UID + 23 + + + CF$UID + 19 + + + CF$UID + 72 + + + CF$UID + 2 + + + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 64 + + + CF$UID + 131 + + + CF$UID + 55 + + + CF$UID + 132 + + + CF$UID + 60 + + + CF$UID + 133 + + + CF$UID + 134 + + + CF$UID + 135 + + + CF$UID + 136 + + + CF$UID + 137 + + + + NSTableColumn1 + NSTableView + Window + NSTableColumn + NSScrollView1 + NSBrowser1 + + $class + + CF$UID + 6 + + NS.string + File's Owner + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 72 + + + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 73 + + + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 58 + + + CF$UID + 122 + + + CF$UID + 72 + + + CF$UID + 70 + + + CF$UID + 109 + + + CF$UID + 62 + + + CF$UID + 115 + + + CF$UID + 63 + + + CF$UID + 107 + + + CF$UID + 113 + + + CF$UID + 54 + + + CF$UID + 19 + + + CF$UID + 11 + + + CF$UID + 111 + + + CF$UID + 65 + + + CF$UID + 10 + + + CF$UID + 117 + + + CF$UID + 119 + + + CF$UID + 44 + + + CF$UID + 23 + + + CF$UID + 59 + + + CF$UID + 124 + + + CF$UID + 2 + + + + + $class + + CF$UID + 127 + + NS.objects + + + CF$UID + 142 + + + CF$UID + 143 + + + CF$UID + 144 + + + CF$UID + 145 + + + CF$UID + 146 + + + CF$UID + 147 + + + CF$UID + 148 + + + CF$UID + 149 + + + CF$UID + 150 + + + CF$UID + 151 + + + CF$UID + 152 + + + CF$UID + 153 + + + CF$UID + 154 + + + CF$UID + 155 + + + CF$UID + 156 + + + CF$UID + 157 + + + CF$UID + 158 + + + CF$UID + 159 + + + CF$UID + 160 + + + CF$UID + 161 + + + CF$UID + 162 + + + CF$UID + 163 + + + CF$UID + 164 + + + + 254 + 274 + 234 + 2 + 257 + 255 + 264 + 249 + 256 + 263 + 250 + 238 + 236 + 262 + 21 + 253 + 265 + 272 + 237 + 235 + 251 + 275 + 1 + + $class + + CF$UID + 49 + + NS.objects + + + + $class + + CF$UID + 127 + + NS.objects + + + + $class + + CF$UID + 127 + + NS.objects + + + + $classes + + NSIBObjectData + NSObject + + $classname + NSIBObjectData + + + $top + + IB.objectdata + + CF$UID + 1 + + + $version + 100000 + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/apropos.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/apropos.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/apropos.nib/classes.nib (revision 8058) @@ -0,0 +1,54 @@ + + + + + IBClasses + + + ACTIONS + + apropos + id + inspectSelectedSymbol + id + setPackage + id + toggleShowsExternalSymbols + id + + CLASS + AproposWindowController + LANGUAGE + ObjC + OUTLETS + + arrayController + id + comboBox + id + externalSymbolsCheckbox + id + tableView + id + textView + id + + SUPERCLASS + NSWindowController + + + CLASS + PackageComboBox + LANGUAGE + ObjC + OUTLETS + + dataSource + id + + + + IBVersion + 1 + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/apropos.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/apropos.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/apropos.nib/info.nib (revision 8058) @@ -0,0 +1,18 @@ + + + + + IBFramework Version + 629 + IBOldestOS + 5 + IBOpenObjects + + 127 + + IBSystem Version + 9A581 + targetFramework + IBCocoaFramework + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/classes.nib (revision 8058) @@ -0,0 +1,11 @@ +{ + IBClasses = ( + { + CLASS = BacktraceWindowController; + LANGUAGE = ObjC; + OUTLETS = {outlineView = id; }; + SUPERCLASS = NSWindowController; + } + ); + IBVersion = 1; +} Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/info.nib (revision 8058) @@ -0,0 +1,18 @@ + + + + + IBDocumentLocation + 178 227 356 240 0 0 1280 1002 + IBFramework Version + 446.1 + IBOldestOS + 4 + IBSystem Version + 8P135 + IBUsesTextArchiving + + targetFramework + IBCocoaFramework + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/keyedobjects.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/keyedobjects.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/backtrace.nib/keyedobjects.nib (revision 8058) @@ -0,0 +1,1556 @@ + + + + + $archiver + NSKeyedArchiver + $objects + + $null + + $class + + CF$UID + 114 + + NSAccessibilityConnectors + + CF$UID + 111 + + NSAccessibilityOidsKeys + + CF$UID + 112 + + NSAccessibilityOidsValues + + CF$UID + 113 + + NSClassesKeys + + CF$UID + 97 + + NSClassesValues + + CF$UID + 98 + + NSConnections + + CF$UID + 8 + + NSFontManager + + CF$UID + 0 + + NSFramework + + CF$UID + 5 + + NSNamesKeys + + CF$UID + 88 + + NSNamesValues + + CF$UID + 89 + + NSNextOid + 15 + NSObjectsKeys + + CF$UID + 83 + + NSObjectsValues + + CF$UID + 87 + + NSOidsKeys + + CF$UID + 99 + + NSOidsValues + + CF$UID + 100 + + NSRoot + + CF$UID + 2 + + NSVisibleWindows + + CF$UID + 6 + + + + $class + + CF$UID + 4 + + NSClassName + + CF$UID + 3 + + + BacktraceWindowController + + $classes + + NSCustomObject + NSObject + + $classname + NSCustomObject + + IBCocoaFramework + + $class + + CF$UID + 7 + + NS.objects + + + + $classes + + NSMutableSet + NSSet + NSObject + + $classname + NSMutableSet + + + $class + + CF$UID + 42 + + NS.objects + + + CF$UID + 9 + + + CF$UID + 47 + + + CF$UID + 81 + + + + + $class + + CF$UID + 46 + + NSDestination + + CF$UID + 10 + + NSLabel + + CF$UID + 45 + + NSSource + + CF$UID + 2 + + + + $class + + CF$UID + 44 + + NSBackgroundColor + + CF$UID + 37 + + NSColumnAutoresizingStyle + 1 + NSCornerView + + CF$UID + 17 + + NSDraggingSourceMaskForLocal + 15 + NSDraggingSourceMaskForNonLocal + 0 + NSEnabled + + NSFrameSize + + CF$UID + 12 + + NSGridColor + + CF$UID + 43 + + NSHeaderView + + CF$UID + 13 + + NSIntercellSpacingHeight + 2 + NSIntercellSpacingWidth + 3 + NSNextResponder + + CF$UID + 11 + + NSRowHeight + 17 + NSSuperview + + CF$UID + 11 + + NSTableColumns + + CF$UID + 21 + + NSTvFlags + 1388347392 + NSvFlags + 256 + + + $class + + CF$UID + 62 + + NSBGColor + + CF$UID + 59 + + NSDocView + + CF$UID + 10 + + NSFrame + + CF$UID + 58 + + NSNextKeyView + + CF$UID + 10 + + NSNextResponder + + CF$UID + 18 + + NSSubviews + + CF$UID + 57 + + NSSuperview + + CF$UID + 18 + + NScvFlags + 4 + NSvFlags + 2304 + + {495, 266} + + $class + + CF$UID + 16 + + NSFrameSize + + CF$UID + 15 + + NSNextResponder + + CF$UID + 14 + + NSSuperview + + CF$UID + 14 + + NSTableView + + CF$UID + 10 + + NSvFlags + 256 + + + $class + + CF$UID + 62 + + NSBGColor + + CF$UID + 59 + + NSDocView + + CF$UID + 13 + + NSFrame + + CF$UID + 71 + + NSNextKeyView + + CF$UID + 13 + + NSNextResponder + + CF$UID + 18 + + NSSubviews + + CF$UID + 70 + + NSSuperview + + CF$UID + 18 + + NScvFlags + 4 + NSvFlags + 2304 + + {495, 17} + + $classes + + NSTableHeaderView + NSView + NSResponder + NSObject + + $classname + NSTableHeaderView + + + $class + + CF$UID + 20 + + NSFrame + + CF$UID + 19 + + NSNextResponder + + CF$UID + 18 + + NSSuperview + + CF$UID + 18 + + NSvFlags + 256 + + + $class + + CF$UID + 73 + + NSContentView + + CF$UID + 11 + + NSFrame + + CF$UID + 72 + + NSHScroller + + CF$UID + 67 + + NSHeaderClipView + + CF$UID + 14 + + NSNextKeyView + + CF$UID + 11 + + NSNextResponder + + CF$UID + 54 + + NSScrollAmts + + QSAAAEEgAABBmAAAQZgAAA== + + NSSubviews + + CF$UID + 56 + + NSSuperview + + CF$UID + 54 + + NSVScroller + + CF$UID + 63 + + NSsFlags + 113 + NSvFlags + 274 + + {{496, 1}, {12, 17}} + + $classes + + _NSCornerView + NSView + NSResponder + NSObject + + $classname + _NSCornerView + + + $class + + CF$UID + 42 + + NS.objects + + + CF$UID + 22 + + + + + $class + + CF$UID + 41 + + NSDataCell + + CF$UID + 35 + + NSHeaderCell + + CF$UID + 23 + + NSIsEditable + + NSIsResizeable + + NSMaxWidth + 1000 + NSMinWidth + 16 + NSResizingMask + 3 + NSTableView + + CF$UID + 10 + + NSWidth + 492 + + + $class + + CF$UID + 34 + + NSBackgroundColor + + CF$UID + 28 + + NSCellFlags + 75628032 + NSCellFlags2 + 0 + NSContents + + CF$UID + 24 + + NSSupport + + CF$UID + 25 + + NSTextColor + + CF$UID + 30 + + + + + $class + + CF$UID + 27 + + NSName + + CF$UID + 26 + + NSSize + 11 + NSfFlags + 16 + + LucidaGrande + + $classes + + NSFont + NSObject + + $classname + NSFont + + + $class + + CF$UID + 29 + + NSColorSpace + 3 + NSWhite + + MC4zMzMzMzI5OQA= + + + + $classes + + NSColor + NSObject + + $classname + NSColor + + + $class + + CF$UID + 29 + + NSCatalogName + + CF$UID + 31 + + NSColor + + CF$UID + 33 + + NSColorName + + CF$UID + 32 + + NSColorSpace + 6 + + System + headerTextColor + + $class + + CF$UID + 29 + + NSColorSpace + 3 + NSWhite + + MAA= + + + + $classes + + NSTableHeaderCell + NSTextFieldCell + NSActionCell + NSCell + NSObject + + $classname + NSTableHeaderCell + + + $class + + CF$UID + 40 + + NSBackgroundColor + + CF$UID + 37 + + NSCellFlags + 338820672 + NSCellFlags2 + 1024 + NSControlView + + CF$UID + 10 + + NSSupport + + CF$UID + 36 + + NSTextColor + + CF$UID + 38 + + + + $class + + CF$UID + 27 + + NSName + + CF$UID + 26 + + NSSize + 13 + NSfFlags + 1044 + + + $class + + CF$UID + 29 + + NSColorSpace + 3 + NSWhite + + MQA= + + + + $class + + CF$UID + 29 + + NSCatalogName + + CF$UID + 31 + + NSColor + + CF$UID + 33 + + NSColorName + + CF$UID + 39 + + NSColorSpace + 6 + + controlTextColor + + $classes + + NSTextFieldCell + NSActionCell + NSCell + NSObject + + $classname + NSTextFieldCell + + + $classes + + NSTableColumn + NSObject + + $classname + NSTableColumn + + + $classes + + NSMutableArray + NSArray + NSObject + + $classname + NSMutableArray + + + $class + + CF$UID + 29 + + NSColorSpace + 1 + NSRGB + + MCAwIDAA + + + + $classes + + NSOutlineView + NSTableView + %NSTableView + NSControl + NSView + NSResponder + NSObject + + $classname + NSOutlineView + + outlineView + + $classes + + NSNibOutletConnector + NSNibConnector + NSObject + + $classname + NSNibOutletConnector + + + $class + + CF$UID + 46 + + NSDestination + + CF$UID + 48 + + NSLabel + + CF$UID + 80 + + NSSource + + CF$UID + 2 + + + + $class + + CF$UID + 79 + + NSMaxSize + + CF$UID + 78 + + NSMinSize + + CF$UID + 77 + + NSScreenRect + + CF$UID + 76 + + NSViewClass + + CF$UID + 52 + + NSWTFlags + 813174784 + NSWindowBacking + 2 + NSWindowClass + + CF$UID + 51 + + NSWindowRect + + CF$UID + 49 + + NSWindowStyleMask + 14 + NSWindowTitle + + CF$UID + 50 + + NSWindowView + + CF$UID + 54 + + + {{172, 212}, {508, 254}} + Backtrace + NSWindow + + $class + + CF$UID + 53 + + NS.string + View + + + $classes + + NSMutableString + NSString + NSObject + + $classname + NSMutableString + + + $class + + CF$UID + 75 + + NSFrameSize + + CF$UID + 74 + + NSNextResponder + + CF$UID + 0 + + NSSubviews + + CF$UID + 55 + + + + $class + + CF$UID + 42 + + NS.objects + + + CF$UID + 18 + + + + + $class + + CF$UID + 42 + + NS.objects + + + CF$UID + 11 + + + CF$UID + 63 + + + CF$UID + 67 + + + CF$UID + 14 + + + CF$UID + 17 + + + + + $class + + CF$UID + 42 + + NS.objects + + + CF$UID + 10 + + + + {{1, 18}, {495, 194}} + + $class + + CF$UID + 29 + + NSCatalogName + + CF$UID + 31 + + NSColor + + CF$UID + 61 + + NSColorName + + CF$UID + 60 + + NSColorSpace + 6 + + controlBackgroundColor + + $class + + CF$UID + 29 + + NSColorSpace + 3 + NSWhite + + MC42NjY2NjY2OQA= + + + + $classes + + NSClipView + NSView + NSResponder + NSObject + + $classname + NSClipView + + + $class + + CF$UID + 66 + + NSAction + + CF$UID + 65 + + NSEnabled + + NSFrame + + CF$UID + 64 + + NSNextResponder + + CF$UID + 18 + + NSPercent + 0.72932332754135132 + NSSuperview + + CF$UID + 18 + + NSTarget + + CF$UID + 18 + + NSsFlags + 256 + NSvFlags + 256 + + {{496, 18}, {11, 194}} + _doScroller: + + $classes + + NSScroller + NSControl + NSView + NSResponder + NSObject + + $classname + NSScroller + + + $class + + CF$UID + 66 + + NSAction + + CF$UID + 69 + + NSFrame + + CF$UID + 68 + + NSNextResponder + + CF$UID + 18 + + NSPercent + 0.96868884563446045 + NSSuperview + + CF$UID + 18 + + NSTarget + + CF$UID + 18 + + NSsFlags + 257 + NSvFlags + 256 + + {{1, 212}, {495, 11}} + _doScroller: + + $class + + CF$UID + 42 + + NS.objects + + + CF$UID + 13 + + + + {{1, 1}, {495, 17}} + {{0, 25}, {508, 224}} + + $classes + + NSScrollView + NSView + NSResponder + NSObject + + $classname + NSScrollView + + {508, 254} + + $classes + + NSView + NSResponder + NSObject + + $classname + NSView + + {{0, 0}, {1280, 1002}} + {213, 129} + {3.40282e+38, 3.40282e+38} + + $classes + + NSWindowTemplate + NSObject + + $classname + NSWindowTemplate + + window + + $class + + CF$UID + 46 + + NSDestination + + CF$UID + 2 + + NSLabel + + CF$UID + 82 + + NSSource + + CF$UID + 10 + + + dataSource + + $class + + CF$UID + 86 + + NS.objects + + + CF$UID + 18 + + + CF$UID + 84 + + + CF$UID + 54 + + + CF$UID + 48 + + + CF$UID + 10 + + + CF$UID + 22 + + + + + $class + + CF$UID + 4 + + NSClassName + + CF$UID + 85 + + + NSApplication + + $classes + + NSArray + NSObject + + $classname + NSArray + + + $class + + CF$UID + 86 + + NS.objects + + + CF$UID + 54 + + + CF$UID + 2 + + + CF$UID + 48 + + + CF$UID + 2 + + + CF$UID + 18 + + + CF$UID + 10 + + + + + $class + + CF$UID + 86 + + NS.objects + + + CF$UID + 2 + + + CF$UID + 18 + + + CF$UID + 84 + + + CF$UID + 54 + + + CF$UID + 48 + + + CF$UID + 10 + + + CF$UID + 22 + + + + + $class + + CF$UID + 86 + + NS.objects + + + CF$UID + 90 + + + CF$UID + 91 + + + CF$UID + 92 + + + CF$UID + 93 + + + CF$UID + 94 + + + CF$UID + 95 + + + CF$UID + 96 + + + + File's Owner + Scroll View + Application + Content View + Window + Outline View + Table Column + + $class + + CF$UID + 86 + + NS.objects + + + + $class + + CF$UID + 86 + + NS.objects + + + + $class + + CF$UID + 86 + + NS.objects + + + CF$UID + 84 + + + CF$UID + 22 + + + CF$UID + 54 + + + CF$UID + 48 + + + CF$UID + 10 + + + CF$UID + 18 + + + CF$UID + 81 + + + CF$UID + 47 + + + CF$UID + 9 + + + CF$UID + 2 + + + + + $class + + CF$UID + 86 + + NS.objects + + + CF$UID + 101 + + + CF$UID + 102 + + + CF$UID + 103 + + + CF$UID + 104 + + + CF$UID + 105 + + + CF$UID + 106 + + + CF$UID + 107 + + + CF$UID + 108 + + + CF$UID + 109 + + + CF$UID + 110 + + + + -3 + 8 + 6 + 5 + 10 + 9 + 12 + 13 + 14 + 1 + + $class + + CF$UID + 42 + + NS.objects + + + + $class + + CF$UID + 86 + + NS.objects + + + + $class + + CF$UID + 86 + + NS.objects + + + + $classes + + NSIBObjectData + NSObject + + $classname + NSIBObjectData + + + $top + + IB.objectdata + + CF$UID + 1 + + + $version + 100000 + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/displaydoc.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/displaydoc.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/displaydoc.nib/classes.nib (revision 8058) @@ -0,0 +1,11 @@ +{ + IBClasses = ( + { + CLASS = DisplayDocument; + LANGUAGE = ObjC; + OUTLETS = {textView = NSTextView; }; + SUPERCLASS = NSDocument; + } + ); + IBVersion = 1; +} Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/displaydoc.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/displaydoc.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/displaydoc.nib/info.nib (revision 8058) @@ -0,0 +1,18 @@ + + + + + IBDocumentLocation + 152 222 356 240 0 0 1280 1002 + IBFramework Version + 446.1 + IBOldestOS + 5 + IBSystem Version + 8P135 + IBUsesTextArchiving + + targetFramework + IBCocoaFramework + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/preferences.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/preferences.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/preferences.nib/classes.nib (revision 8058) @@ -0,0 +1,49 @@ + + + + + IBClasses + + + ACTIONS + + selectCCLDirectory + id + showFontPanel + id + + CLASS + PreferencesWindowController + LANGUAGE + ObjC + OUTLETS + + appearancePrefs + id + cclPathButton + id + documentationPrefs + id + editorTabViewItem + id + encodingsPrefs + id + generalPrefs + id + hyperspecURLButton + id + listenerFontName + id + listenerTabViewItem + id + tabView + id + window + id + + + + IBVersion + 1 + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/preferences.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/preferences.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/preferences.nib/info.nib (revision 8058) @@ -0,0 +1,18 @@ + + + + + IBFramework Version + 629 + IBOldestOS + 5 + IBOpenObjects + + 1501086 + + IBSystem Version + 9B18 + targetFramework + IBCocoaFramework + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/processes.nib/classes.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/processes.nib/classes.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/processes.nib/classes.nib (revision 8058) @@ -0,0 +1,39 @@ + + + + + IBClasses + + + ACTIONS + + killSelectedProcess + id + refresh + id + + CLASS + ProcessesWindowController + LANGUAGE + ObjC + OUTLETS + + tableView + NSTableView + + SUPERCLASS + NSWindowController + + + CLASS + FirstResponder + LANGUAGE + ObjC + SUPERCLASS + NSObject + + + IBVersion + 1 + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/processes.nib/info.nib =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/processes.nib/info.nib (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/English.lproj/processes.nib/info.nib (revision 8058) @@ -0,0 +1,16 @@ + + + + + IBFramework Version + 628 + IBOldestOS + 4 + IBOpenObjects + + IBSystem Version + 9A559 + targetFramework + IBCocoaFramework + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/Help/cocoa-notes.html =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/Help/cocoa-notes.html (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/Help/cocoa-notes.html (revision 8058) @@ -0,0 +1,109 @@ + + + + The (preliminary) Cocoa-based development environment for OpenMCL + + + +

The (still preliminary) Cocoa-based development environment for OpenMCL

+

General information

+

+ The OpenMCL Cocoa demo's been around for over a year; a variety + of things have kept it from moving forward: +

+
    +
  1. +

    + It was difficult (in some cases, impossible) to get Cocoa's + runtime system and OpenMCL's cooperative threads to interact + reasonably. +

    +
    2. +
  2. +

    + The demo code was written using a set of reader macros and + other constructs that made it possible to sort of embed + Objective-C like code in lisp. (It was actually a bit worse + than writing Objective-C code, since there was absolutely + nothing in the way of compile-time type- or sanity-checking + going on; the code was all effectively written at the lowest + level of OpenMCL's ffi. +

    +

    + The code's (almost ...) all rewritten using a Lisp-to-ObjC + bridge package developed and contributed by Randall Beer. + The bridge offers a lot of features that make Cocoa programming + in OpenMCL saner, safer, and Lispier than it had been; it's + a good thing, and seems to be an important step towards + closer integration of CLOS and ObjC. +

    +
    3. +
  3. +

    + There was a proof-of-concept example that showed how it was + possible to save the demo IDE as a double-clickable bundled + application. A lot of the steps involved in that process + had to be performed manually, and the result wasn't too + usable ... +

    +
    4. +
+

+ These issues have been addressed to a large degree; the demo + IDE's still barely usable (neither the editor nor the listener + windows are particularly lisp-aware, a lot of development and + debugging tools are missing, etc.) but I think that the foundation + for building this stuff is significantly stronger than it was. +

+

+ All of this is (obviously) MacOSX-specific. The GNUstep Project is trying to + provide a cross-platform, opensourced version of OPENSTEP (and + therefore a potentially high degree of compatibility with Cocoa.) + It might therefore be possible to port some of this to GNUstep + and Linux; I don't know how much would be involved in that. +

+ +

Random technical issues & to-do list

+ +

Lisp-awareness

+

+ The demo IDE's listener and editor windows are slightly + customized versions of Cocoa's NSTextView class; the underlying + editor buffers are accessed as "attributed strings". There's no + support for lisp-syntax-aware navigation in NSTextView buffers, + and adding that support at the "attributed string" level would + seem to be a tedious, error-prone process. +

+

+ I think that it'll be possible to effectively replace the + Cocoa text system's buffering mechanism with Lisp data structures + (e.g., PHemlock buffers), and continue to use the Cocoa text + system for display, scrolling, selection, and raw event handling. +

+ +

Modularity

+

+ There's code in the demo IDE that's very specific to the IDE + application itself; some other code probably needs to be + in any (hypothetical) OpenMCL-based Cocoa application. This + obviously needs to be refactored a bit. +

+

+ The bundle directory used by the demo IDE ("ccl:OpenMCL.app") + is something that I originally created in ProjectBuilder a + long time ago. It'd be nice (and probably not too hard) + if there was a simple way to create skeletal bundle hierarchys + that could be populated and customized to create other types + of applications, and if the lisp (in various ways) helped + to support this process.) There are obviously lots of things + that could be done here ... +

+ +
+ + +Last modified: Mon Sep 1 19:54:26 MDT 2003 + + + Index: /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/Help/index.html =================================================================== --- /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/Help/index.html (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/ide-contents/Resources/Help/index.html (revision 8058) @@ -0,0 +1,26 @@ + + + + + OpenMCL Help + + + +

OpenMCL Help

+ +

Aren't you glad you waited so long to see this window ?

+ +

The OpenMCL Doc directory is available here. +

+ +

Some notes about the Cocoa-based development environment are + available here. +

+ +
+ + +Last modified: Mon Jun 3 02:18:04 MDT 2002 + + + Index: /branches/experimentation/later/source/cocoa-ide/preferences.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/preferences.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/preferences.lisp (revision 8058) @@ -0,0 +1,286 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates +;;; +;;; How to add a new preference pane: +;;; +;;; 1. Open preferences.nib with IB. Drag a Custom View instance from +;;; the palette. Use the inpector to set its class to PreferencesView. +;;; 2. Inspect File's Owner (which represents an instance of +;;; PreferencesWindowController). Add an outlet for the new +;;; preferences view you just made. Hook up the outlet. You can +;;; add actions here too, if your preferences view will need them. +;;; 3. Add controls to your view, binding them to the defaults controller. +;;; 4. Save the nib file. +;;; 5. In preferences.lisp (this file), edit the defclass form for +;;; preferences-window-controller and add a slot that matches the outlet +;;; you created in step 2. +;;; 6. Edit the toolbar delegate methods to add a toolbar item for your +;;; new preference view. +;;; 7. Implement a #/showFooPrefs: method to swap in the view when +;;; the toolbar item is clicked. (See #/showGeneralPrefs: for an +;;; example. +;;; 8. Implement actions, if needed. + + +(in-package "GUI") + +;;; A view that keeps track of its initial size. +(defclass preferences-view (ns:ns-view) + ((width :accessor width) + (height :accessor height)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/awakeFromNib :void) ((self preferences-view)) + (let* ((frame (#/frame self))) + (setf (width self) (ns-width frame) + (height self) (ns-height frame)))) + +(defclass font-to-name-transformer (ns:ns-value-transformer) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/transformedValueClass :lass) + ((self +font-to-name-transformer)) + ns:ns-string) + +(objc:defmethod (#/allowsReverseTransformation :) + ((self +font-to-name-transformer)) + nil) + +;;; Produce description of NSFont object, e.g., "Monaco 10" +(objc:defmethod #/transformedValue: ((self font-to-name-transformer) value) + (let* ((font (#/unarchiveObjectWithData: ns:ns-unarchiver value)) + (name (#/displayName font)) + (size (float (#/pointSize font) 0.0d0))) + (#/stringWithFormat: ns:ns-string #@"%@ %.0f" :id name :double-float size))) + +(defclass preferences-window-controller (ns:ns-window-controller) + ((tab-view :foreign-type :id :accessor tab-view) + (editor-tab-view-item :foreign-type :id :accessor editor-tab-view-item) + (listener-tab-view-item :foreign-type :id :accessor listener-tab-view-item) + (ccl-path-button :foreign-type :id :accessor ccl-path-button) + (hyperspec-path-button :foreign-type :id :accessor hyperspec-path-button) + (toolbar :foreign-type :id :accessor toolbar) + (general-prefs :foreign-type :id :accessor general-prefs) + (appearance-prefs :foreign-type :id :accessor appearance-prefs) + (documentation-prefs :foreign-type :id :accessor documentation-prefs) + (encodings-prefs :foreign-type :id :accessor encodings-prefs)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/init ((self preferences-window-controller)) + (#/setValueTransformer:forName: ns:ns-value-transformer + (make-instance 'font-to-name-transformer) + #@"FontToName") + + (#/initWithWindowNibName: self #@"preferences") + (#/addObserver:selector:name:object: (#/defaultCenter ns:ns-notification-center) + self + (@selector #/defaultsDidChange:) + #&NSUserDefaultsDidChangeNotification + (#/standardUserDefaults ns:ns-user-defaults)) + + self) + +(objc:defmethod (#/windowDidLoad :void) ((self preferences-window-controller)) + (let* ((window (#/window self))) + (with-slots (toolbar) self + (setf toolbar (make-instance 'ns:ns-toolbar + :with-identifier #@"preferences-window-toolbar")) + (#/setDelegate: toolbar self) + (#/setSelectedItemIdentifier: toolbar #@"appearance") + (#/setToolbar: window toolbar) + ;; for some reason, setting this in IB doesn't work on Tiger/PPC32 + (#/setShowsToolbarButton: window nil) + (#/release toolbar)) + (#/showAppearancePrefs: self +null-ptr+))) + +(objc:defmethod (#/showWindow: :void) ((self preferences-window-controller) + sender) + (#/center (#/window self)) + (call-next-method sender)) + +(objc:defmethod (#/defaultsDidChange: :void) ((self preferences-window-controller) + notification) + (declare (ignore notification)) + (update-cocoa-defaults)) + +(defconstant editor-font-button-tag 1) +(defconstant listener-input-font-button-tag 2) +(defconstant listener-output-font-button-tag 2) + +;;; Ugh. +(defvar *listener-or-editor* nil) + +(objc:defmethod (#/showFontPanel: :void) ((self preferences-window-controller) + sender) + (let* ((tag (#/tag sender)) + (font-manager (#/sharedFontManager ns:ns-font-manager)) + (font nil) + (panel (#/window self))) + (ecase tag + (1 + (setq font *editor-font*) + (setq *listener-or-editor* :editor)) + (2 + (setq font *listener-input-font*) + (setq *listener-or-editor* :listener-input)) + (3 + (setq font *listener-output-font*) + (setq *listener-or-editor* :listener-output))) + (#/makeFirstResponder: panel panel) + (#/setSelectedFont:isMultiple: font-manager font nil) + (#/orderFrontFontPanel: font-manager self))) + +;;; This message is sent to the first responder, which is why +;;; we do the *listener-or-editor* thing. +(objc:defmethod (#/changeFont: :void) ((self preferences-window-controller) + font-manager) + (let* ((defaults (#/standardUserDefaults ns:ns-user-defaults)) + (data nil) + (font nil)) + (ecase *listener-or-editor* + (:listener-input + (setq font (#/convertFont: font-manager *listener-input-font*)) + (unless (%null-ptr-p font) + (setq data (#/archivedDataWithRootObject: ns:ns-archiver font)) + (#/setObject:forKey: defaults data #@"listenerInputFont"))) + (:listener-output + (setq font (#/convertFont: font-manager *listener-output-font*)) + (unless (%null-ptr-p font) + (setq data (#/archivedDataWithRootObject: ns:ns-archiver font)) + (#/setObject:forKey: defaults data #@"listenerOutputFont"))) + (:editor + (setq font (#/convertFont: font-manager *editor-font*)) + (unless (%null-ptr-p font) + (setq data (#/archivedDataWithRootObject: ns:ns-archiver font)) + (#/setObject:forKey: defaults data #@"editorFont")))))) + +(objc:defmethod (#/selectCCLDirectory: :void) ((self preferences-window-controller) + sender) + (declare (ignore sender)) + (let* ((panel (#/openPanel ns:ns-open-panel)) + (dc (#/sharedUserDefaultsController ns:ns-user-defaults-controller)) + (values (#/values dc)) + (key #@"cclDirectory")) + (#/setAllowsMultipleSelection: panel nil) + (#/setCanChooseDirectories: panel t) + (#/setCanChooseFiles: panel nil) + (when (eql (#/runModalForDirectory:file:types: panel + (#/valueForKey: values key) + +null-ptr+ + +null-ptr+) + #$NSOKButton) + ;; #/stringByStandardizingPath seems to strip trailing slashes + (let* ((filename (#/stringByAppendingString: + (#/stringByStandardizingPath + (#/objectAtIndex: (#/filenames panel) 0)) + #@"/"))) + (#/setValue:forKey: values filename key))))) + + +;;; toolbar delegate methods + +(objc:defmethod #/toolbar:itemForItemIdentifier:willBeInsertedIntoToolbar: + ((self preferences-window-controller) + toolbar itemIdentifier (flag :)) + (declare (ignore toolbar)) + (let ((item +null-ptr+)) + (cond + ((#/isEqualToString: itemIdentifier #@"general") + (setf item (make-instance 'ns:ns-toolbar-item + :with-item-identifier itemIdentifier)) + (#/setLabel: item #@"General") + (#/setImage: item (#/imageNamed: ns:ns-image #@"General")) + (#/setTarget: item self) + (#/setAction: item (@selector #/showGeneralPrefs:))) + ((#/isEqualToString: itemIdentifier #@"appearance") + (setf item (make-instance 'ns:ns-toolbar-item + :with-item-identifier itemIdentifier)) + (#/setLabel: item #@"Appearance") + (#/setImage: item (#/imageNamed: ns:ns-image #@"Appearance")) + (#/setTarget: item self) + (#/setAction: item (@selector #/showAppearancePrefs:))) + ((#/isEqualToString: itemIdentifier #@"documentation") + (setf item (make-instance 'ns:ns-toolbar-item + :with-item-identifier itemIdentifier)) + (#/setLabel: item #@"Documentation") + (#/setImage: item (#/imageNamed: ns:ns-image #@"Documentation")) + (#/setTarget: item self) + (#/setAction: item (@selector #/showDocumentationPrefs:))) + ((#/isEqualToString: itemIdentifier #@"encodings") + (setf item (make-instance 'ns:ns-toolbar-item + :with-item-identifier itemIdentifier)) + (#/setLabel: item #@"Encodings") + (#/setImage: item (#/imageNamed: ns:ns-image #@"Encodings")) + (#/setTarget: item self) + (#/setAction: item (@selector #/showEncodingsPrefs:)))) + (#/autorelease item))) + +(objc:defmethod #/toolbarDefaultItemIdentifiers: + ((self preferences-window-controller) toolbar) + (declare (ignore toolbar)) + (#/arrayWithObjects: ns:ns-array #@"general" + #@"appearance" + #@"documentation" + #@"encodings" + +null-ptr+)) ; don't even think about putting nil here + +(objc:defmethod #/toolbarAllowedItemIdentifiers: + ((self preferences-window-controller) toolbar) + (declare (ignore toolbar)) + (#/arrayWithObjects: ns:ns-array #@"general" + #@"appearance" + #@"documentation" + #@"encodings" + +null-ptr+)) + +(objc:defmethod #/toolbarSelectableItemIdentifiers: + ((self preferences-window-controller) toolbar) + (declare (ignore toolbar)) + (#/arrayWithObjects: ns:ns-array #@"general" + #@"appearance" + #@"documentation" + #@"encodings" + +null-ptr+)) + +(defun switch-content-view (window view) + (#/setContentView: window view) + (let* ((frame (#/frame window)) + (min-size (#/minSize window)) + (new-frame nil) + (content-rect (#/contentRectForFrameRect: window frame)) + (dy (- (height view) + (ns-height content-rect)))) + (decf (ns:ns-rect-y content-rect) dy) + (incf (ns:ns-rect-height content-rect) dy) + (setf (ns:ns-rect-width content-rect) (max (width view) + (ns:ns-size-width min-size))) + (setq new-frame (#/frameRectForContentRect: window content-rect)) + (#/setFrame:display:animate: window new-frame t t))) + +;;; toolbar actions + +(objc:defmethod (#/showGeneralPrefs: :void) ((self preferences-window-controller) + sender) + (declare (ignore sender)) + (#/setTitle: (#/window self) #@"General") + (switch-content-view (#/window self) (general-prefs self))) + +(objc:defmethod (#/showAppearancePrefs: :void) ((self preferences-window-controller) + sender) + (declare (ignore sender)) + (#/setTitle: (#/window self) #@"Appearance") + (switch-content-view (#/window self) (appearance-prefs self))) + +(objc:defmethod (#/showDocumentationPrefs: :void) ((self preferences-window-controller) + sender) + (declare (ignore sender)) + (#/setTitle: (#/window self) #@"Documentation") + (switch-content-view (#/window self) (documentation-prefs self))) + +(objc:defmethod (#/showEncodingsPrefs: :void) ((self preferences-window-controller) + sender) + (declare (ignore sender)) + (#/setTitle: (#/window self) #@"Encodings") + (switch-content-view (#/window self) (encodings-prefs self))) Index: /branches/experimentation/later/source/cocoa-ide/processes-window.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/processes-window.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/processes-window.lisp (revision 8058) @@ -0,0 +1,150 @@ +;;;-*-Mode: LISP; Package: GUI -*- +;;; +;;; Copyright (C) 2007 Clozure Associates + +(in-package "GUI") + +(defclass processes-window-controller (ns:ns-window-controller) + ((table-view :foreign-type :id :reader processes-window-table-view) + (toolbar :foreign-type :id :accessor processes-window-toolbar) + (processes :accessor processes-window-processes)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/init ((self processes-window-controller)) + (setf (slot-value self 'processes) (coerce (all-processes) 'vector)) + (#/initWithWindowNibName: self #@"processes")) + +(objc:defmethod (#/awakeFromNib :void) ((self processes-window-controller)) + (with-slots (toolbar table-view) self + (#/setDoubleAction: table-view (@selector #/inspectSelectedProcess:)) + (setf toolbar (make-instance 'ns:ns-toolbar + :with-identifier #@"processes-window-toolbar")) + (#/setDisplayMode: toolbar #$NSToolbarDisplayModeLabelOnly) + (#/setDelegate: toolbar self) + (#/setToolbar: (#/window self) toolbar) + (#/release toolbar))) + + + +;;; toolbar delegate methods + +(objc:defmethod #/toolbar:itemForItemIdentifier:willBeInsertedIntoToolbar: + ((self processes-window-controller) + toolbar itemIdentifier (flag :)) + (declare (ignore toolbar)) + (let ((item +null-ptr+)) + (cond + ((#/isEqualToString: itemIdentifier #@"kill") + (setf item (make-instance 'ns:ns-toolbar-item :with-item-identifier itemIdentifier)) + (#/setLabel: item #@"Kill") + (#/setTarget: item self) + (#/setAction: item (@selector #/killSelectedProcess:))) + ((#/isEqualToString: itemIdentifier #@"refresh") + (setf item (make-instance 'ns:ns-toolbar-item :with-item-identifier itemIdentifier)) + (#/setLabel: item #@"Refresh") + (#/setTarget: item self) + (#/setAction: item (@selector #/refresh:)))) + (#/autorelease item))) + +(objc:defmethod #/toolbarDefaultItemIdentifiers: + ((self processes-window-controller) toolbar) + (declare (ignore toolbar)) + (#/arrayWithObjects: ns:ns-array #@"kill" + #&NSToolbarFlexibleSpaceItemIdentifier + #@"refresh" + +null-ptr+)) ; don't even think about putting nil here + +(objc:defmethod #/toolbarAllowedItemIdentifiers: + ((self processes-window-controller) toolbar) + (declare (ignore toolbar)) + (#/arrayWithObjects: ns:ns-array #@"refresh" + #&NSToolbarFlexibleSpaceItemIdentifier + #@"refresh" + +null-ptr+)) + +(objc:defmethod (#/validateToolbarItem: :) + ((self processes-window-controller) item) + (let ((enable #$NO)) + (cond + ((#/isEqualToString: (#/itemIdentifier item) #@"kill") + (when (plusp (#/numberOfSelectedRows (processes-window-table-view self))) + (setf enable #$YES))) + ((#/isEqualToString: (#/itemIdentifier item) #@"refresh") + (setf enable #$YES))) + enable)) + +;;; actions + +(objc:defmethod (#/refresh: :void) ((self processes-window-controller) sender) + (declare (ignore sender)) + (setf (slot-value self 'processes) + (coerce (all-processes) 'vector)) + (#/reloadData (processes-window-table-view self))) + +(objc:defmethod (#/killSelectedProcess: :void) ((self processes-window-controller) sender) + (declare (ignore sender)) + (let ((row (#/selectedRow (processes-window-table-view self))) + (p nil)) + (unless (minusp row) + (setq p (svref (processes-window-processes self) row)) + (process-kill p) + (#/refresh: self self)))) + +(objc:defmethod (#/inspectSelectedProcess: :void) ((self processes-window-controller) sender) + (declare (ignore sender)) + (with-slots (table-view processes) self + (let* ((row (#/clickedRow table-view)) + (p nil)) + (unless (minusp row) + (setq p (svref processes row)) + (cinspect p) + (#/refresh: self self))))) + +;;; table view delegate methods + +(objc:defmethod (#/tableViewSelectionDidChange: :void) + ((self processes-window-controller) notification) + (declare (ignore notification)) + (with-slots (toolbar) self + ;; Usually, we'd just update the one item in question, + ;; but since there aren't many items in the toolbar, + ;; just be lazy. + (#/validateVisibleItems toolbar))) + +;;; table view data source methods + +(objc:defmethod (#/numberOfRowsInTableView: :nteger) + ((self processes-window-controller) + table-view) + (declare (ignore table-view)) + (length (slot-value self 'processes))) + +(objc:defmethod #/tableView:objectValueForTableColumn:row: + ((self processes-window-controller) + table-view + table-column + (row :nteger)) + (declare (ignore table-view)) + (with-slots (processes) self + (let ((fn nil) + (p (svref processes row))) + (cond + ((#/isEqualToString: (#/identifier table-column) #@"name") + (setq fn #'process-name)) + ((#/isEqualToString: (#/identifier table-column) #@"state") + (setq fn #'process-whostate)) + ((#/isEqualToString: (#/identifier table-column) #@"thread") + (setq fn #'process-thread)) + ((#/isEqualToString: (#/identifier table-column) #@"suspend count") + (setq fn #'process-suspend-count))) + (if (and p fn) + (#/autorelease (%make-nsstring (format nil "~a" (funcall fn p)))) + +null-ptr+)))) + +#| +(in-package "CCL") +(load "~rme/processes-window") +(setf *pwc* (make-instance 'processes-window-controller)) +(#/showWindow: *pwc* *pwc*) + +|# Index: /branches/experimentation/later/source/cocoa-ide/start.lisp =================================================================== --- /branches/experimentation/later/source/cocoa-ide/start.lisp (revision 8058) +++ /branches/experimentation/later/source/cocoa-ide/start.lisp (revision 8058) @@ -0,0 +1,138 @@ +(in-package "GUI") + +(defparameter *standalone-cocoa-ide* nil) + +(if (< #&NSAppKitVersionNumber 824) + (error "This application requires features introduced in OSX 10.4.")) + +(def-cocoa-default *ccl-directory* :string "" nil #'(lambda (old new) + (when (equal new "") (setq new nil)) + (unless (and new (equal old new)) + (init-interfaces-root) + (ccl::replace-base-translation "ccl:" + (or new (find-ccl-directory)))))) + +;; If there are interfaces inside the bundle, use those rather than the ones +;; in CCL:, since they're more likely to be valid. CCL: could be some random +;; old sources we're just using for meta-. +(defun init-interfaces-root () + (let* ((subpath (ccl::cdb-subdirectory-path)) + (path (pathname-directory (ccl::ccl-directory)))) + (when (and *standalone-cocoa-ide* + (equalp (last path 2) '("Contents" "MacOS"))) + (setq path (butlast path)) + (when (or (probe-file (make-pathname :directory (append path subpath))) + (probe-file (make-pathname :directory (append (setq path `(,@path "Resources")) subpath)))) + (setq ccl::*interfaces-root* (make-pathname :directory path)))))) + +(defun find-ccl-directory () + (let* ((path (ccl::ccl-directory)) + (dir (pathname-directory path))) + (if (equalp (last dir 2) '("Contents" "MacOS")) + (make-pathname :directory (butlast dir 3)) + path))) + +(defmethod ccl::ui-object-do-operation ((o ns:ns-application) + operation + &rest args) + (declare (ignore operation args)) + ;; Do nothing. Would it be better to warn and/or log this ? + ) + +(defmethod ccl::ui-object-do-operation ((o ns:ns-application) + (operation (eql :note-current-package)) + &rest args) + (ui-object-note-package o (car args))) + +(defmethod ccl::ui-object-do-operation ((o ns:ns-application) + (operation (eql :eval-selection)) + &rest args) + (ui-object-eval-selection o (car args))) + +(defmethod ccl::ui-object-do-operation ((o ns:ns-application) + (operation (eql :enter-backtrace-context)) + &rest args) + (ui-object-enter-backtrace-context o (car args))) + +(defmethod ccl::ui-object-do-operation ((o ns:ns-application) + (operation (eql :exit-backtrace-context)) + &rest args) + (ui-object-exit-backtrace-context o (car args))) + + +;;; Support for saving a stand-alone IDE + + +(defclass cocoa-application (application) + ()) + +;; Is this defined on application (rather than cocoa-application) for a reason? +(defmethod ccl::application-error ((a application) condition error-pointer) + (ccl::break-loop-handle-error condition error-pointer)) + + +;;; If we're launched via the Finder, the only argument we'll +;;; get is of the form -psnXXXXXX. That's meaningless to us; +;;; it's easier to pretend that we didn't get any arguments. +;;; (If it seems like some of this needs to be thought out a +;;; bit better ... I'd tend to agree.) +(defmethod ccl::parse-application-arguments ((a cocoa-application)) + (values nil nil nil nil)) + +(defmethod toplevel-function ((a cocoa-application) init-file) + (declare (ignore init-file)) + (when (< #&NSAppKitVersionNumber 824) + (#_NSLog #@"This application requires features introduced in OSX 10.4.") + (#_ _exit -1)) + (setq *standalone-cocoa-ide* t) + ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to + ;; actual bundle path where started up. + (start-cocoa-application)) + + + ;;; The saved image will be an instance of COCOA-APPLICATION (mostly + ;;; so that it'll ignore its argument list.) When it starts up, it'll + ;;; run the Cocoa event loop in the cocoa event process. + ;;; If you use an init file ("home:ccl-init"), it'll be loaded + ;;; in an environment in which *STANDARD-INPUT* always generates EOF + ;;; and where output and error streams are directed to the OSX console + ;;; (see below). If that causes problems, you may want to suppress + ;;; the loading of your init file (via an :INIT-FILE nil arg to + ;;; the call to SAVE-APPLICATION, below.) + +(defun build-ide (bundle-path) + (setq bundle-path (ensure-directory-pathname bundle-path)) + + ;; The bundle is expected to exists, we'll just add the executable into it. + (assert (probe-file bundle-path)) + + ;; Wait until we're sure that the Cocoa event loop has started. + (wait-on-semaphore *cocoa-application-finished-launching*) + + (require :easygui) + + (ccl::maybe-map-objc-classes t) + (let* ((missing ())) + (ccl::do-interface-dirs (d) + (ccl::cdb-enumerate-keys + (ccl::db-objc-classes d) + (lambda (name) + (let* ((class (ccl::lookup-objc-class name nil))) + (unless (ccl::objc-class-id class) (push name missing)))))) + (when missing + (break "ObjC classes ~{~&~a~} are declared but not defined." missing))) + + (ccl::touch bundle-path) + + (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil + :defaults (merge-pathnames ";Contents;MacOS;" bundle-path)))) + (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path)) + (force-output *error-output*) + (ensure-directories-exist image-file) + (save-application image-file + :prepend-kernel t + :application-class 'cocoa-application))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(start-cocoa-application) Index: /branches/experimentation/later/source/compiler/.cvsignore =================================================================== --- /branches/experimentation/later/source/compiler/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/compiler/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/compiler/PPC/.cvsignore =================================================================== --- /branches/experimentation/later/source/compiler/PPC/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/compiler/PPC/PPC32/.cvsignore =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC32/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC32/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-arch.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-arch.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-arch.lisp (revision 8058) @@ -0,0 +1,925 @@ +;;;-*- Mode: Lisp; Package: (PPC32 :use CL) -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;; This file matches "ccl:pmcl;constants.h" & "ccl:pmcl;constants.s" + +(defpackage "PPC32" + (:use "CL") + #+ppc32-target + (:nicknames "TARGET")) + +(in-package "PPC32") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "PPC-ARCH") + + +(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-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)) + +(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)))) + + +) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant rcontext 13) +(defconstant nbits-in-word 32) +(defconstant least-significant-bit 31) +(defconstant nbits-in-byte 8) +(defconstant ntagbits 3) ; But non-header objects only use 2 +(defconstant nlisptagbits 2) +(defconstant nfixnumtagbits 2) ; See ? +(defconstant num-subtag-bits 8) ; tag part of header is 8 bits wide +(defconstant fixnumshift nfixnumtagbits) +(defconstant fixnum-shift fixnumshift) ; A pet name for it. +(defconstant fulltagmask (1- (ash 1 ntagbits))) ; Only needed by GC/very low-level code +(defconstant full-tag-mask fulltagmask) +(defconstant tagmask (1- (ash 1 nlisptagbits))) +(defconstant tag-mask tagmask) +(defconstant fixnummask (1- (ash 1 nfixnumtagbits))) +(defconstant fixnum-mask fixnummask) +(defconstant subtag-mask (1- (ash 1 num-subtag-bits))) +(defconstant ncharcodebits 24) ; only the low 8 bits are used, currently +(defconstant charcode-shift (- nbits-in-word ncharcodebits)) +(defconstant word-shift 2) +(defconstant word-size-in-bytes 4) +(defconstant node-size 4) +(defconstant dnode-size 8) +(defconstant dnode-align-bits 3) +(defconstant dnode-shift dnode-align-bits) +(defconstant bitmap-shift 5) + +(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))))) + +;; PPC-32 stuff and tags. + +;; Tags. +;; There are two-bit tags and three-bit tags. +;; A FULLTAG is the value of the low three bits of a tagged object. +;; A TAG is the value of the low two bits of a tagged object. +;; A TYPECODE is either a TAG or the value of a "tag-misc" object's header-byte. + +;; There are 4 primary TAG values. Any object which lisp can "see" can be classified +;; by its TAG. (Some headers have FULLTAGS that are congruent modulo 4 with the +;; TAGS of other objects, but lisp can't "see" headers.) +(ccl::defenum () + tag-fixnum ; All fixnums, whether odd or even + tag-list ; Conses and NIL + tag-misc ; Heap-consed objects other than lists: vectors, symbols, functions, floats ... + tag-imm ; Immediate-objects: characters, UNBOUND, other markers. +) + +;;; And there are 8 FULLTAG values. Note that NIL has its own FULLTAG (congruent mod 4 to tag-list), +;;; that FULLTAG-MISC is > 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. +(ccl::defenum () + fulltag-even-fixnum ; I suppose EVENP/ODDP might care; nothing else does. + fulltag-cons ; a real (non-null) cons. Shares TAG with fulltag-nil. + fulltag-nodeheader ; Header of heap-allocated object that contains lisp-object pointers + fulltag-imm ; a "real" immediate object. Shares TAG with fulltag-immheader. + fulltag-odd-fixnum ; + fulltag-nil ; NIL and nothing but. (Note that there's still a hidden NILSYM.) + fulltag-misc ; Pointer "real" tag-misc object. Shares TAG with fulltag-nodeheader. + fulltag-immheader ; Header of heap-allocated object that contains unboxed data. +) + +(defconstant misc-header-offset (- fulltag-misc)) +(defconstant misc-subtag-offset (+ misc-header-offset 3)) +(defconstant misc-data-offset (+ misc-header-offset 4)) +(defconstant misc-dfloat-offset (+ misc-header-offset 8)) + + + + + + +(defconstant nil-value #x00003015) +;;; 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. + +(defconstant t-offset (+ 8 (- 8 fulltag-nil) fulltag-misc)) +(assert (and (logbitp 0 t-offset) (= (logcount t-offset) 2))) + +;;; 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) ; "SINGLE" float, aka short-float in the new order. +(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) + + +;;(define-imm-subtag simple-base-string 27) +(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 vectorH 20) +(define-node-subtag arrayH 19) +(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) + +;;; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag)) +;;; for various immediate/node object types. + +(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 code-vector 5) +(define-imm-subtag creole-object 6) +(define-imm-subtag xcode-vector 7) ; code-vector for cross-development + +(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)) + +(define-subtag character fulltag-imm 9) +(define-subtag vsp-protect fulltag-imm 7) +(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 go-tag fulltag-imm 12) +(define-subtag block-tag fulltag-imm 24) +(define-subtag no-thread-local-binding fulltag-imm 30) +(define-subtag unbound fulltag-imm 6) +(defconstant unbound-marker subtag-unbound) +(defconstant undefined unbound-marker) + + +(defconstant max-64-bit-constant-index (ash (+ #x7fff ppc32::misc-dfloat-offset) -3)) +(defconstant max-32-bit-constant-index (ash (+ #x7fff ppc32::misc-data-offset) -2)) +(defconstant max-16-bit-constant-index (ash (+ #x7fff ppc32::misc-data-offset) -1)) +(defconstant max-8-bit-constant-index (+ #x7fff ppc32::misc-data-offset)) +(defconstant max-1-bit-constant-index (ash (+ #x7fff ppc32::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. +(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-low) + +(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 +) + +;;; Catch frames go on the tstack; they point to a minimal lisp-frame +;;; on the cstack. (The catch/unwind-protect PC is on the cstack, where +;;; the GC expects to find it.) +(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 + csp ; pointer to control stack + db-link ; value of dynamic-binding link on thread entry. + save-save7 ; saved registers + save-save6 + save-save5 + save-save4 + save-save3 + save-save2 + save-save1 + save-save0 + xframe ; exception-frame link + tsp-segment ; mostly padding, for now. +) + +(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) + +;;; The kernel uses these (rather generically named) structures +;;; to keep track of various memory regions it (or the lisp) is +;;; interested in. +;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp" +;;; matches this. + +(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) + +(defconstant tcr-bias 0) + +(define-storage-layout tcr (- tcr-bias) + prev ; in doubly-linked list + next ; in doubly-linked list + lisp-fpscr-high + lisp-fpscr-low + db-link ; special binding chain head + catch-top ; top catch frame + save-vsp ; VSP when in foreign code + save-tsp ; TSP when in foreign code + cs-area ; cstack area pointer + vs-area ; vstack area pointer + ts-area ; tstack area pointer + cs-limit ; cstack overflow limit + total-bytes-allocated-high + total-bytes-allocated-low + 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 + safe-ref-address +) + +(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 + ) + +;;; For the eabi port: mark this stack frame as Lisp's (since EABI +;;; foreign frames can be the same size as a lisp frame.) + + +(ppc32::define-storage-layout lisp-frame 0 + backlink + savefn + savelr + savevsp +) + +(ppc32::define-storage-layout c-frame 0 + backlink + crsave + savelr + unused-1 + unused-2 + savetoc + param0 + param1 + param2 + param3 + param4 + param5 + param6 + param7 +) + +(defconstant c-frame.minsize c-frame.size) + +;;; .SPeabi-ff-call "shrinks" this frame after loading the GPRs. +(ppc32::define-storage-layout eabi-c-frame 0 + backlink + savelr + param0 + param1 + param2 + param3 + param4 + param5 + param6 + param7 +) + +(defconstant eabi-c-frame.minsize eabi-c-frame.size) + +(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) +(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) + +(defconstant yield-syscall + #+darwinppc-target -60 + #+linuxppc-target #$__NR_sched_yield) +) + + + + +(defun %kernel-global (sym) + (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=))) + (if pos + (- (+ fulltag-nil (* (1+ pos) 4))) + (error "Unknown kernel global : ~s ." sym)))) + +(defmacro kernel-global (sym) + (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=))) + (if pos + (- (+ fulltag-nil (* (1+ pos) 4))) + (error "Unknown kernel global : ~s ." sym)))) + +;;; The kernel imports things that are defined in various other +;;; libraries for us. The objects in question are generally +;;; fixnum-tagged; the entries in the "kernel-imports" vector are 4 +;;; bytes apart. +(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4) + fd-setsize-bytes + do-fd-set + do-fd-clr + do-fd-is-set + do-fd-zero + MakeDataExecutable + GetSharedLibrary + FindSymbol + malloc + free + allocate_tstack + allocate_vstack + register_cstack + raise-thread-interrupt + 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 +) + +(defmacro nrs-offset (name) + (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq))) + (if pos (+ t-offset (* pos symbol.size))))) + + +(defconstant reservation-discharge #x2004) + + + +(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 *ppc32-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 ) + (:code-vector . ,subtag-code-vector) + (: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 ppc32-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 ppc32-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 *ppc32-target-arch* + (arch::make-target-arch :name :ppc32 + :lisp-node-size 4 + :nil-value nil-value + :fixnum-shift fixnumshift + :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift)))) + :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift)))) + :misc-data-offset misc-data-offset + :misc-dfloat-offset misc-dfloat-offset + :nbits-in-word 32 + :ntagbits 3 + :nlisptagbits 2 + :uvector-subtags *ppc32-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 2 + :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 + #'ppc32-array-type-name-from-ctype + :package-name "PPC32" + :t-offset t-offset + :array-data-size-function #'ppc32-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 ppc::*ppc-subprims-base* + :subprims-shift ppc::*ppc-subprims-shift* + :subprims-table ppc::*ppc-subprims* + :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-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-nil + :symbol-tag subtag-symbol + :symbol-tag-is-subtag t + :function-tag subtag-function + :function-tag-is-subtag t + :big-endian t + :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 defppc32archmacro (name lambda-list &body body) + `(arch::defarchmacro :ppc32 ,name ,lambda-list ,@body)) + +(defppc32archmacro ccl::%make-sfloat () + `(ccl::%alloc-misc ppc32::single-float.element-count ppc32::subtag-single-float)) + +(defppc32archmacro ccl::%make-dfloat () + `(ccl::%alloc-misc ppc32::double-float.element-count ppc32::subtag-double-float)) + +(defppc32archmacro ccl::%numerator (x) + `(ccl::%svref ,x ppc32::ratio.numer-cell)) + +(defppc32archmacro ccl::%denominator (x) + `(ccl::%svref ,x ppc32::ratio.denom-cell)) + +(defppc32archmacro ccl::%realpart (x) + `(ccl::%svref ,x ppc32::complex.realpart-cell)) + +(defppc32archmacro ccl::%imagpart (x) + `(ccl::%svref ,x ppc32::complex.imagpart-cell)) + +;;; +(defppc32archmacro ccl::%get-single-float-from-double-ptr (ptr offset) + `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset) + (ccl::%alloc-misc 1 ppc32::subtag-single-float))) + +(defppc32archmacro ccl::codevec-header-p (word) + `(eql ppc32::subtag-code-vector + (logand ,word ppc32::subtag-mask))) + +(defppc32archmacro ccl::immediate-p-macro (thing) + (let* ((tag (gensym))) + `(let* ((,tag (ccl::lisptag ,thing))) + (declare (fixnum ,tag)) + (or (= ,tag ppc32::tag-fixnum) + (= ,tag ppc32::tag-imm))))) + +(defppc32archmacro ccl::hashed-by-identity (thing) + (let* ((typecode (gensym))) + `(let* ((,typecode (ccl::typecode ,thing))) + (declare (fixnum ,typecode)) + (or + (= ,typecode ppc32::tag-fixnum) + (= ,typecode ppc32::tag-imm) + (= ,typecode ppc32::subtag-symbol) + (= ,typecode ppc32::subtag-instance))))) + +;;; +(defppc32archmacro ccl::%get-kernel-global (name) + `(ccl::%fixnum-ref 0 (+ ppc32::nil-value + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name))))) + +(defppc32archmacro ccl::%get-kernel-global-ptr (name dest) + `(ccl::%setf-macptr + ,dest + (ccl::%fixnum-ref-macptr 0 (+ ppc32::nil-value + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name)))))) + +(defppc32archmacro ccl::%target-kernel-global (name) + `(ppc32::%kernel-global ,name)) + +(defppc32archmacro ccl::lfun-vector (fn) + fn) + +(defppc32archmacro ccl::lfun-vector-lfun (lfv) + lfv) + +(defppc32archmacro ccl::area-code () + area.code) + +(defppc32archmacro ccl::area-succ () + area.succ) + +(defppc32archmacro ccl::nth-immediate (f i) + `(ccl::%svref ,f ,i)) + +(defppc32archmacro ccl::set-nth-immediate (f i new) + `(setf (ccl::%svref ,f ,i) ,new)) + +(defppc32archmacro ccl::symptr->symvector (s) + s) + +(defppc32archmacro ccl::symvector->symptr (s) + s) + +(defppc32archmacro ccl::function-to-function-vector (f) + f) + +(defppc32archmacro ccl::function-vector-to-function (v) + v) + +(defppc32archmacro ccl::with-ffcall-results ((buf) &body body) + (let* ((size (+ (* 8 4) (* 31 8)))) + `(%stack-block ((,buf ,size)) + ,@body))) + +(provide "PPC32-ARCH") Index: /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-backend.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-backend.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-backend.lisp (revision 8058) @@ -0,0 +1,154 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPCENV") + (require "PPC32-ARCH")) + + + + + +(defvar *ppc32-vinsn-templates* (make-hash-table :test #'eq)) + + + + +(defvar *known-ppc32-backends* ()) + + +#+linuxppc-target +(defvar *linuxppc32-backend* + (make-backend :lookup-opcode #'lookup-ppc-opcode + :lookup-macro #'ppc::ppc-macro-function + :lap-opcodes ppc::*ppc-opcodes* + :define-vinsn 'define-ppc-vinsn + :platform-syscall-mask (logior platform-os-linux platform-cpu-ppc) + :p2-dispatch *ppc2-specials* + :p2-vinsn-templates *ppc32-vinsn-templates* + :p2-template-hash-name '*ppc32-vinsn-templates* + :p2-compile 'ppc2-compile + :target-specific-features + '(:powerpc :ppc-target :eabi-target :linux-target :linuxppc-target :ppc32-target :32-bit-target :big-endian-target) + :target-fasl-pathname (make-pathname :type "pfsl") + :target-platform (logior platform-word-size-32 + platform-cpu-ppc + platform-os-linux) + :target-os :linuxppc + :name :linuxppc32 + :target-arch-name :ppc32 + :target-foreign-type-data nil + :target-arch ppc32::*ppc32-target-arch*)) + + +#+darwinppc-target +(defvar *darwinppc32-backend* + (make-backend :lookup-opcode #'lookup-ppc-opcode + :lookup-macro #'ppc::ppc-macro-function + :lap-opcodes ppc::*ppc-opcodes* + :define-vinsn 'define-ppc-vinsn + :platform-syscall-mask (logior platform-os-darwin platform-cpu-ppc) + :p2-dispatch *ppc2-specials* + :p2-vinsn-templates *ppc32-vinsn-templates* + :p2-template-hash-name '*ppc32-vinsn-templates* + :p2-compile 'ppc2-compile + :target-specific-features + '(:powerpc :ppc-target :darwin-target :darwinppc-target :ppc32-target :32-bit-target :big-endian-target) + :target-fasl-pathname (make-pathname :type "dfsl") + :target-platform (logior platform-word-size-32 + platform-cpu-ppc + platform-os-darwin) + :target-os :darwinppc + :name :darwinppc32 + :target-arch-name :ppc32 + :target-foreign-type-data nil + :target-arch ppc32::*ppc32-target-arch*)) + +#+linuxppc-target +(pushnew *linuxppc32-backend* *known-ppc32-backends* :key #'backend-name) + + +#+darwinppc-target +(pushnew *darwinppc32-backend* *known-ppc32-backends* :key #'backend-name) + +(defvar *ppc32-backend* (car *known-ppc32-backends*)) + +(defun fixup-ppc32-backend () + (dolist (b *known-ppc32-backends*) + (setf (backend-lap-opcodes b) ppc::*ppc-opcodes* + (backend-p2-dispatch b) *ppc2-specials* + (backend-p2-vinsn-templates b) *ppc32-vinsn-templates*) + (or (backend-lap-macros b) (setf (backend-lap-macros b) + (make-hash-table :test #'equalp))))) + + + +(fixup-ppc32-backend) + +#+ppc32-target +(setq *host-backend* *ppc32-backend* *target-backend* *ppc32-backend*) +#-ppc32-target +(unless (backend-target-foreign-type-data *ppc32-backend*) + (let* ((ftd (make-ftd + :interface-db-directory + #+darwinppc-target "ccl:darwin-headers;" + #+linuxppc-target "ccl:headers;" + :interface-package-name + #+darwinppc-target "DARWIN32" + #+linuxppc-target "LINUX32" + :attributes + #+darwinppc-target + '(:signed-char t + :struct-by-value t + :prepend-underscores t + :bits-per-word 32 + :poweropen-alignment t) + #+linuxppc-target + '(:bits-per-word 32) + :ff-call-expand-function + #+linuxppc-target + 'linux32::expand-ff-call + #+darwinppc-target + 'darwin32::expand-ff-call + :ff-call-struct-return-by-implicit-arg-function + #+linuxppc-target + linux32::record-type-returns-structure-as-first-arg + #+darwinppc-target + darwin32::record-type-returns-structure-as-first-arg + :callback-bindings-function + #+linuxppc-target + linux32::generate-callback-bindings + #+darwinppc-target + darwin32::generate-callback-bindings + :callback-return-value-function + #+linuxppc-target + linux32::generate-callback-return-value + #+darwinppc-target + darwin32::generate-callback-return-value + ))) + (install-standard-foreign-types ftd) + (use-interface-dir :libc ftd) + (setf (backend-target-foreign-type-data *ppc32-backend*) ftd))) + +(pushnew *ppc32-backend* *known-backends* :key #'backend-name) + +#+ppc32-target +(require "PPC32-VINSNS") +(provide "PPC32-BACKEND") Index: /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-vinsns.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-vinsns.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC32/ppc32-vinsns.lisp (revision 8058) @@ -0,0 +1,4025 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPC32-BACKEND")) + +(eval-when (:compile-toplevel :execute) + (require "PPCENV")) + +(defmacro define-ppc32-vinsn (vinsn-name (results args &optional temps) &body body) + (%define-vinsn *ppc32-backend* vinsn-name results args temps body)) + + +;;; Index "scaling" and constant-offset misc-ref vinsns. + +(define-ppc32-vinsn scale-node-misc-index (((dest :u32)) + ((idx :imm) ; A fixnum + ) + ()) + (addi dest idx ppc32::misc-data-offset)) + +(define-ppc32-vinsn scale-32bit-misc-index (((dest :u32)) + ((idx :imm) ; A fixnum + ) + ()) + (addi dest idx ppc32::misc-data-offset)) + +(define-ppc32-vinsn scale-16bit-misc-index (((dest :u32)) + ((idx :imm) ; A fixnum + ) + ()) + (srwi dest idx 1) + (addi dest dest ppc32::misc-data-offset)) + +(define-ppc32-vinsn scale-8bit-misc-index (((dest :u32)) + ((idx :imm) ; A fixnum + ) + ()) + (srwi dest idx 2) + (addi dest dest ppc32::misc-data-offset)) + +(define-ppc32-vinsn scale-64bit-misc-index (((dest :u32)) + ((idx :imm) ; A fixnum + ) + ()) + (slwi dest idx 1) + (addi dest dest ppc32::misc-dfloat-offset)) + +(define-ppc32-vinsn scale-1bit-misc-index (((word-index :u32) + (bitnum :u8)) ; (unsigned-byte 5) + ((idx :imm) ; A fixnum + ) + ) + ; Logically, we want to: + ; 1) Unbox the index by shifting it right 2 bits. + ; 2) Shift (1) right 5 bits + ; 3) Scale (2) by shifting it left 2 bits. + ; We get to do all of this with one instruction + (rlwinm word-index idx (- ppc32::nbits-in-word 5) 5 (- ppc32::least-significant-bit ppc32::fixnum-shift)) + (addi word-index word-index ppc32::misc-data-offset) ; Hmmm. Also one instruction, but less impressive somehow. + (extrwi bitnum idx 5 (- ppc32::nbits-in-word (+ ppc32::fixnum-shift 5)))) + + + +(define-ppc32-vinsn misc-ref-u32 (((dest :u32)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lwzx dest v scaled-idx)) + + +(define-ppc32-vinsn misc-ref-c-u32 (((dest :u32)) + ((v :lisp) + (idx :u32const)) + ()) + (lwz dest (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc32-vinsn misc-ref-s32 (((dest :s32)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lwzx dest v scaled-idx)) + +(define-ppc32-vinsn misc-ref-c-s32 (((dest :s32)) + ((v :lisp) + (idx :u32const)) + ()) + (lwz dest (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + + +(define-ppc32-vinsn misc-set-c-u32 (() + ((val :u32) + (v :lisp) + (idx :u32const))) + (stw val (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc32-vinsn misc-set-c-s32 (() + ((val :s32) + (v :lisp) + (idx :u32const))) + (stw val (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc32-vinsn misc-set-u32 (() + ((val :u32) + (v :lisp) + (scaled-idx :u32))) + (stwx val v scaled-idx)) + +(define-ppc32-vinsn misc-set-s32 (() + ((val :s32) + (v :lisp) + (scaled-idx :u32))) + (stwx val v scaled-idx)) + + +(define-ppc32-vinsn misc-ref-single-float (((dest :single-float)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lfsx dest v scaled-idx)) + +(define-ppc32-vinsn misc-ref-c-single-float (((dest :single-float)) + ((v :lisp) + (idx :u32const)) + ()) + (lfs dest (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc32-vinsn misc-ref-double-float (((dest :double-float)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lfdx dest v scaled-idx)) + + +(define-ppc32-vinsn misc-ref-c-double-float (((dest :double-float)) + ((v :lisp) + (idx :u32const)) + ()) + (lfd dest (:apply + ppc32::misc-dfloat-offset (:apply ash idx 3)) v)) + +(define-ppc32-vinsn misc-set-c-double-float (((val :double-float)) + ((v :lisp) + (idx :u32const))) + (stfd val (:apply + ppc32::misc-dfloat-offset (:apply ash idx 3)) v)) + +(define-ppc32-vinsn misc-set-double-float (() + ((val :double-float) + (v :lisp) + (scaled-idx :u32))) + (stfdx val v scaled-idx)) + +(define-ppc32-vinsn misc-set-c-single-float (((val :single-float)) + ((v :lisp) + (idx :u32const))) + (stfs val (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc32-vinsn misc-set-single-float (() + ((val :single-float) + (v :lisp) + (scaled-idx :u32))) + (stfsx val v scaled-idx)) + + +(define-ppc32-vinsn misc-ref-u16 (((dest :u16)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lhzx dest v scaled-idx)) + +(define-ppc32-vinsn misc-ref-c-u16 (((dest :u16)) + ((v :lisp) + (idx :u32const)) + ()) + (lhz dest (:apply + ppc32::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc32-vinsn misc-set-c-u16 (((val :u16)) + ((v :lisp) + (idx :u32const)) + ()) + (sth val (:apply + ppc32::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc32-vinsn misc-set-u16 (((val :u16)) + ((v :lisp) + (scaled-idx :s32))) + (sthx val v scaled-idx)) + +(define-ppc32-vinsn misc-ref-s16 (((dest :s16)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lhax dest v scaled-idx)) + +(define-ppc32-vinsn misc-ref-c-s16 (((dest :s16)) + ((v :lisp) + (idx :u32const)) + ()) + (lha dest (:apply + ppc32::misc-data-offset (:apply ash idx 1)) v)) + + +(define-ppc32-vinsn misc-set-c-s16 (((val :s16)) + ((v :lisp) + (idx :u32const)) + ()) + (sth val (:apply + ppc32::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc32-vinsn misc-set-s16 (((val :s16)) + ((v :lisp) + (scaled-idx :s32))) + (sthx val v scaled-idx)) + +(define-ppc32-vinsn misc-ref-u8 (((dest :u8)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lbzx dest v scaled-idx)) + +(define-ppc32-vinsn misc-ref-c-u8 (((dest :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (lbz dest (:apply + ppc32::misc-data-offset idx) v)) + +(define-ppc32-vinsn misc-set-c-u8 (((val :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (stb val (:apply + ppc32::misc-data-offset idx) v)) + +(define-ppc32-vinsn misc-set-u8 (((val :u8)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (stbx val v scaled-idx)) + +(define-ppc32-vinsn misc-ref-s8 (((dest :s8)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lbzx dest v scaled-idx) + (extsb dest dest)) + +(define-ppc32-vinsn misc-ref-c-s8 (((dest :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (lbz dest (:apply + ppc32::misc-data-offset idx) v) + (extsb dest dest)) + +(define-ppc32-vinsn misc-set-c-s8 (((val :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (stb val (:apply + ppc32::misc-data-offset idx) v)) + +(define-ppc32-vinsn misc-set-s8 (((val :s8)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (stbx val v scaled-idx)) + +(define-ppc32-vinsn misc-ref-c-bit (((dest :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (lwz dest (:apply + ppc32::misc-data-offset (:apply ash idx -5)) v) + (rlwinm dest dest (:apply 1+ (:apply logand idx #x1f)) 31 31)) + +(define-ppc32-vinsn misc-ref-c-bit-fixnum (((dest :imm)) + ((v :lisp) + (idx :u32const)) + ((temp :u32))) + (lwz temp (:apply + ppc32::misc-data-offset (:apply ash idx -5)) v) + (rlwinm dest + temp + (:apply + 1 ppc32::fixnumshift (:apply logand idx #x1f)) + (- ppc32::least-significant-bit ppc32::fixnumshift) + (- ppc32::least-significant-bit ppc32::fixnumshift))) + + +(define-ppc32-vinsn misc-ref-node (((dest :lisp)) + ((v :lisp) + (scaled-idx :s32)) + ()) + (lwzx dest v scaled-idx)) + + + + +(define-ppc32-vinsn misc-ref-c-node (((dest :lisp)) + ((v :lisp) + (idx :s16const)) + ()) + (lwz dest (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc32-vinsn misc-set-node (() + ((val :lisp) + (v :lisp) + (scaled-idx :u32))) + (stwx val v scaled-idx)) + +;;; This should only be used for initialization (when the value being +;;; stored is known to be older than the vector V.) +(define-ppc32-vinsn misc-set-c-node (() + ((val :lisp) + (v :lisp) + (idx :s16const)) + ()) + (stw val (:apply + ppc32::misc-data-offset (:apply ash idx 2)) v)) + + +(define-ppc32-vinsn misc-element-count-fixnum (((dest :imm)) + ((v :lisp)) + ((temp :u32))) + (lwz temp ppc32::misc-header-offset v) + (rlwinm dest + temp + (- ppc32::nbits-in-word (- ppc32::num-subtag-bits ppc32::fixnumshift)) + (- ppc32::num-subtag-bits ppc32::fixnumshift) + (- ppc32::least-significant-bit ppc32::fixnumshift))) + +(define-ppc32-vinsn check-misc-bound (() + ((idx :imm) + (v :lisp)) + ((temp :u32))) + (lwz temp ppc32::misc-header-offset v) + (rlwinm temp + temp + (- ppc32::nbits-in-word (- ppc32::num-subtag-bits ppc32::fixnumshift)) + (- ppc32::num-subtag-bits ppc32::fixnumshift) + (- ppc32::least-significant-bit ppc32::fixnumshift)) + (twlge idx temp)) + +(define-ppc32-vinsn 2d-unscaled-index (((dest :imm) + (dim1 :u32)) + ((dim1 :u32) + (i :imm) + (j :imm))) + (mullw dim1 i dim1) + (add dest dim1 j)) + +;; dest <- (+ (* i dim1 dim2) (* j dim2) k) +(define-ppc32-vinsn 3d-unscaled-index (((dest :imm) + (dim1 :u32) + (dim2 :u32)) + ((dim1 :u32) + (dim2 :u32) + (i :imm) + (j :imm) + (k :imm))) + (mullw dim1 dim1 dim2) + (mullw dim2 j dim2) + (mullw dim1 i dim1) + (add dim2 dim1 dim2) + (add dest dim2 k)) + + +(define-ppc32-vinsn 2d-dim1 (((dest :u32)) + ((header :lisp))) + (lwz dest (+ ppc32::misc-data-offset (* 4 (1+ ppc32::arrayH.dim0-cell))) header) + (srawi dest dest ppc32::fixnumshift)) + +(define-ppc32-vinsn 3d-dims (((dim1 :u32) + (dim2 :u32)) + ((header :lisp))) + (lwz dim1 (+ ppc32::misc-data-offset (* 4 (1+ ppc32::arrayH.dim0-cell))) header) + (lwz dim2 (+ ppc32::misc-data-offset (* 4 (+ 2 ppc32::arrayH.dim0-cell))) header) + (srawi dim1 dim1 ppc32::fixnumshift) + (srawi dim2 dim2 ppc32::fixnumshift)) + +;; Return dim1 (unboxed) +(define-ppc32-vinsn check-2d-bound (((dim :u32)) + ((i :imm) + (j :imm) + (header :lisp))) + (lwz dim (+ ppc32::misc-data-offset (* 4 ppc32::arrayH.dim0-cell)) header) + (twlge i dim) + (lwz dim (+ ppc32::misc-data-offset (* 4 (1+ ppc32::arrayH.dim0-cell))) header) + (twlge j dim) + (srawi dim dim ppc32::fixnumshift)) + +(define-ppc32-vinsn check-3d-bound (((dim1 :u32) + (dim2 :u32)) + ((i :imm) + (j :imm) + (k :imm) + (header :lisp))) + (lwz dim1 (+ ppc32::misc-data-offset (* 4 ppc32::arrayH.dim0-cell)) header) + (twlge i dim1) + (lwz dim1 (+ ppc32::misc-data-offset (* 4 (1+ ppc32::arrayH.dim0-cell))) header) + (twlge j dim1) + (lwz dim2 (+ ppc32::misc-data-offset (* 4 (+ 2 ppc32::arrayH.dim0-cell))) header) + (twlge k dim2) + (srawi dim1 dim1 ppc32::fixnumshift) + (srawi dim2 dim2 ppc32::fixnumshift)) + +(define-ppc32-vinsn array-data-vector-ref (((dest :lisp)) + ((header :lisp))) + (lwz dest ppc32::arrayH.data-vector header)) + + +(define-ppc32-vinsn check-arrayH-rank (() + ((header :lisp) + (expected :u32const)) + ((rank :imm))) + (lwz rank ppc32::arrayH.rank header) + (twi 27 rank (:apply ash expected ppc32::fixnumshift))) + +(define-ppc32-vinsn check-arrayH-flags (() + ((header :lisp) + (expected :u16const)) + ((flags :imm) + (xreg :u32))) + (lis xreg (:apply ldb (byte 16 16) (:apply ash expected ppc32::fixnumshift))) + (ori xreg xreg (:apply ldb (byte 16 0) (:apply ash expected ppc32::fixnumshift))) + (lwz flags ppc32::arrayH.flags header) + (tw 27 flags xreg)) + + + + + +(define-ppc32-vinsn node-slot-ref (((dest :lisp)) + ((node :lisp) + (cellno :u32const))) + (lwz dest (:apply + ppc32::misc-data-offset (:apply ash cellno 2)) node)) + + + +(define-ppc32-vinsn %slot-ref (((dest :lisp)) + ((instance (:lisp (:ne dest))) + (index :lisp)) + ((scaled :u32))) + (la scaled ppc32::misc-data-offset index) + (lwzx dest instance scaled) + (tweqi dest ppc32::slot-unbound-marker)) + + +;;; Untagged memory reference & assignment. + +(define-ppc32-vinsn mem-ref-c-fullword (((dest :u32)) + ((src :address) + (index :s16const))) + (lwz dest index src)) + + +(define-ppc32-vinsn mem-ref-c-signed-fullword (((dest :s32)) + ((src :address) + (index :s16const))) + (lwz dest index src)) + +(define-ppc32-vinsn mem-ref-c-natural (((dest :u32)) + ((src :address) + (index :s16const))) + (lwz dest index src)) + + +(define-ppc32-vinsn mem-ref-fullword (((dest :u32)) + ((src :address) + (index :s32))) + (lwzx dest src index)) + +(define-ppc32-vinsn mem-ref-signed-fullword (((dest :u32)) + ((src :address) + (index :s32))) + (lwzx dest src index)) + +(define-ppc32-vinsn mem-ref-natural (((dest :u32)) + ((src :address) + (index :s32))) + (lwzx dest src index)) + + +(define-ppc32-vinsn mem-ref-c-u16 (((dest :u16)) + ((src :address) + (index :s16const))) + (lhz dest index src)) + + +(define-ppc32-vinsn mem-ref-u16 (((dest :u16)) + ((src :address) + (index :s32))) + (lhzx dest src index)) + + + +(define-ppc32-vinsn mem-ref-c-s16 (((dest :s16)) + ((src :address) + (index :s16const))) + (lha dest index src)) + +(define-ppc32-vinsn mem-ref-s16 (((dest :s16)) + ((src :address) + (index :s32))) + (lhax dest src index)) + +(define-ppc32-vinsn mem-ref-c-u8 (((dest :u8)) + ((src :address) + (index :s16const))) + (lbz dest index src)) + +(define-ppc32-vinsn mem-ref-u8 (((dest :u8)) + ((src :address) + (index :s32))) + (lbzx dest src index)) + +(define-ppc32-vinsn mem-ref-c-s8 (((dest :s8)) + ((src :address) + (index :s16const))) + (lbz dest index src) + (extsb dest dest)) + +(define-ppc32-vinsn mem-ref-s8 (((dest :s8)) + ((src :address) + (index :s32))) + (lbzx dest src index) + (extsb dest dest)) + +(define-ppc32-vinsn mem-ref-c-bit (((dest :u8)) + ((src :address) + (byte-index :s16const) + (bit-shift :u8const))) + (lbz dest byte-index src) + (rlwinm dest dest bit-shift 31 31)) + +(define-ppc32-vinsn mem-ref-c-bit-fixnum (((dest :lisp)) + ((src :address) + (byte-index :s16const) + (bit-shift :u8const)) + ((byteval :u8))) + (lbz byteval byte-index src) + (rlwinm dest byteval bit-shift 29 29)) + +(define-ppc32-vinsn mem-ref-bit (((dest :u8)) + ((src :address) + (bit-index :lisp)) + ((byte-index :s16) + (bit-shift :u8))) + (srwi byte-index bit-index (+ ppc32::fixnumshift 3)) + (extrwi bit-shift bit-index 3 27) + (addi bit-shift bit-shift 29) + (lbzx dest src byte-index) + (rlwnm dest dest bit-shift 31 31)) + + +(define-ppc32-vinsn mem-ref-bit-fixnum (((dest :lisp)) + ((src :address) + (bit-index :lisp)) + ((byte-index :s16) + (bit-shift :u8))) + (srwi byte-index bit-index (+ ppc32::fixnumshift 3)) + (extrwi bit-shift bit-index 3 27) + (addi bit-shift bit-shift 27) + (lbzx byte-index src byte-index) + (rlwnm dest + byte-index + bit-shift + (- ppc32::least-significant-bit ppc32::fixnum-shift) + (- ppc32::least-significant-bit ppc32::fixnum-shift))) + +(define-ppc32-vinsn mem-ref-c-double-float (((dest :double-float)) + ((src :address) + (index :s16const))) + (lfd dest index src)) + +(define-ppc32-vinsn mem-ref-double-float (((dest :double-float)) + ((src :address) + (index :s32))) + (lfdx dest src index)) + +(define-ppc32-vinsn mem-set-c-double-float (() + ((val :double-float) + (src :address) + (index :s16const))) + (stfd val index src)) + +(define-ppc32-vinsn mem-set-double-float (() + ((val :double-float) + (src :address) + (index :s32))) + (stfdx val src index)) + +(define-ppc32-vinsn mem-ref-c-single-float (((dest :single-float)) + ((src :address) + (index :s16const))) + (lfs dest index src)) + +(define-ppc32-vinsn mem-ref-single-float (((dest :single-float)) + ((src :address) + (index :s32))) + (lfsx dest src index)) + +(define-ppc32-vinsn mem-set-c-single-float (() + ((val :single-float) + (src :address) + (index :s16const))) + (stfs val index src)) + +(define-ppc32-vinsn mem-set-single-float (() + ((val :single-float) + (src :address) + (index :s32))) + (stfsx val src index)) + + +(define-ppc32-vinsn mem-set-c-address (() + ((val :address) + (src :address) + (index :s16const))) + (stw val index src)) + +(define-ppc32-vinsn mem-set-address (() + ((val :address) + (src :address) + (index :s32))) + (stwx val src index)) + +(define-ppc32-vinsn mem-set-c-fullword (() + ((val :u32) + (src :address) + (index :s16const))) + (stw val index src)) + +(define-ppc32-vinsn mem-set-fullword (() + ((val :u32) + (src :address) + (index :s32))) + (stwx val src index)) + +(define-ppc32-vinsn mem-set-c-halfword (() + ((val :u16) + (src :address) + (index :s16const))) + (sth val index src)) + +(define-ppc32-vinsn mem-set-halfword (() + ((val :u16) + (src :address) + (index :s32))) + (sthx val src index)) + +(define-ppc32-vinsn mem-set-c-byte (() + ((val :u16) + (src :address) + (index :s16const))) + (stb val index src)) + +(define-ppc32-vinsn mem-set-byte (() + ((val :u8) + (src :address) + (index :s32))) + (stbx val src index)) + +(define-ppc32-vinsn mem-set-c-bit-0 (() + ((src :address) + (byte-index :s16const) + (mask-begin :u8const) + (mask-end :u8const)) + ((val :u8))) + (lbz val byte-index src) + (rlwinm val val 0 mask-begin mask-end) + (stb val byte-index src)) + +(define-ppc32-vinsn mem-set-c-bit-1 (() + ((src :address) + (byte-index :s16const) + (mask :u8const)) + ((val :u8))) + (lbz val byte-index src) + (ori val val mask) + (stb val byte-index src)) + +(define-ppc32-vinsn mem-set-c-bit (() + ((src :address) + (byte-index :s16const) + (bit-index :u8const) + (val :imm)) + ((byteval :u8))) + (lbz byteval byte-index src) + (rlwimi byteval val (:apply logand 31 (:apply - 29 bit-index)) bit-index bit-index) + (stb byteval byte-index src)) + +;;; Hey, they should be happy that it even works. Who cares how big it is or how +;;; long it takes ... +(define-ppc32-vinsn mem-set-bit (() + ((src :address) + (bit-index :lisp) + (val :lisp)) + ((bit-shift :u32) + (mask :u32) + (byte-index :u32) + (crf :crf))) + (cmplwi crf val (ash 1 ppc32::fixnumshift)) + (extrwi bit-shift bit-index 3 27) + (li mask #x80) + (srw mask mask bit-shift) + (ble+ crf :got-it) + (uuo_interr arch::error-object-not-bit src) + :got-it + (srwi bit-shift bit-index (+ 3 ppc32::fixnumshift)) + (lbzx bit-shift src bit-shift) + (beq crf :set) + (andc mask bit-shift mask) + (b :done) + :set + (or mask bit-shift mask) + :done + (srwi bit-shift bit-index (+ 3 ppc32::fixnumshift)) + (stbx mask src bit-shift)) + +;;; Tag and subtag extraction, comparison, checking, trapping ... + +(define-ppc32-vinsn extract-tag (((tag :u8)) + ((object :lisp)) + ()) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits))) + +(define-ppc32-vinsn extract-tag-fixnum (((tag :imm)) + ((object :lisp))) + (rlwinm tag + object + ppc32::fixnum-shift + (- ppc32::nbits-in-word + (+ ppc32::nlisptagbits ppc32::fixnum-shift)) + (- ppc32::least-significant-bit ppc32::fixnum-shift))) + +(define-ppc32-vinsn extract-fulltag (((tag :u8)) + ((object :lisp)) + ()) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::ntagbits))) + + +(define-ppc32-vinsn extract-fulltag-fixnum (((tag :imm)) + ((object :lisp))) + (rlwinm tag + object + ppc32::fixnum-shift + (- ppc32::nbits-in-word + (+ ppc32::ntagbits ppc32::fixnum-shift)) + (- ppc32::least-significant-bit ppc32::fixnum-shift))) + +(define-ppc32-vinsn extract-typecode (((code :u8)) + ((object :lisp)) + ((crf :crf))) + (clrlwi code object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf code ppc32::tag-misc) + (bne crf :not-misc) + (lbz code ppc32::misc-subtag-offset object) + :not-misc) + +(define-ppc32-vinsn extract-typecode-fixnum (((code :imm)) + ((object (:lisp (:ne code)))) + ((crf :crf) (subtag :u8))) + (rlwinm code + object + ppc32::fixnum-shift + (- ppc32::nbits-in-word + (+ ppc32::nlisptagbits ppc32::fixnum-shift)) + (- ppc32::least-significant-bit ppc32::fixnum-shift)) + (cmpwi crf code (ash ppc32::tag-misc ppc32::fixnum-shift)) + (bne crf :not-misc) + (lbz subtag ppc32::misc-subtag-offset object) + (slwi code subtag ppc32::fixnum-shift) + :not-misc) + + +(define-ppc32-vinsn require-fixnum (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u8))) + :again + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-fixnum object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-integer (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u8))) + :again + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (beq+ crf0 :got-it) + (cmpwi crf0 tag ppc32::tag-misc) + (bne crf0 :no-got) + (lbz tag ppc32::misc-subtag-offset object) + (cmpwi crf0 tag ppc32::subtag-bignum) + (beq+ crf0 :got-it) + :no-got + (uuo_intcerr arch::error-object-not-integer object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-simple-vector (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :no-got) + (lbz tag ppc32::misc-subtag-offset object) + (cmpwi crf tag ppc32::subtag-simple-vector) + (beq+ crf :got-it) + :no-got + (uuo_intcerr arch::error-object-not-simple-vector object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-simple-string (() + ((object :lisp)) + ((tag :u8) + (crf :crf) + (crf2 :crf))) + :again + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :no-got) + (lbz tag ppc32::misc-subtag-offset object) + (cmpwi crf tag ppc32::subtag-simple-base-string) + (beq+ crf :got-it) + :no-got + (uuo_intcerr arch::error-object-not-simple-string object) + (b :again) + :got-it) + + +(define-ppc32-vinsn require-real (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u8))) + :again + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (beq+ crf0 :got-it) + (cmpwi crf0 tag ppc32::tag-misc) + (bne crf0 :no-got) + (lbz tag ppc32::misc-subtag-offset object) + (cmplwi crf0 tag ppc32::max-real-subtag) + (ble+ crf0 :got-it) + :no-got + (uuo_intcerr arch::error-object-not-real object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-number (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u8))) + :again + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (beq+ crf0 :got-it) + (cmpwi crf0 tag ppc32::tag-misc) + (bne crf0 :no-got) + (lbz tag ppc32::misc-subtag-offset object) + (cmplwi crf0 tag ppc32::max-numeric-subtag) + (ble+ crf0 :got-it) + :no-got + (uuo_intcerr arch::error-object-not-number object) + (b :again) + :got-it) + + +(define-ppc32-vinsn require-list (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-list) + (beq+ crf :got-it) + (uuo_intcerr arch::error-object-not-list object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-symbol (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (cmpwi crf object ppc32::nil-value) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (beq crf :got-it) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :no-got) + (lbz tag ppc32::misc-subtag-offset object) + (cmpwi crf tag ppc32::subtag-symbol) + (beq+ crf :got-it) + :no-got + (uuo_intcerr arch::error-object-not-symbol object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-character (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrlwi tag object (- ppc32::nbits-in-word ppc32::num-subtag-bits)) + (cmpwi crf tag ppc32::subtag-character) + (beq+ crf :got-it) + (uuo_intcerr arch::error-object-not-character object) + (b :again) + :got-it) + + +(define-ppc32-vinsn require-s8 (() + ((object :lisp)) + ((crf :crf) + (tag :u32))) + :again + (slwi tag object (- ppc32::nbits-in-word (+ 8 ppc32::fixnumshift))) + (srawi tag tag (- ppc32::nbits-in-word 8 )) + (slwi tag tag ppc32::fixnumshift) + (cmpw crf tag object) + (beq+ crf :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-8 object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-u8 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u32))) + :again + ;; The bottom ppc32::fixnumshift bits and the top (- 32 (+ + ;; ppc32::fixnumshift 8)) must all be zero. + (rlwinm. tag object 0 (- ppc32::nbits-in-word ppc32::fixnumshift) (- ppc32::least-significant-bit (+ ppc32::fixnumshift 8))) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-unsigned-byte-8 object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-s16 (() + ((object :lisp)) + ((crf :crf) + (tag :u32))) + :again + (slwi tag object (- ppc32::nbits-in-word (+ 16 ppc32::fixnumshift))) + (srawi tag tag (- ppc32::nbits-in-word 16)) + (slwi tag tag ppc32::fixnumshift) + (cmpw crf tag object) + (beq+ crf :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-16 object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-u16 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u32))) + :again + ;; The bottom ppc32::fixnumshift bits and the top (- 32 (+ + ;; ppc32::fixnumshift 16)) must all be zero. + (rlwinm. tag object 0 (- ppc32::nbits-in-word ppc32::fixnumshift) (- ppc32::least-significant-bit (+ ppc32::fixnumshift 16))) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-unsigned-byte-16 object) + (b :again) + :got-it) + +(define-ppc32-vinsn require-s32 (() + ((src :lisp)) + ((crfx :crf) + (crfy :crf) + (tag :u32))) + :again + (clrlwi tag src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crfx tag ppc32::tag-fixnum) + (cmpwi crfy tag ppc32::tag-misc) + (beq+ crfx :got-it) + (bne- crfy :bad) + (lwz tag ppc32::misc-header-offset src) + (cmpwi crfx tag ppc32::one-digit-bignum-header) + (beq+ crfx :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-32 src) + (b :again) + :got-it) + + +(define-ppc32-vinsn require-u32 (() + ((src :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (temp :u32))) + :again + (rlwinm. temp src 0 (- ppc32::nbits-in-word ppc32::fixnumshift) 0) + (beq+ crf0 :got-it) + (clrlwi temp src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf0 temp ppc32::tag-misc) + (bne- crf0 :bad) + (lwz temp ppc32::misc-header-offset src) + (cmpwi crf1 temp ppc32::two-digit-bignum-header) + (cmpwi crf0 temp ppc32::one-digit-bignum-header) + (lwz temp ppc32::misc-data-offset src) + (beq crf1 :two) + (bne crf0 :bad) + (cmpwi crf0 temp 0) + (bgt+ crf0 :got-it) + :bad + (uuo_intcerr arch::error-object-not-unsigned-byte-32 src) + (b :again) + :two + (lwz temp (+ ppc32::misc-data-offset 4) src) + (cmpwi crf0 temp 0) + (bne- crf0 :bad) + :got-it) + +(define-ppc32-vinsn require-s64 (() + ((src :lisp)) + ((crfx :crf) + (crfy :crf) + (tag :u32))) + :again + (clrlwi tag src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crfx tag ppc32::tag-fixnum) + (cmpwi crfy tag ppc32::tag-misc) + (beq+ crfx :got-it) + (bne- crfy :bad) + (lwz tag ppc32::misc-header-offset src) + (cmpwi crfx tag ppc32::one-digit-bignum-header) + (cmpwi crfy tag ppc32::two-digit-bignum-header) + (lwz tag ppc32::misc-data-offset src) + (beq+ crfx :got-it) + (beq+ crfy :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-64 src) + (b :again) + :got-it) + +(define-ppc32-vinsn require-u64 (() + ((src :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (crf2 :crf) + (temp :u32))) + :again + (rlwinm. temp src 0 (- ppc32::nbits-in-word ppc32::fixnumshift) 0) + (beq+ crf0 :got-it) + (clrlwi temp src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf0 temp ppc32::tag-misc) + (bne- crf0 :bad) + (lwz temp ppc32::misc-header-offset src) + (cmpwi crf2 temp ppc32::three-digit-bignum-header) + (cmpwi crf1 temp ppc32::two-digit-bignum-header) + (cmpwi crf0 temp ppc32::one-digit-bignum-header) + (lwz temp ppc32::misc-data-offset src) + (beq crf2 :three) + (beq crf1 :two) + (bne crf0 :bad) + (cmpwi crf0 temp 0) + (bgt+ crf0 :got-it) + :bad + (uuo_intcerr arch::error-object-not-unsigned-byte-64 src) + (b :again) + :three + (lwz temp (+ ppc32::misc-data-offset 8) src) + (cmpwi crf0 temp 0) + (beq+ crf0 :got-it) + (b :bad) + :two + (lwz temp (+ ppc32::misc-data-offset 4) src) + (cmpwi crf0 temp 0) + (blt- crf0 :bad) + :got-it) + + + +(define-ppc32-vinsn require-char-code (() + ((object :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (tag :u32))) + :again + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (lis tag (ash (ash #x110000 ppc32::fixnumshift) -16)) + (cmplw crf1 object tag) + (bne crf0 :bad) + (blt+ crf1 :got-it) + :bad + (uuo_intcerr arch::error-object-not-mod-char-code-limit object) + (b :again) + :got-it) + + +(define-ppc32-vinsn box-fixnum (((dest :imm)) + ((src :s32))) + (slwi dest src ppc32::fixnumshift)) + +(define-ppc32-vinsn fixnum->signed-natural (((dest :s32)) + ((src :imm))) + (srawi dest src ppc32::fixnumshift)) + +(define-ppc32-vinsn fixnum->unsigned-natural (((dest :u32)) + ((src :imm))) + (srwi dest src ppc32::fixnumshift)) + +;;; 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-ppc32-vinsn unbox-u32 (((dest :u32)) + ((src :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf))) + (rlwinm. dest src 0 (- ppc32::nbits-in-word ppc32::fixnumshift) 0) + (srwi dest src ppc32::fixnumshift) + (beq+ crf0 :got-it) + (clrlwi dest src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf0 dest ppc32::tag-misc) + (bne- crf0 :bad) + (lwz dest ppc32::misc-header-offset src) + (cmpwi crf1 dest ppc32::two-digit-bignum-header) + (cmpwi crf0 dest ppc32::one-digit-bignum-header) + (lwz dest ppc32::misc-data-offset src) + (beq crf1 :two) + (bne crf0 :bad) + (cmpwi crf0 dest 0) + (bgt+ crf0 :got-it) + :bad + (uuo_interr arch::error-object-not-unsigned-byte-32 src) + :two + (lwz dest (+ ppc32::misc-data-offset 4) src) + (cmpwi crf0 dest 0) + (bne- crf0 :bad) + (lwz dest ppc32::misc-data-offset src) + :got-it) + +;;; an object is of type (SIGNED-BYTE 32) iff +;;; a) it's a fixnum +;;; b) it's a bignum with exactly one digit. + +(define-ppc32-vinsn unbox-s32 (((dest :s32)) + ((src :lisp)) + ((crfx :crf) + (crfy :crf) + (tag :u32))) + (clrlwi tag src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crfx tag ppc32::tag-fixnum) + (cmpwi crfy tag ppc32::tag-misc) + (srawi dest src ppc32::fixnumshift) + (beq+ crfx :got-it) + (bne- crfy :bad) + (lwz tag ppc32::misc-header-offset src) + (cmpwi crfx tag ppc32::one-digit-bignum-header) + (lwz dest ppc32::misc-data-offset src) + (beq+ crfx :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-32 src) + :got-it) + +;;; For the sake of argument, "dest" is u32. +;;; Return dest if src is either (signed-byte 32) or (unsigned-byte 32). +;;; Say that it's not (signed-byte 32) if neither. +(define-ppc32-vinsn unbox-x32 (((dest :u32)) + ((src :lisp)) + ((crfx :crf) + (crfy :crf) + (tag :u32))) + (clrlwi tag src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crfx tag ppc32::tag-fixnum) + (cmpwi crfy tag ppc32::tag-misc) + (srawi dest src ppc32::fixnumshift) + (beq+ crfx :got-it) + (bne- crfy :bad) + (lwz tag ppc32::misc-header-offset src) + (cmpwi crfx tag (logior (ash 1 ppc32::num-subtag-bits) ppc32::subtag-bignum)) + (cmpwi crfy tag (logior (ash 2 ppc32::num-subtag-bits) ppc32::subtag-bignum)) + (lwz dest ppc32::misc-data-offset src) + (beq crfx :got-it) + (lwz tag (+ 4 ppc32::misc-data-offset) src) + (cmpwi crfx tag 0) + (bne crfy :bad) + (beq+ crfx :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-32 src) + :got-it) + +(define-ppc32-vinsn unbox-u16 (((dest :u16)) + ((src :lisp)) + ((crf0 (:crf 0)))) + ; The bottom ppc32::fixnumshift bits and the top (- 31 (+ ppc32::fixnumshift 16)) must all be zero. + (rlwinm. dest src 0 (- ppc32::nbits-in-word ppc32::fixnumshift) (- ppc32::least-significant-bit (+ ppc32::fixnumshift 16))) + (rlwinm dest src (- 32 ppc32::fixnumshift) 16 31) + (beq+ crf0 :got-it) + (uuo_interr arch::error-object-not-unsigned-byte-16 src) + :got-it) + +(define-ppc32-vinsn unbox-s16 (((dest :s16)) + ((src :lisp)) + ((crf :crf))) + (slwi dest src (- ppc32::nbits-in-word (+ 16 ppc32::fixnumshift))) + (srawi dest dest (- ppc32::nbits-in-word 16)) + (slwi dest dest ppc32::fixnumshift) + (cmpw crf dest src) + (srawi dest src ppc32::fixnumshift) + (beq+ crf :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-16 src) + :got-it) + + + +(define-ppc32-vinsn unbox-u8 (((dest :u8)) + ((src :lisp)) + ((crf0 (:crf 0)))) + ;; The bottom ppc32::fixnumshift bits and the top (- 31 (+ + ;; ppc32::fixnumshift 8)) must all be zero. + (rlwinm. dest src 0 (- ppc32::nbits-in-word ppc32::fixnumshift) (- ppc32::least-significant-bit (+ ppc32::fixnumshift 8))) + (rlwinm dest src (- 32 ppc32::fixnumshift) 24 31) + (beq+ crf0 :got-it) + (uuo_interr arch::error-object-not-unsigned-byte-8 src) + :got-it) + +(define-ppc32-vinsn %unbox-u8 (((dest :u8)) + ((src :lisp)) +) + (rlwinm dest src (- 32 ppc32::fixnumshift) 24 31)) + +(define-ppc32-vinsn unbox-s8 (((dest :s8)) + ((src :lisp)) + ((crf :crf))) + (slwi dest src (- ppc32::nbits-in-word (+ 8 ppc32::fixnumshift))) + (srawi dest dest (- ppc32::nbits-in-word 8)) + (slwi dest dest ppc32::fixnumshift) + (cmpw crf dest src) + (srawi dest src ppc32::fixnumshift) + (beq+ crf :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-8 src) + :got-it) + +(define-ppc32-vinsn unbox-base-char (((dest :u32)) + ((src :lisp)) + ((crf :crf))) + (rlwinm dest src 0 24 31) + (cmpwi crf dest ppc32::subtag-character) + (srwi dest src ppc32::charcode-shift) + (beq+ crf :got-it) + (uuo_interr arch::error-object-not-base-char src) + :got-it) + + +(define-ppc32-vinsn unbox-bit (((dest :u32)) + ((src :lisp)) + ((crf :crf))) + (cmplwi crf src (ash 1 ppc32::fixnumshift)) + (srawi dest src ppc32::fixnumshift) + (ble+ crf :got-it) + (uuo_interr arch::error-object-not-bit src) + :got-it) + +(define-ppc32-vinsn unbox-bit-bit0 (((dest :u32)) + ((src :lisp)) + ((crf :crf))) + (cmplwi crf src (ash 1 ppc32::fixnumshift)) + (rlwinm dest src (- 32 (1+ ppc32::fixnumshift)) 0 0) + (ble+ crf :got-it) + (uuo_interr arch::error-object-not-bit src) + :got-it) + +(define-ppc32-vinsn fixnum->fpr (((dest :double-float)) + ((src :lisp)) + ((imm :s32))) + (stfd ppc::fp-s32conv -8 ppc::sp) + (srawi imm src ppc32::fixnumshift) + (xoris imm imm #x8000) + (stw imm -4 ppc::sp) + (lfd dest -8 ppc::sp) + (fsub dest dest ppc::fp-s32conv)) + + +(define-ppc32-vinsn shift-right-variable-word (((dest :u32)) + ((src :u32) + (sh :u32))) + (srw dest src sh)) + +(define-ppc32-vinsn u32logandc2 (((dest :u32)) + ((x :u32) + (y :u32))) + (andc dest x y)) + +(define-ppc32-vinsn u32logior (((dest :u32)) + ((x :u32) + (y :u32))) + (or dest x y)) + +(define-ppc32-vinsn rotate-left-variable-word (((dest :u32)) + ((src :u32) + (rot :u32))) + (rlwnm dest src rot 0 31)) + +(define-ppc32-vinsn complement-shift-count (((dest :u32)) + ((src :u32))) + (subfic dest src 32)) + +(define-ppc32-vinsn extract-lowbyte (((dest :u32)) + ((src :lisp))) + (clrlwi dest src (- ppc32::nbits-in-word ppc32::num-subtag-bits))) + +;;; Set DEST to the difference between the low byte of SRC and BYTEVAL. +(define-ppc32-vinsn extract-compare-lowbyte (((dest :u32)) + ((src :lisp) + (byteval :u8const))) + (clrlwi dest src (- ppc32::nbits-in-word ppc32::num-subtag-bits)) + (subi dest dest byteval)) + + +;;; Set the "EQ" bit in condition-register field CRF if object is +;;; a fixnum. Leave the object's tag in TAG. +;;; This is a little easier if CRF is CR0. +(define-ppc32-vinsn eq-if-fixnum (((crf :crf) + (tag :u8)) + ((object :lisp)) + ()) + ((:eq crf 0) + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits))) + ((:not (:eq crf 0)) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-fixnum))) + + + +(define-ppc32-vinsn trap-unless-fixnum (() + ((object :lisp)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (twnei tag ppc32::tag-fixnum)) + +(define-ppc32-vinsn trap-unless-list (() + ((object :lisp)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (twnei tag ppc32::tag-list)) + +(define-ppc32-vinsn trap-unless-single-float (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :do-trap) + (lbz tag ppc32::misc-subtag-offset object) + :do-trap + (twnei tag ppc32::subtag-single-float)) + +(define-ppc32-vinsn trap-unless-double-float (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :do-trap) + (lbz tag ppc32::misc-subtag-offset object) + :do-trap + (twnei tag ppc32::subtag-double-float)) + + +(define-ppc32-vinsn trap-unless-array-header (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :do-trap) + (lbz tag ppc32::misc-subtag-offset object) + :do-trap + (twnei tag ppc32::subtag-arrayH)) + +(define-ppc32-vinsn trap-unless-macptr (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :do-trap) + (lbz tag ppc32::misc-subtag-offset object) + :do-trap + (twnei tag ppc32::subtag-macptr)) + + + +(define-ppc32-vinsn trap-unless-uvector (() + ((object :lisp)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (twnei tag ppc32::tag-misc)) + +(define-ppc32-vinsn trap-unless-fulltag= (() + ((object :lisp) + (tagval :u16const)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::ntagbits)) + (twnei tag tagval)) + +(define-ppc32-vinsn trap-unless-lowbyte= (() + ((object :lisp) + (tagval :u16const)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word 8)) + (twnei tag tagval)) + +(define-ppc32-vinsn trap-unless-character (() + ((object :lisp)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word 8)) + (twnei tag ppc32::subtag-character)) + +(define-ppc32-vinsn trap-unless-cons (() + ((object :lisp)) + ((tag :u8))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::ntagbits)) + (twnei tag ppc32::fulltag-cons)) + +(define-ppc32-vinsn trap-unless-typecode= (() + ((object :lisp) + (tagval :u16const)) + ((tag :u8) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :do-trap) + (lbz tag ppc32::misc-subtag-offset object) + :do-trap + (twnei tag tagval)) + +(define-ppc32-vinsn subtract-constant (((dest :imm)) + ((src :imm) + (const :s16const))) + (subi dest src const)) + +(define-ppc32-vinsn trap-unless-numeric-type (() + ((object :lisp) + (maxtype :u16const)) + ((crf0 (:crf 0)) + (tag :u8) + (crfX :crf))) + (clrlwi. tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi tag ppc32::tag-misc) + (beq+ crf0 :fixnum) + (bne crfX :scale-tag) + (lbz tag ppc32::misc-subtag-offset object) + :scale-tag + (subi tag tag ppc32::min-numeric-subtag) + (twlgti tag (:apply - maxtype ppc32::min-numeric-subtag)) + :fixnum) + + +;; Bit-extraction & boolean operations + +(eval-when (:compile-toplevel :execute) + (assert (= ppc32::t-offset #b10001))) ; PPC-bits 31 and 27 set + +;; For some mind-numbing reason, IBM decided to call the most significant +;; bit in a 32-bit word "bit 0" and the least significant bit "bit 31" +;; (this despite the fact that it's essentially a big-endian architecture +;; (it was exclusively big-endian when this decision was made.)) +;; We'll probably be least confused if we consistently use this backwards +;; bit ordering (letting things that have a "sane" bit-number worry about +;; it at compile-time or run-time (subtracting the "sane" bit number from +;; 31.)) + +(define-ppc32-vinsn extract-variable-bit (((dest :u8)) + ((src :u32) + (bitnum :u8)) + ()) + (rotlw dest src bitnum) + (extrwi dest dest 1 0)) + + +(define-ppc32-vinsn extract-variable-bit-fixnum (((dest :imm)) + ((src :u32) + (bitnum :u8)) + ((temp :u32))) + (rotlw temp src bitnum) + (rlwinm dest + temp + (1+ ppc32::fixnumshift) + (- ppc32::least-significant-bit ppc32::fixnumshift) + (- ppc32::least-significant-bit ppc32::fixnumshift))) + + +;; Sometimes we try to extract a single bit from some source register +;; into a destination bit (typically 31, sometimes fixnum bit 0 = 29). +;; If we copy bit 0 (whoops, I mean "bit 31") to bit 4 (aka 27) in a +;; given register, we get a value that's either 17 (the arithmetic difference +;; between T and NIL) or 0. + +(define-ppc32-vinsn lowbit->truth (((dest :lisp) + (bits :u32)) + ((bits :u32)) + ()) + (rlwimi bits bits (- ppc32::least-significant-bit 27) 27 27) ; bits = 0000...X000X + (addi dest bits ppc32::nil-value)) + +(define-ppc32-vinsn invert-lowbit (((bits :u32)) + ((bits :u32)) + ()) + (xori bits bits 1)) + + + +;; Some of the obscure-looking instruction sequences - which map some relation +;; to PPC bit 31 of some register - were found by the GNU SuperOptimizer. +;; Some of them use extended-precision instructions (which may cause interlocks +;; on some superscalar PPCs, if I remember correctly.) In general, sequences +;; that GSO found that -don't- do extended precision are longer and/or use +;; more temporaries. +;; On the 604, the penalty for using an instruction that uses the CA bit is +;; "at least" one cycle: it can't complete execution until all "older" instructions +;; have. That's not horrible, especially given that the alternative is usually +;; to use more instructions (and, more importantly, more temporaries) to avoid +;; using extended-precision. + + +(define-ppc32-vinsn eq0->bit31 (((bits :u32)) + ((src (t (:ne bits))))) + (cntlzw bits src) + (srwi bits bits 5)) ; bits = 0000...000X + +(define-ppc32-vinsn ne0->bit31 (((bits :u32)) + ((src (t (:ne bits))))) + (cntlzw bits src) + (slw bits src bits) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn lt0->bit31 (((bits :u32)) + ((src (t (:ne bits))))) + (srwi bits src 31)) ; bits = 0000...000X + + +(define-ppc32-vinsn ge0->bit31 (((bits :u32)) + ((src (t (:ne bits))))) + (srwi bits src 31) + (xori bits bits 1)) ; bits = 0000...000X + + +(define-ppc32-vinsn le0->bit31 (((bits :u32)) + ((src (t (:ne bits))))) + (neg bits src) + (orc bits bits src) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn gt0->bit31 (((bits :u32)) + ((src (t (:ne bits))))) + (subi bits src 1) + (nor bits bits src) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn ne->bit31 (((bits :u32)) + ((x t) + (y t)) + ((temp :u32))) + (subf temp x y) + (cntlzw bits temp) + (slw bits temp bits) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn fulltag->bit31 (((bits :u32)) + ((lispobj :lisp) + (tagval :u8const)) + ()) + (clrlwi bits lispobj (- ppc32::nbits-in-word ppc32::ntagbits)) + (subi bits bits tagval) + (cntlzw bits bits) + (srwi bits bits 5)) + + +(define-ppc32-vinsn eq->bit31 (((bits :u32)) + ((x t) + (y t))) + (subf bits x y) + (cntlzw bits bits) + (srwi bits bits 5)) ; bits = 0000...000X + +(define-ppc32-vinsn eqnil->bit31 (((bits :u32)) + ((x t))) + (subi bits x ppc32::nil-value) + (cntlzw bits bits) + (srwi bits bits 5)) + +(define-ppc32-vinsn ne->bit31 (((bits :u32)) + ((x t) + (y t))) + (subf bits x y) + (cntlzw bits bits) + (srwi bits bits 5) + (xori bits bits 1)) + +(define-ppc32-vinsn nenil->bit31 (((bits :u32)) + ((x t))) + (subi bits x ppc32::nil-value) + (cntlzw bits bits) + (srwi bits bits 5) + (xori bits bits 1)) + +(define-ppc32-vinsn lt->bit31 (((bits :u32)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + + (xor bits x y) + (srawi bits bits 31) + (or bits bits x) + (subf bits y bits) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn ltu->bit31 (((bits :u32)) + ((x :u32) + (y :u32))) + (subfc bits y x) + (subfe bits bits bits) + (neg bits bits)) + +(define-ppc32-vinsn le->bit31 (((bits :u32)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + + (xor bits x y) + (srawi bits bits 31) + (nor bits bits y) + (add bits bits x) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn leu->bit31 (((bits :u32)) + ((x :u32) + (y :u32))) + (subfc bits x y) + (addze bits ppc::rzero)) + +(define-ppc32-vinsn gt->bit31 (((bits :u32)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + + (eqv bits x y) + (srawi bits bits 31) + (and bits bits x) + (subf bits bits y) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn gtu->bit31 (((bits :u32)) + ((x :u32) + (y :u32))) + (subfc bits x y) + (subfe bits bits bits) + (neg bits bits)) + +(define-ppc32-vinsn ge->bit31 (((bits :u32)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + (eqv bits x y) + (srawi bits bits 31) + (andc bits bits x) + (add bits bits y) + (srwi bits bits 31)) ; bits = 0000...000X + +(define-ppc32-vinsn geu->bit31 (((bits :u32)) + ((x :u32) + (y :u32))) + (subfc bits y x) + (addze bits ppc::rzero)) + + +;;; there are big-time latencies associated with MFCR on more heavily +;;; pipelined processors; that implies that we should avoid this like +;;; the plague. +;;; GSO can't find anything much quicker for LT or GT, even though +;;; MFCR takes three cycles and waits for previous instructions to complete. +;;; Of course, using a CR field costs us something as well. +(define-ppc32-vinsn crbit->bit31 (((bits :u32)) + ((crf :crf) + (bitnum :crbit)) + ()) + (mfcr bits) ; Suffer. + (rlwinm bits bits (:apply + 1 bitnum (:apply ash crf 2)) 31 31)) ; bits = 0000...000X + + +(define-ppc32-vinsn compare (((crf :crf)) + ((arg0 t) + (arg1 t)) + ()) + (cmpw crf arg0 arg1)) + +(define-ppc32-vinsn compare-to-nil (((crf :crf)) + ((arg0 t))) + (cmpwi crf arg0 ppc32::nil-value)) + +(define-ppc32-vinsn compare-logical (((crf :crf)) + ((arg0 t) + (arg1 t)) + ()) + (cmplw crf arg0 arg1)) + +(define-ppc32-vinsn double-float-compare (((crf :crf)) + ((arg0 :double-float) + (arg1 :double-float)) + ()) + (fcmpo crf arg0 arg1)) + + +(define-ppc32-vinsn double-float+-2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fadd result x y)) + +(define-ppc32-vinsn double-float--2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fsub result x y)) + +(define-ppc32-vinsn double-float*-2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fmul result x y)) + +(define-ppc32-vinsn double-float/-2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fdiv result x y)) + +(define-ppc32-vinsn single-float+-2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fadds result x y)) + +(define-ppc32-vinsn single-float--2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fsubs result x y)) + +(define-ppc32-vinsn single-float*-2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fmuls result x y)) + +(define-ppc32-vinsn single-float/-2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fdivs result x y)) + + + + + +(define-ppc32-vinsn compare-unsigned (((crf :crf)) + ((arg0 :imm) + (arg1 :imm)) + ()) + (cmplw crf arg0 arg1)) + +(define-ppc32-vinsn compare-signed-s16const (((crf :crf)) + ((arg0 :imm) + (imm :s16const)) + ()) + (cmpwi crf arg0 imm)) + +(define-ppc32-vinsn compare-unsigned-u16const (((crf :crf)) + ((arg0 :u32) + (imm :u16const)) + ()) + (cmplwi crf arg0 imm)) + + + +;; Extract a constant bit (0-31) from src; make it be bit 31 of dest. +;; Bitnum is treated mod 32. +(define-ppc32-vinsn extract-constant-ppc-bit (((dest :u32)) + ((src :imm) + (bitnum :u16const)) + ()) + (rlwinm dest src (:apply + 1 bitnum) 31 31)) + + +(define-ppc32-vinsn set-constant-ppc-bit-to-variable-value (((dest :u32)) + ((src :u32) + (bitval :u32) ; 0 or 1 + (bitnum :u8const))) + (rlwimi dest bitval (:apply - 31 bitnum) bitnum bitnum)) + +(define-ppc32-vinsn set-constant-ppc-bit-to-1 (((dest :u32)) + ((src :u32) + (bitnum :u8const))) + ((:pred < bitnum 16) + (oris dest src (:apply ash #x8000 (:apply - bitnum)))) + ((:pred >= bitnum 16) + (ori dest src (:apply ash #x8000 (:apply - (:apply - bitnum 16)))))) + +(define-ppc32-vinsn set-constant-ppc-bit-to-0 (((dest :u32)) + ((src :u32) + (bitnum :u8const))) + (rlwinm dest src 0 (:apply logand #x1f (:apply 1+ bitnum)) (:apply logand #x1f (:apply 1- bitnum)))) + + +(define-ppc32-vinsn insert-bit-0 (((dest :u32)) + ((src :u32) + (val :u32))) + (rlwimi dest val 0 0 0)) + +;;; The bit number is boxed and wants to think of the least-significant bit as 0. +;;; Imagine that. +;;; To turn the boxed, lsb-0 bitnumber into an unboxed, msb-0 rotate count, +;;; we (conceptually) unbox it, add ppc32::fixnumshift to it, subtract it from +;;; 31, and add one. This can also be done as "unbox and subtract from 28", +;;; I think ... +;;; Actually, it'd be "unbox, then subtract from 30". +(define-ppc32-vinsn extract-variable-non-insane-bit (((dest :u32)) + ((src :imm) + (bit :imm)) + ((temp :u32))) + (srwi temp bit ppc32::fixnumshift) + (subfic temp temp (- 32 ppc32::fixnumshift)) + (rlwnm dest src temp 31 31)) + +;;; Operations on lists and cons cells + +(define-ppc32-vinsn %cdr (((dest :lisp)) + ((src :lisp))) + (lwz dest ppc32::cons.cdr src)) + +(define-ppc32-vinsn %car (((dest :lisp)) + ((src :lisp))) + (lwz dest ppc32::cons.car src)) + +(define-ppc32-vinsn %set-car (() + ((cell :lisp) + (new :lisp))) + (stw new ppc32::cons.car cell)) + +(define-ppc32-vinsn %set-cdr (() + ((cell :lisp) + (new :lisp))) + (stw new ppc32::cons.cdr cell)) + +(define-ppc32-vinsn load-adl (() + ((n :u32const))) + (lis ppc::nargs (:apply ldb (byte 16 16) n)) + (ori ppc::nargs ppc::nargs (:apply ldb (byte 16 0) n))) + +(define-ppc32-vinsn set-nargs (() + ((n :s16const))) + (li ppc::nargs (:apply ash n ppc32::word-shift))) + +(define-ppc32-vinsn scale-nargs (() + ((nfixed :s16const))) + ((:pred > nfixed 0) + (la ppc::nargs (:apply - (:apply ash nfixed ppc32::word-shift)) ppc::nargs))) + + + +(define-ppc32-vinsn (vpush-register :push :node :vsp) + (() + ((reg :lisp))) + (stwu reg -4 ppc::vsp)) + +(define-ppc32-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument) + (() + ((reg :lisp))) + (stwu reg -4 ppc::vsp)) + +(define-ppc32-vinsn (vpop-register :pop :node :vsp) + (((dest :lisp)) + ()) + (lwz dest 0 ppc::vsp) + (la ppc::vsp 4 ppc::vsp)) + + +(define-ppc32-vinsn copy-node-gpr (((dest :lisp)) + ((src :lisp))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (mr dest src))) + +(define-ppc32-vinsn copy-gpr (((dest t)) + ((src t))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (mr dest src))) + + +(define-ppc32-vinsn copy-fpr (((dest :double-float)) + ((src :double-float))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (fmr dest src))) + +(define-ppc32-vinsn vcell-ref (((dest :lisp)) + ((vcell :lisp))) + (lwz dest ppc32::misc-data-offset vcell)) + + +(define-ppc32-vinsn make-vcell (((dest :lisp)) + ((closed (:lisp :ne dest))) + ((header :u32))) + (li header ppc32::value-cell-header) + (la ppc::allocptr (- ppc32::fulltag-misc ppc32::value-cell.size) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw closed ppc32::value-cell.value dest)) + +(define-ppc32-vinsn make-tsp-vcell (((dest :lisp)) + ((closed :lisp)) + ((header :u32))) + (li header ppc32::value-cell-header) + (stwu ppc::tsp -16 ppc::tsp) + (stw ppc::tsp 4 ppc::tsp) + (stfd ppc::fp-zero 8 ppc::tsp) + (stw ppc::rzero 4 ppc::tsp) + (stw header (+ 8 ppc32::fulltag-misc ppc32::value-cell.header) ppc::tsp) + (stw closed (+ 8 ppc32::fulltag-misc ppc32::value-cell.value) ppc::tsp) + (la dest (+ 8 ppc32::fulltag-misc) ppc::tsp)) + +(define-ppc32-vinsn make-tsp-cons (((dest :lisp)) + ((car :lisp) (cdr :lisp)) + ()) + (stwu ppc::tsp -16 ppc::tsp) + (stw ppc::tsp 4 ppc::tsp) + (stfd ppc::fp-zero 8 ppc::tsp) + (stw ppc::rzero 4 ppc::tsp) + (stw car (+ 8 ppc32::fulltag-cons ppc32::cons.car) ppc::tsp) + (stw cdr (+ 8 ppc32::fulltag-cons ppc32::cons.cdr) ppc::tsp) + (la dest (+ 8 ppc32::fulltag-cons) ppc::tsp)) + + +(define-ppc32-vinsn %closure-code% (((dest :lisp)) + ()) + (lwz dest (+ ppc32::symbol.vcell (ppc32::nrs-offset %closure-code%) ppc32::nil-value) 0)) + + +(define-ppc32-vinsn single-float-bits (((dest :u32)) + ((src :lisp))) + (lwz dest ppc32::single-float.value src)) + +(define-ppc32-vinsn (call-subprim :call :subprim-call) (() + ((spno :s32const))) + (bla spno)) + +(define-ppc32-vinsn (jump-subprim :jumpLR) (() + ((spno :s32const))) + (ba spno)) + +;;; Same as "call-subprim", but gives us a place to +;;; track args, results, etc. +(define-ppc32-vinsn (call-subprim-0 :call :subprim-call) (((dest t)) + ((spno :s32const))) + (bla spno)) + +(define-ppc32-vinsn (call-subprim-1 :call :subprim-call) (((dest t)) + ((spno :s32const) + (z t))) + (bla spno)) + +(define-ppc32-vinsn (call-subprim-2 :call :subprim-call) (((dest t)) + ((spno :s32const) + (y t) + (z t))) + (bla spno)) + +(define-ppc32-vinsn (call-subprim-3 :call :subprim-call) (((dest t)) + ((spno :s32const) + (x t) + (y t) + (z t))) + (bla spno)) + +(define-ppc32-vinsn event-poll (() + () + ((crf :crf))) + (lwz ppc::nargs ppc32::tcr.tlb-pointer ppc32::rcontext) + (lwz ppc::nargs ppc32::interrupt-level-binding-index ppc::nargs) + (cmpwi crf ppc::nargs 0) + (blt crf :done) + (bgt crf :trap) + (lwz ppc::nargs ppc32::tcr.interrupt-pending ppc32::rcontext) + :trap + (twgti ppc::nargs 0) + :done) + +(define-ppc32-vinsn ref-interrupt-level (((dest :imm)) + () + ((temp :u32))) + (lwz temp ppc32::tcr.tlb-pointer ppc32::rcontext) + (lwz dest ppc32::INTERRUPT-LEVEL-BINDING-INDEX temp)) + + +;;; Unconditional (pc-relative) branch +(define-ppc32-vinsn (jump :jump) (() + ((label :label))) + (b label)) + +(define-ppc32-vinsn (call-label :call) (() + ((label :label))) + (bl label)) + +;;; just like JUMP, only (implicitly) asserts that the following +;;; code is somehow reachable. +(define-ppc32-vinsn (non-barrier-jump :xref) (() + ((label :label))) + (b label)) + + +(define-ppc32-vinsn (cbranch-true :branch) (() + ((label :label) + (crf :crf) + (crbit :u8const))) + (bt (:apply + crf crbit) label)) + +(define-ppc32-vinsn (cbranch-false :branch) (() + ((label :label) + (crf :crf) + (crbit :u8const))) + (bf (:apply + crf crbit) label)) + +(define-ppc32-vinsn check-trap-error (() + ()) + (beq+ 0 :no-error) + (uuo_interr arch::error-reg-regnum ppc::arg_z) + :no-error) + + +(define-ppc32-vinsn lisp-word-ref (((dest t)) + ((base t) + (offset t))) + (lwzx dest base offset)) + +(define-ppc32-vinsn lisp-word-ref-c (((dest t)) + ((base t) + (offset :s16const))) + (lwz dest offset base)) + + + +;; Load an unsigned, 32-bit constant into a destination register. +(define-ppc32-vinsn (lri :constant-ref) (((dest :imm)) + ((intval :u32const)) + ()) + ((:or (:pred = (:apply ash intval -15) #x1ffff) + (:pred = (:apply ash intval -15) #x0)) + (li dest (:apply %word-to-int (:apply logand #xffff intval)))) + ((:not ; that's :else to you, bub. + (:or (:pred = (:apply ash intval -15) #x1ffff) + (:pred = (:apply ash intval -15) #x0))) + ((:pred = (:apply ash intval -15) 1) + (ori dest ppc::rzero (:apply logand intval #xffff))) + ((:not (:pred = (:apply ash intval -15) 1)) + (lis dest (:apply ash intval -16)) + ((:not (:pred = 0 (:apply logand intval #xffff))) + (ori dest dest (:apply logand intval #xffff)))))) + + +(define-ppc32-vinsn discard-temp-frame (() + ()) + (lwz ppc::tsp 0 ppc::tsp)) + + +;;; Somewhere, deep inside the "OS_X_PPC_RuntimeConventions.pdf" +;;; document, they bother to document the fact that SP should +;;; maintain 16-byte alignment on OSX. (The example prologue +;;; code in that document incorrectly assumes 8-byte alignment. +;;; Or something. It's wrong in a number of other ways.) +;;; The caller always has to reserve a 24-byte linkage area +;;; (large chunks of which are unused). +(define-ppc32-vinsn alloc-c-frame (() + ((n-c-args :u16const))) + ;; Always reserve space for at least 8 args and space for a lisp + ;; frame (for the kernel) underneath it. + ;; Zero the c-frame's savelr field, not that the GC cares .. + ((:pred <= n-c-args 10) + (stwu ppc::sp (- (+ 8 ppc32::c-frame.size ppc32::lisp-frame.size)) ppc::sp)) + ((:pred > n-c-args 10) + ;; A normal C frame has room for 10 args (when padded out to + ;; 16-byte alignment. Add enough double words to accomodate the + ;; remaining args, in multiples of 4. + (stwu ppc::sp (:apply - (:apply + + 8 + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + (:apply ash + (:apply logand + (lognot 3) + (:apply + + + 3 + (:apply - n-c-args 10))) + 2))) + ppc::sp)) + (stw ppc::rzero ppc32::c-frame.savelr ppc::sp)) + +(define-ppc32-vinsn alloc-variable-c-frame (() + ((n-c-args :lisp)) + ((crf :crf) + (size :s32))) + (cmpwi crf n-c-args (ash 10 ppc32::fixnumshift)) + (subi size n-c-args (ash 10 ppc32::fixnumshift)) + (bgt :variable) + ;; Always reserve space for at least 8 args and space for a lisp + ;; frame (for the kernel) underneath it. + (stwu ppc::sp (- (+ 8 ppc32::c-frame.size ppc32::lisp-frame.size)) ppc::sp) + (b :done) + :variable + (addi size size (+ (+ 8 ppc32::c-frame.size ppc32::lisp-frame.size) (ash 3 ppc32::fixnumshift))) + (clrrwi size size 3) + (neg size size) + (stwux ppc::sp ppc::sp size) + :done + (stw ppc::rzero ppc32::c-frame.savelr ppc::sp)) + +(define-ppc32-vinsn alloc-eabi-c-frame (() + ((n-c-args :u16const))) + ;; Always reserve space for at least 8 args and space for a lisp + ;; frame (for the kernel) underneath it. Store NIL inthe c-frame's + ;; savelr field, so that the kernel doesn't mistake this for a lisp + ;; frame. + ((:pred <= n-c-args 8) + (stwu ppc::sp (- (+ ppc32::eabi-c-frame.size ppc32::lisp-frame.size)) ppc::sp)) + ((:pred > n-c-args 8) + ;; A normal C frame has room for 8 args. Add enough double words to + ;; accomodate the remaining args + (stwu ppc::sp (:apply - (:apply + + (+ ppc32::eabi-c-frame.size ppc32::lisp-frame.size) + (:apply ash + (:apply logand + (lognot 1) + (:apply + 1+ + (:apply - n-c-args 8))) + 2))) + ppc::sp)) + (stw ppc::sp ppc32::eabi-c-frame.savelr ppc::sp)) + +(define-ppc32-vinsn alloc-variable-eabi-c-frame (() + ((n-c-args :lisp)) + ((crf :crf) + (size :s32))) + (cmpwi crf n-c-args (ash 8 ppc32::fixnumshift)) + (subi size n-c-args (ash 8 ppc32::fixnumshift)) + (bgt :variable) + ;; Always reserve space for at least 8 args and space for a lisp + ;; frame (for the kernel) underneath it. + (stwu ppc::sp (- (+ ppc32::eabi-c-frame.size ppc32::lisp-frame.size)) ppc::sp) + (b :done) + :variable + (addi size size (+ (+ ppc32::eabi-c-frame.size ppc32::lisp-frame.size) (ash 1 ppc32::fixnumshift))) + (clrrwi size size 2) + (neg size size) + (stwux ppc::sp ppc::sp size) + :done + (stw ppc::rzero ppc32::c-frame.savelr ppc::sp)) + + + +;;; We should rarely have to do this. It's easier to just generate code +;;; to do the memory reference than it would be to keep track of the size +;;; of each frame. +(define-ppc32-vinsn discard-c-frame (() + ()) + (lwz ppc::sp 0 ppc::sp)) + + + + +(define-ppc32-vinsn set-c-arg (() + ((argval :u32) + (argnum :u16const))) + (stw argval (:apply + ppc32::c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn set-single-c-arg (() + ((argval :single-float) + (argnum :u16const))) + (stfs argval (:apply + ppc32::c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn set-double-c-arg (() + ((argval :double-float) + (argnum :u16const))) + (stfd argval (:apply + ppc32::c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn reload-single-c-arg (((argval :single-float)) + ((argnum :u16const))) + (lfs argval (:apply + ppc32::c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn reload-double-c-arg (((argval :double-float)) + ((argnum :u16const))) + (lfd argval (:apply + ppc32::c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn set-eabi-c-arg (() + ((argval :u32) + (argnum :u16const))) + (stw argval (:apply + ppc32::eabi-c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn set-single-eabi-c-arg (() + ((argval :single-float) + (argnum :u16const))) + (stfs argval (:apply + ppc32::eabi-c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn set-double-eabi-c-arg (() + ((argval :double-float) + (argnum :u16const))) + (stfd argval (:apply + ppc32::eabi-c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn reload-single-eabi-c-arg (((argval :single-float)) + ((argnum :u16const))) + (lfs argval (:apply + ppc32::eabi-c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn reload-double-eabi-c-arg (((argval :double-float)) + ((argnum :u16const))) + (lfd argval (:apply + ppc32::eabi-c-frame.param0 (:apply ash argnum ppc32::word-shift)) ppc::sp)) + +(define-ppc32-vinsn (load-nil :constant-ref) (((dest t)) + ()) + (li dest ppc32::nil-value)) + +(define-ppc32-vinsn (load-t :constant-ref) (((dest t)) + ()) + (li dest (+ ppc32::t-offset ppc32::nil-value))) + +(define-ppc32-vinsn set-eq-bit (((dest :crf)) + ()) + (creqv (:apply + ppc::ppc-eq-bit dest) + (:apply + ppc::ppc-eq-bit dest) + (:apply + ppc::ppc-eq-bit dest))) + +(define-ppc32-vinsn (ref-constant :constant-ref) (((dest :lisp)) + ((src :s16const))) + (lwz dest (:apply + ppc32::misc-data-offset (:apply ash (:apply 1+ src) 2)) ppc::fn)) + +(define-ppc32-vinsn ref-indexed-constant (((dest :lisp)) + ((idxreg :s32))) + (lwzx dest ppc::fn idxreg)) + + +(define-ppc32-vinsn cons (((dest :lisp)) + ((newcar :lisp) + (newcdr :lisp))) + (la ppc::allocptr (- ppc32::fulltag-cons ppc32::cons.size) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw newcdr ppc32::cons.cdr ppc::allocptr) + (stw newcar ppc32::cons.car ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits)) + + + +;; subtag had better be a PPC-NODE-SUBTAG of some sort! +(define-ppc32-vinsn %ppc-gvector (((dest :lisp)) + ((Rheader :u32) + (nbytes :u32const)) + ((immtemp0 :u32) + (nodetemp :lisp) + (crf :crf))) + (la ppc::allocptr (:apply - ppc32::fulltag-misc + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes))) + ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw Rheader ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + ((:not (:pred = nbytes 0)) + (li immtemp0 (:apply + ppc32::misc-data-offset nbytes)) + :loop + (subi immtemp0 immtemp0 4) + (cmpwi crf immtemp0 ppc32::misc-data-offset) + (lwz nodetemp 0 ppc::vsp) + (la ppc::vsp 4 ppc::vsp) + (stwx nodetemp dest immtemp0) + (bne crf :loop))) + +;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag +(define-ppc32-vinsn %alloc-misc-fixed (((dest :lisp)) + ((Rheader :u32) + (nbytes :u32const))) + (la ppc::allocptr (:apply - ppc32::fulltag-misc + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes))) + ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw Rheader ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits)) + +(define-ppc32-vinsn vstack-discard (() + ((nwords :u32const))) + ((:not (:pred = nwords 0)) + (la ppc::vsp (:apply ash nwords ppc32::word-shift) ppc::vsp))) + + +(define-ppc32-vinsn lcell-load (((dest :lisp)) + ((cell :lcell) + (top :lcell))) + (lwz dest (:apply - + (:apply - (:apply calc-lcell-depth top) 4) + (:apply calc-lcell-offset cell)) ppc::vsp)) + +(define-ppc32-vinsn vframe-load (((dest :lisp)) + ((frame-offset :u16const) + (cur-vsp :u16const))) + (lwz dest (:apply - (:apply - cur-vsp 4) frame-offset) ppc::vsp)) + +(define-ppc32-vinsn lcell-store (() + ((src :lisp) + (cell :lcell) + (top :lcell))) + (stw src (:apply - + (:apply - (:apply calc-lcell-depth top) 4) + (:apply calc-lcell-offset cell)) ppc::vsp)) + +(define-ppc32-vinsn vframe-store (() + ((src :lisp) + (frame-offset :u16const) + (cur-vsp :u16const))) + (stw src (:apply - (:apply - cur-vsp 4) frame-offset) ppc::vsp)) + +(define-ppc32-vinsn load-vframe-address (((dest :imm)) + ((offset :s16const))) + (la dest offset ppc::vsp)) + +(define-ppc32-vinsn copy-lexpr-argument (() + () + ((temp :lisp))) + (lwzx temp ppc::vsp ppc::nargs) + (stwu temp -4 ppc::vsp)) + +;;; Boxing/unboxing of integers. + +;;; Treat the low 8 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum. +(define-ppc32-vinsn u8->fixnum (((result :imm)) + ((val :u8)) + ()) + (rlwinm result val ppc32::fixnumshift (- ppc32::nbits-in-word (+ 8 ppc32::fixnumshift)) (- ppc32::least-significant-bit ppc32::fixnumshift))) + +;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the equivalent fixnum. +(define-ppc32-vinsn s8->fixnum (((result :imm)) + ((val :s8)) + ()) + (extlwi result val 8 (- ppc32::nbits-in-word 8)) + (srawi result result (- (- ppc32::nbits-in-word 8) ppc32::fixnumshift))) + + +;;; Treat the low 16 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum. +(define-ppc32-vinsn u16->fixnum (((result :imm)) + ((val :u16)) + ()) + (rlwinm result val ppc32::fixnumshift (- ppc32::nbits-in-word (+ 16 ppc32::fixnumshift)) (- ppc32::least-significant-bit ppc32::fixnumshift))) + +;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to the equivalent fixnum. +(define-ppc32-vinsn s16->fixnum (((result :imm)) + ((val :s16)) + ()) + (extlwi result val 16 (- ppc32::nbits-in-word 16)) + (srawi result result (- (- ppc32::nbits-in-word 16) ppc32::fixnumshift))) + +(define-ppc32-vinsn fixnum->s16 (((result :s16)) + ((src :imm))) + (srawi result src ppc32::fixnumshift)) + +;;; A signed 32-bit untagged value can be at worst a 1-digit bignum. +;;; There should be something very much like this that takes a stack-consed +;;; bignum result ... +(define-ppc32-vinsn s32->integer (((result :lisp)) + ((src :s32)) + ((crf (:crf 0)) ; a casualty + (temp :s32))) + (addo temp src src) + (addo. result temp temp) + (bns+ :done) + (mtxer ppc::rzero) + (li temp ppc32::one-digit-bignum-header) + (la ppc::allocptr (- ppc32::fulltag-misc 8) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw temp ppc32::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw src ppc32::misc-data-offset result) + :done) + + +;;; An unsigned 32-bit untagged value can be either a 1 or a 2-digit bignum. +(define-ppc32-vinsn u32->integer (((result :lisp)) + ((src :u32)) + ((crf (:crf 0)) ; a casualty + (temp :s32) + (size :u32))) + (clrrwi. temp src (- ppc32::least-significant-bit ppc32::nfixnumtagbits)) + (slwi result src ppc32::fixnumshift) + (beq+ crf :done) + (cmpwi src 0) + (li temp ppc32::one-digit-bignum-header) + (li size (- 8 ppc32::fulltag-misc)) + (bgt :common) + (li temp ppc32::two-digit-bignum-header) + (li size (- 16 ppc32::fulltag-misc)) + :common + (sub ppc::allocptr ppc::allocptr size) + (twllt ppc::allocptr ppc::allocbase) + (stw temp ppc32::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw src ppc32::misc-data-offset result) + :done) + +(define-ppc32-vinsn u16->u32 (((dest :u32)) + ((src :u16))) + (clrlwi dest src 16)) + +(define-ppc32-vinsn u8->u32 (((dest :u32)) + ((src :u8))) + (clrlwi dest src 24)) + + +(define-ppc32-vinsn s16->s32 (((dest :s32)) + ((src :s16))) + (extsh dest src)) + +(define-ppc32-vinsn s8->s32 (((dest :s32)) + ((src :s8))) + (extsb dest src)) + + +;;; ... of floats ... + +;;; Heap-cons a double-float to store contents of FPREG. Hope that we don't do +;;; this blindly. +(define-ppc32-vinsn double->heap (((result :lisp)) ; tagged as a double-float + ((fpreg :double-float)) + ((header-temp :u32))) + (li header-temp (arch::make-vheader ppc32::double-float.element-count ppc32::subtag-double-float)) + (la ppc::allocptr (- ppc32::fulltag-misc ppc32::double-float.size) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header-temp ppc32::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stfd fpreg ppc32::double-float.value result) ) + + +;;; This is about as bad as heap-consing a double-float. (In terms of +;;; verbosity). Wouldn't kill us to do either/both out-of-line, but +;;; need to make visible to compiler so unnecessary heap-consing can +;;; be elided. +(define-ppc32-vinsn single->node (((result :lisp)) ; tagged as a single-float + ((fpreg :single-float)) + ((header-temp :u32))) + (li header-temp (arch::make-vheader ppc32::single-float.element-count ppc32::subtag-single-float)) + (la ppc::allocptr (- ppc32::fulltag-misc ppc32::single-float.size) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header-temp ppc32::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stfs fpreg ppc32::single-float.value result)) + + +;;; "dest" is preallocated, presumably on a stack somewhere. +(define-ppc32-vinsn store-double (() + ((dest :lisp) + (source :double-float)) + ()) + (stfd source ppc32::double-float.value dest)) + +(define-ppc32-vinsn get-double (((target :double-float)) + ((source :lisp)) + ()) + (lfd target ppc32::double-float.value source)) + +;;; 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-ppc32-vinsn get-double? (((target :double-float)) + ((source :lisp)) + ((tag :u8) + (crf :crf))) + (clrlwi tag source (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :do-trap) + (lbz tag ppc32::misc-subtag-offset source) + :do-trap + (twnei tag ppc32::subtag-double-float) + (lfd target ppc32::double-float.value source)) + + +(define-ppc32-vinsn %double-to-single (((result :single-float)) + ((arg :double-float))) + (frsp result arg)) + +(define-ppc32-vinsn store-single (() + ((dest :lisp) + (source :single-float)) + ()) + (stfs source ppc32::single-float.value dest)) + +(define-ppc32-vinsn get-single (((target :single-float)) + ((source :lisp)) + ()) + (lfs target ppc32::single-float.value source)) + +;;; ... of characters ... + + +(define-ppc32-vinsn character->fixnum (((dest :lisp)) + ((src :lisp)) + ()) + (rlwinm dest + src + (- ppc32::nbits-in-word (- ppc32::charcode-shift ppc32::fixnumshift)) + (- ppc32::nbits-in-word (+ ppc32::ncharcodebits ppc32::fixnumshift)) + (- ppc32::least-significant-bit ppc32::fixnumshift))) + +(define-ppc32-vinsn character->code (((dest :u32)) + ((src :lisp))) + (srwi dest src ppc32::charcode-shift)) + + +(define-ppc32-vinsn fixnum->char (((dest :lisp)) + ((src :imm)) + ((temp :u32) + (crf0 (:crf 0)))) + (srwi temp src (+ ppc32::fixnumshift 11)) + (cmpwi temp 27) + (slwi dest src (- ppc32::charcode-shift ppc32::fixnumshift)) + (bne+ :ok) + (li dest ppc32::nil-value) + (b :done) + :ok + (addi dest dest ppc32::subtag-character) + :done) + + +(define-ppc32-vinsn u32->char (((dest :lisp)) + ((src :u32)) + ()) + (slwi dest src ppc32::charcode-shift) + (addi dest dest ppc32::subtag-character)) + +;; ... Macptrs ... + +(define-ppc32-vinsn deref-macptr (((addr :address)) + ((src :lisp)) + ()) + (lwz addr ppc32::macptr.address src)) + +(define-ppc32-vinsn set-macptr-address (() + ((addr :address) + (src :lisp)) + ()) + (stw addr ppc32::macptr.address src)) + + +(define-ppc32-vinsn macptr->heap (((dest :lisp)) + ((address :address)) + ((header :u32))) + (li header (logior (ash ppc32::macptr.element-count ppc32::num-subtag-bits) ppc32::subtag-macptr)) + (la ppc::allocptr (- ppc32::fulltag-misc ppc32::macptr.size) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + ;; It's not necessary to zero out the domain/type fields, since newly + ;; heap-allocated memory's guaranteed to be 0-filled. + (stw address ppc32::macptr.address dest)) + +(define-ppc32-vinsn macptr->stack (((dest :lisp)) + ((address :address)) + ((header :u32))) + (li header ppc32::macptr-header) + (stwu ppc::tsp (- (+ 8 ppc32::macptr.size)) ppc::tsp) + (stw ppc::tsp 4 ppc::tsp) + (stw header (+ 8 ppc32::fulltag-misc ppc32::macptr.header) ppc::tsp) + (stw address (+ 8 ppc32::fulltag-misc ppc32::macptr.address) ppc::tsp) + ;; It -is- necessary to zero out the domain/type fields here, since + ;; stack-allocated memory isn't guaranteed to be 0-filled. + (stfd ppc::fp-zero (+ 8 ppc32::fulltag-misc ppc32::macptr.domain) ppc::tsp) + (la dest (+ 8 ppc32::fulltag-misc) ppc::tsp)) + + +(define-ppc32-vinsn adjust-stack-register (() + ((reg t) + (amount :s16const))) + (la reg amount reg)) + +(define-ppc32-vinsn adjust-vsp (() + ((amount :s16const))) + (la ppc::vsp amount ppc::vsp)) + +(define-ppc32-vinsn adjust-sp (() + ((amount :s16const))) + (la ppc::sp amount ppc::sp)) + +;; Arithmetic on fixnums & unboxed numbers + +(define-ppc32-vinsn u32-lognot (((dest :u32)) + ((src :u32)) + ()) + (not dest src)) + +(define-ppc32-vinsn fixnum-lognot (((dest :imm)) + ((src :imm)) + ((temp :u32))) + (not temp src) + (clrrwi dest temp ppc32::nfixnumtagbits)) + + +(define-ppc32-vinsn negate-fixnum-overflow-inline (((dest :lisp)) + ((src :imm)) + ((unboxed :s32) + (header :u32))) + (nego. dest src) + (bns+ :done) + (mtxer ppc::rzero) + (srawi unboxed dest ppc32::fixnumshift) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc32::fixnumshift)))) + (li header ppc32::one-digit-bignum-header) + (la ppc::allocptr (- ppc32::fulltag-misc 8) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw unboxed ppc32::misc-data-offset dest) + :done) + +(define-ppc32-vinsn negate-fixnum-overflow-ool (() + ((src :imm)) + ) + (nego. ppc::arg_z src) + (bsola- .SPfix-overflow) + :done) + + + +(define-ppc32-vinsn negate-fixnum-no-ovf (((dest :lisp)) + ((src :imm))) + + (neg dest src)) + + +(define-ppc32-vinsn logior-high (((dest :imm)) + ((src :imm) + (high :u16const))) + (oris dest src high)) + +(define-ppc32-vinsn logior-low (((dest :imm)) + ((src :imm) + (low :u16const))) + (ori dest src low)) + + + +(define-ppc32-vinsn %logior2 (((dest :imm)) + ((x :imm) + (y :imm)) + ()) + (or dest x y)) + +(define-ppc32-vinsn logand-high (((dest :imm)) + ((src :imm) + (high :u16const)) + ((crf0 (:crf 0)))) + (andis. dest src high)) + +(define-ppc32-vinsn logand-low (((dest :imm)) + ((src :imm) + (low :u16const)) + ((crf0 (:crf 0)))) + (andi. dest src low)) + + +(define-ppc32-vinsn %logand2 (((dest :imm)) + ((x :imm) + (y :imm)) + ()) + (and dest x y)) + +(define-ppc32-vinsn clear-left (((dest :imm)) + ((src :imm) + (nbits :s8const))) + (rlwinm dest src 0 (:apply 1+ nbits) 31)) + +(define-ppc32-vinsn clear-right (((dest :imm)) + ((src :imm) + (nbits :s8const))) + (rlwinm dest src 0 0 (:apply - 31 nbits))) + + +(define-ppc32-vinsn logxor-high (((dest :imm)) + ((src :imm) + (high :u16const))) + (xoris dest src high)) + +(define-ppc32-vinsn logxor-low (((dest :imm)) + ((src :imm) + (low :u16const))) + (xori dest src low)) + + + +(define-ppc32-vinsn %logxor2 (((dest :imm)) + ((x :imm) + (y :imm)) + ()) + (xor dest x y)) + +(define-ppc32-vinsn %ilsl (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :u32) + (crx :crf))) + (cmpwi crx count (ash 31 ppc32::fixnumshift)) + (srwi temp count ppc32::fixnumshift) + (slw dest src temp) + (ble+ crx :foo) + (li dest 0) + :foo) + +(define-ppc32-vinsn %ilsl-c (((dest :imm)) + ((count :u8const) + (src :imm))) + ; Hard to use ppcmacroinstructions that expand into expressions involving variables. + (rlwinm dest src count 0 (:apply - ppc32::least-significant-bit count))) + + +(define-ppc32-vinsn %ilsr-c (((dest :imm)) + ((count :u8const) + (src :imm))) + (rlwinm dest src (:apply - ppc32::nbits-in-word count) count (- ppc32::least-significant-bit + ppc32::fixnumshift))) + + + +;;; 68k did the right thing for counts < 64 - fixnumshift but not if greater +;;; so load-byte fails in 3.0 also + + +(define-ppc32-vinsn %iasr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s32) + (crx :crf))) + (cmpwi crx count (ash 31 ppc32::fixnumshift)) + (srawi temp count ppc32::fixnumshift) + (sraw temp src temp) + (ble+ crx :foo) + (srawi temp src 31) + :foo + (clrrwi dest temp ppc32::fixnumshift)) + +(define-ppc32-vinsn %iasr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s32))) + (srawi temp src count) + (clrrwi dest temp ppc32::fixnumshift)) + +(define-ppc32-vinsn %ilsr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s32) + (crx :crf))) + (cmpwi crx count (ash 31 ppc32::fixnumshift)) + (srwi temp count ppc32::fixnumshift) + (srw temp src temp) + (clrrwi dest temp ppc32::fixnumshift) + (ble+ crx :foo) + (li dest 0) + :foo + ) + +#+maybe +(define-ppc32-vinsn %ilsr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s32))) + (rlwinm temp src (:apply - 32 count) count 31) + (clrrwi dest temp ppc32::fixnumshift)) + +(define-ppc32-vinsn natural-shift-left (((dest :u32)) + ((src :u32) + (count :u8const))) + (rlwinm dest src count 0 (:apply - 31 count))) + +(define-ppc32-vinsn natural-shift-right (((dest :u32)) + ((src :u32) + (count :u8const))) + (rlwinm dest src (:apply - 32 count) count 31)) + + +(define-ppc32-vinsn trap-unless-simple-array-2 (() + ((object :lisp) + (expected-flags :u32const) + (type-error :u8const)) + ((tag :u8) + (flags :u32) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :bad) + (lbz tag ppc32::misc-subtag-offset object) + (cmpwi crf tag ppc32::subtag-arrayH) + (bne crf :bad) + (lwz tag ppc32::arrayH.rank object) + (cmpwi crf tag (ash 2 ppc32::fixnumshift)) + (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags ppc32::fixnumshift))) + + (lwz flags ppc32::arrayH.flags object) + (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags ppc32::fixnumshift))) + (bne crf :bad) + (cmpw crf tag flags) + (beq crf :good) + :bad + (uuo_interr type-error object) + :good) + +(define-ppc32-vinsn trap-unless-simple-array-3 (() + ((object :lisp) + (expected-flags :u32const) + (type-error :u8const)) + ((tag :u8) + (flags :u32) + (crf :crf))) + (clrlwi tag object (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne crf :bad) + (lbz tag ppc32::misc-subtag-offset object) + (cmpwi crf tag ppc32::subtag-arrayH) + (bne crf :bad) + (lwz tag ppc32::arrayH.rank object) + (cmpwi crf tag (ash 3 ppc32::fixnumshift)) + (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags ppc32::fixnumshift))) + + (lwz flags ppc32::arrayH.flags object) + (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags ppc32::fixnumshift))) + (bne crf :bad) + (cmpw crf tag flags) + (beq crf :good) + :bad + (uuo_interr type-error object) + :good) + + + + +(define-ppc32-vinsn sign-extend-halfword (((dest :imm)) + ((src :imm))) + (slwi dest src (- 16 ppc32::fixnumshift)) + (srawi dest dest (- 16 ppc32::fixnumshift))) + +(define-ppc32-vinsn s32-highword (((dest :imm)) + ((src :s32)) + ((temp :s32))) + (srawi temp src 16) + (slwi dest temp ppc32::fixnumshift)) + + + +(define-ppc32-vinsn fixnum-add (((dest t)) + ((x t) + (y t))) + (add dest x y)) + + +(define-ppc32-vinsn fixnum-add-overflow-ool (() + ((x :imm) + (y :imm)) + ((cr0 (:crf 0)))) + (addo. ppc::arg_z x y) + (bsola- .SPfix-overflow)) + +(define-ppc32-vinsn fixnum-add-overflow-inline (((dest :lisp)) + ((x :imm) + (y :imm)) + ((cr0 (:crf 0)) + (unboxed :s32) + (header :u32))) + (addo. dest x y) + (bns+ cr0 :done) + (mtxer ppc::rzero) + (srawi unboxed dest ppc32::fixnumshift) + (li header ppc32::one-digit-bignum-header) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc32::fixnumshift)))) + (la ppc::allocptr (- ppc32::fulltag-misc 8) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw unboxed ppc32::misc-data-offset dest) + :done) + +(define-ppc32-vinsn fixnum-add-overflow-inline-skip (((dest :lisp)) + ((x :imm) + (y :imm) + (target :label)) + ((cr0 (:crf 0)) + (unboxed :s32) + (header :u32))) + (addo. dest x y) + (bns+ cr0 target) + (mtxer ppc::rzero) + (srawi unboxed dest ppc32::fixnumshift) + (li header ppc32::one-digit-bignum-header) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc32::fixnumshift)))) + (la ppc::allocptr (- ppc32::fulltag-misc 8) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw unboxed ppc32::misc-data-offset dest) + (b target)) + + + + +;;; (setq dest (- x y)) +(define-ppc32-vinsn fixnum-sub (((dest t)) + ((x t) + (y t))) + (subf dest y x)) + +(define-ppc32-vinsn fixnum-sub-from-constant (((dest :imm)) + ((x :s16const) + (y :imm))) + (subfic dest y (:apply ash x ppc32::fixnumshift))) + + + + +(define-ppc32-vinsn fixnum-sub-overflow-ool (() + ((x :imm) + (y :imm))) + (subo. ppc::arg_z x y) + (bsola- .SPfix-overflow)) + +(define-ppc32-vinsn fixnum-sub-overflow-inline (((dest :lisp)) + ((x :imm) + (y :imm)) + ((cr0 (:crf 0)) + (unboxed :s32) + (header :u32))) + (subo. dest x y) + (bns+ cr0 :done) + (mtxer ppc::rzero) + (srawi unboxed dest ppc32::fixnumshift) + (li header ppc32::one-digit-bignum-header) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc32::fixnumshift)))) + (la ppc::allocptr (- ppc32::fulltag-misc 8) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw unboxed ppc32::misc-data-offset dest) + :done) + +(define-ppc32-vinsn fixnum-sub-overflow-inline-skip (((dest :lisp)) + ((x :imm) + (y :imm) + (target :label)) + ((cr0 (:crf 0)) + (unboxed :s32) + (header :u32))) + (subo. dest x y) + (bns+ cr0 target) + (mtxer ppc::rzero) + (srawi unboxed dest ppc32::fixnumshift) + (li header ppc32::one-digit-bignum-header) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc32::fixnumshift)))) + (la ppc::allocptr (- ppc32::fulltag-misc 8) ppc::allocptr) + (twllt ppc::allocptr ppc::allocbase) + (stw header ppc32::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrwi ppc::allocptr ppc::allocptr ppc32::ntagbits) + (stw unboxed ppc32::misc-data-offset dest) + (b target)) + +;;; This is, of course, also "subtract-immediate." +(define-ppc32-vinsn add-immediate (((dest t)) + ((src t) + (upper :u32const) + (lower :u32const))) + ((:not (:pred = upper 0)) + (addis dest src upper) + ((:not (:pred = lower 0)) + (addi dest dest lower))) + ((:and (:pred = upper 0) (:not (:pred = lower 0))) + (addi dest src lower))) + +;This must unbox one reg, but hard to tell which is better. +;(The one with the smaller absolute value might be) +(define-ppc32-vinsn multiply-fixnums (((dest :imm)) + ((a :imm) + (b :imm)) + ((unboxed :s32))) + (srawi unboxed b ppc32::fixnumshift) + (mullw dest a unboxed)) + +(define-ppc32-vinsn multiply-immediate (((dest :imm)) + ((boxed :imm) + (const :s16const))) + (mulli dest boxed const)) + +;;; Mask out the code field of a base character; the result +;;; should be EXACTLY = to subtag-base-char +(define-ppc32-vinsn mask-base-char (((dest :u32)) + ((src :imm))) + (clrlwi dest src (- ppc32::nbits-in-word ppc32::charcode-shift))) + +;;; Set dest (of type :s32!) to 0 iff VAL is an istruct of type TYPE +(define-ppc32-vinsn istruct-typep (((dest :s32)) + ((val :lisp) + (type :lisp)) + ((crf :crf) + (temp :lisp))) + (clrlwi dest val (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf dest ppc32::tag-misc) + (li dest -1) + (bne crf :done) + (lbz dest ppc32::misc-subtag-offset val) + (cmpwi crf dest ppc32::subtag-istruct) + (bne crf :done) + (lwz temp ppc32::misc-data-offset val) + (subf dest type temp) + :done) + + +;; Boundp, fboundp stuff. +(define-ppc32-vinsn (ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val))))) + (bla .SPspecrefcheck)) + +(define-ppc32-vinsn ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + (lwz idx ppc32::symbol.binding-index src) + (lwz table ppc32::tcr.tlb-limit ppc32::rcontext) + (cmpw idx table) + (lwz table ppc32::tcr.tlb-pointer ppc32::rcontext) + (bge :symbol) + (lwzx dest table idx) + (cmpwi dest ppc32::subtag-no-thread-local-binding) + (bne :done) + :symbol + (lwz dest ppc32::symbol.vcell src) + :done + (tweqi dest ppc32::unbound-marker)) + +(define-ppc32-vinsn (%ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val))))) + (bla .SPspecref)) + +(define-ppc32-vinsn %ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + (lwz idx ppc32::symbol.binding-index src) + (lwz table ppc32::tcr.tlb-limit ppc32::rcontext) + (cmpw idx table) + (lwz table ppc32::tcr.tlb-pointer ppc32::rcontext) + (bge :symbol) + (lwzx dest table idx) + (cmpwi dest ppc32::subtag-no-thread-local-binding) + (bne :done) + :symbol + (lwz dest ppc32::symbol.vcell src) + :done + ) + +(define-ppc32-vinsn (setq-special :call :subprim-call) + (() + ((sym :lisp) + (val :lisp))) + (bla .SPspecset)) + + +(define-ppc32-vinsn symbol-function (((val :lisp)) + ((sym (:lisp (:ne val)))) + ((crf :crf) + (tag :u32))) + (lwz val ppc32::symbol.fcell sym) + (clrlwi tag val (- 32 ppc32::nlisptagbits)) + (cmpwi crf tag ppc32::tag-misc) + (bne- crf :bad) + (lbz tag ppc32::misc-subtag-offset val) + (cmpwi crf tag ppc32::subtag-function) + (beq+ crf :good) + :bad + (uuo_interr arch::error-udf sym) + :good) + +(define-ppc32-vinsn (temp-push-unboxed-word :push :word :tsp) + (() + ((w :u32))) + (stwu ppc::tsp -16 ppc::tsp) + (stw ppc::tsp 4 ppc::tsp) + (stw w 8 ppc::tsp)) + +(define-ppc32-vinsn (temp-pop-unboxed-word :pop :word :tsp) + (((w :u32)) + ()) + (lwz w 8 ppc::tsp) + (la ppc::tsp 16 ppc::tsp)) + +(define-ppc32-vinsn (temp-push-double-float :push :doubleword :tsp) + (((d :double-float)) + ()) + (stwu ppc::tsp -16 ppc::tsp) + (stw ppc::tsp 4 ppc::tsp) + (stfd d 8 ppc::tsp)) + +(define-ppc32-vinsn (temp-pop-double-float :pop :doubleword :tsp) + (() + ((d :double-float))) + (lfd d 8 ppc::tsp) + (la ppc::tsp 16 ppc::tsp)) + +(define-ppc32-vinsn (temp-push-single-float :push :word :tsp) + (((s :single-float)) + ()) + (stwu ppc::tsp -16 ppc::tsp) + (stw ppc::tsp 4 ppc::tsp) + (stfs s 8 ppc::tsp)) + +(define-ppc32-vinsn (temp-pop-single-float :pop :word :tsp) + (() + ((s :single-float))) + (lfs s 8 ppc::tsp) + (la ppc::tsp 16 ppc::tsp)) + + +(define-ppc32-vinsn (save-nvrs-individually :push :node :vsp :multiple) + (() + ((first :u8const))) + (stwu ppc::save0 -4 ppc::vsp) + ((:pred <= first ppc::save1) + (stwu ppc::save1 -4 ppc::vsp) + ((:pred <= first ppc::save2) + (stwu ppc::save2 -4 ppc::vsp) + ((:pred <= first ppc::save3) + (stwu ppc::save3 -4 ppc::vsp) + ((:pred <= first ppc::save4) + (stwu ppc::save4 -4 ppc::vsp) + ((:pred <= first ppc::save5) + (stwu ppc::save5 -4 ppc::vsp) + ((:pred <= first ppc::save6) + (stwu ppc::save6 -4 ppc::vsp) + ((:pred = first ppc::save7) + (stwu ppc::save7 -4 ppc::vsp))))))))) + +(define-ppc32-vinsn (save-nvrs :push :node :vsp :multiple) + (() + ((first :u8const))) + ((:pred <= first ppc::save3) + (subi ppc::vsp ppc::vsp (:apply * 4 (:apply - 32 first))) + (stmw first 0 ppc::vsp)) + ((:pred >= first ppc::save2) + (stwu ppc::save0 -4 ppc::vsp) + ((:pred <= first ppc::save1) + (stwu ppc::save1 -4 ppc::vsp) + ((:pred = first ppc::save2) + (stwu ppc::save2 -4 ppc::vsp))))) + + +(define-ppc32-vinsn (restore-nvrs :pop :node :vsp :multiple) + (() + ((firstreg :u8const) + (basereg :imm) + (offset :s16const))) + ((:pred <= firstreg ppc::save3) + (lmw firstreg offset basereg)) + ((:pred = firstreg ppc::save2) + (lwz ppc::save2 offset basereg) + (lwz ppc::save1 (:apply + offset 4) basereg) + (lwz ppc::save0 (:apply + offset 8) basereg)) + ((:pred = firstreg ppc::save1) + (lwz ppc::save1 offset basereg) + (lwz ppc::save0 (:apply + offset 4) basereg)) + ((:pred = firstreg ppc::save0) + (lwz ppc::save0 offset basereg))) + +(define-ppc32-vinsn %current-frame-ptr (((dest :imm)) + ()) + (mr dest ppc::sp)) + +(define-ppc32-vinsn %current-tcr (((dest :imm)) + ()) + (mr dest ppc32::rcontext)) + +(define-ppc32-vinsn (dpayback :call :subprim-call) (() + ((n :s16const)) + ((temp (:u32 #.ppc::imm0)))) + ((:pred > n 1) + (li temp n) + (bla .SPunbind-n)) + ((:pred = n 1) + (bla .SPunbind))) + +(define-ppc32-vinsn zero-double-float-register + (((dest :double-float)) + ()) + (fmr dest ppc::fp-zero)) + +(define-ppc32-vinsn zero-single-float-register + (((dest :single-float)) + ()) + (fmr dest ppc::fp-zero)) + +(define-ppc32-vinsn load-double-float-constant + (((dest :double-float)) + ((high t) + (low t))) + (stw high -8 ppc::sp) + (stw low -4 ppc::sp) + (lfd dest -8 ppc::sp )) + +(define-ppc32-vinsn load-single-float-constant + (((dest :single-float)) + ((src t))) + (stw src -4 ppc::sp) + (lfs dest -4 ppc::sp)) + +(define-ppc32-vinsn load-indexed-node (((node :lisp)) + ((base :lisp) + (offset :s16const))) + (lwz node offset base)) + +(define-ppc32-vinsn check-exact-nargs (() + ((n :u16const))) + (twnei ppc::nargs (:apply ash n 2))) + +(define-ppc32-vinsn check-min-nargs (() + ((min :u16const))) + (twllti ppc::nargs (:apply ash min 2))) + +(define-ppc32-vinsn check-max-nargs (() + ((max :u16const))) + (twlgti ppc::nargs (:apply ash max 2))) + +;;; Save context and establish FN. The current VSP is the the +;;; same as the caller's, e.g., no arguments were vpushed. +(define-ppc32-vinsn save-lisp-context-vsp (() + () + ((imm :u32))) + (lwz imm ppc32::tcr.cs-limit ppc32::rcontext) + (stwu ppc::sp (- ppc32::lisp-frame.size) ppc::sp) + (stw ppc::fn ppc32::lisp-frame.savefn ppc::sp) + (stw ppc::loc-pc ppc32::lisp-frame.savelr ppc::sp) + (stw ppc::vsp ppc32::lisp-frame.savevsp ppc::sp) + (mr ppc::fn ppc::nfn) + ;; Do a stack-probe ... + (twllt ppc::sp imm)) + +;;; Do the same thing via a subprim call. +(define-ppc32-vinsn (save-lisp-context-vsp-ool :call :subprim-call) + (() + () + ((imm (:u32 #.ppc::imm0)))) + (bla .SPsavecontextvsp)) + +(define-ppc32-vinsn save-lisp-context-offset (() + ((nbytes-vpushed :u16const)) + ((imm :u32))) + (la imm nbytes-vpushed ppc::vsp) + (stwu ppc::sp (- ppc32::lisp-frame.size) ppc::sp) + (stw ppc::fn ppc32::lisp-frame.savefn ppc::sp) + (stw ppc::loc-pc ppc32::lisp-frame.savelr ppc::sp) + (stw imm ppc32::lisp-frame.savevsp ppc::sp) + (mr ppc::fn ppc::nfn) + ;; Do a stack-probe ... + (lwz imm ppc32::tcr.cs-limit ppc32::rcontext) + (twllt ppc::sp imm)) + +(define-ppc32-vinsn save-lisp-context-offset-ool (() + ((nbytes-vpushed :u16const)) + ((imm (:u32 #.ppc::imm0)))) + (li imm nbytes-vpushed) + (bla .SPsavecontext0)) + + +(define-ppc32-vinsn save-lisp-context-lexpr (() + () + ((imm :u32))) + (stwu ppc::sp (- ppc32::lisp-frame.size) ppc::sp) + (stw ppc::rzero ppc32::lisp-frame.savefn ppc::sp) + (stw ppc::loc-pc ppc32::lisp-frame.savelr ppc::sp) + (stw ppc::vsp ppc32::lisp-frame.savevsp ppc::sp) + (mr ppc::fn ppc::nfn) + ;; Do a stack-probe ... + (lwz imm ppc32::tcr.cs-limit ppc32::rcontext) + (twllt ppc::sp imm)) + +(define-ppc32-vinsn save-cleanup-context (() + ()) + ;; SP was this deep just a second ago, so no need to do a stack-probe. + (mflr ppc::loc-pc) + (stwu ppc::sp (- ppc32::lisp-frame.size) ppc::sp) + (stw ppc::rzero ppc32::lisp-frame.savefn ppc::sp) + (stw ppc::loc-pc ppc32::lisp-frame.savelr ppc::sp) + (stw ppc::vsp ppc32::lisp-frame.savevsp ppc::sp)) + +;; Vpush the argument registers. We got at least "min-fixed" args; +;; that knowledge may help us generate better code. +(define-ppc32-vinsn (save-lexpr-argregs :call :subprim-call) + (() + ((min-fixed :u16const)) + ((crfx :crf) + (crfy :crf) + (entry-vsp (:u32 #.ppc::imm0)) + (arg-temp :u32))) + ((:pred >= min-fixed $numppcargregs) + (stwu ppc::arg_x -4 ppc::vsp) + (stwu ppc::arg_y -4 ppc::vsp) + (stwu ppc::arg_z -4 ppc::vsp)) + ((:pred = min-fixed 2) ; at least 2 args + (cmplwi crfx ppc::nargs (ash 2 ppc32::word-shift)) + (beq crfx :yz2) ; skip arg_x if exactly 2 + (stwu ppc::arg_x -4 ppc::vsp) + :yz2 + (stwu ppc::arg_y -4 ppc::vsp) + (stwu ppc::arg_z -4 ppc::vsp)) + ((:pred = min-fixed 1) ; at least one arg + (cmplwi crfx ppc::nargs (ash 2 ppc32::word-shift)) + (blt crfx :z1) ; branch if exactly one + (beq crfx :yz1) ; branch if exactly two + (stwu ppc::arg_x -4 ppc::vsp) + :yz1 + (stwu ppc::arg_y -4 ppc::vsp) + :z1 + (stwu ppc::arg_z -4 ppc::vsp)) + ((:pred = min-fixed 0) + (cmplwi crfx ppc::nargs (ash 2 ppc32::word-shift)) + (cmplwi crfy ppc::nargs 0) + (beq crfx :yz0) ; exactly two + (beq crfy :none) ; exactly zero + (blt crfx :z0) ; one + ; Three or more ... + (stwu ppc::arg_x -4 ppc::vsp) + :yz0 + (stwu ppc::arg_y -4 ppc::vsp) + :z0 + (stwu ppc::arg_z -4 ppc::vsp) + :none + ) + ((:pred = min-fixed 0) + (stwu ppc::nargs -4 ppc::vsp)) + ((:not (:pred = min-fixed 0)) + (subi arg-temp ppc::nargs (:apply ash min-fixed ppc32::word-shift)) + (stwu arg-temp -4 ppc::vsp)) + (add entry-vsp ppc::vsp ppc::nargs) + (la entry-vsp 4 entry-vsp) + (bla .SPlexpr-entry)) + + +(define-ppc32-vinsn (jump-return-pc :jumpLR) + (() + ()) + (blr)) + +(define-ppc32-vinsn (restore-full-lisp-context :lispcontext :pop :csp :lrRestore) + (() + ()) + (lwz ppc::loc-pc ppc32::lisp-frame.savelr ppc::sp) + (lwz ppc::vsp ppc32::lisp-frame.savevsp ppc::sp) + (lwz ppc::fn ppc32::lisp-frame.savefn ppc::sp) + (mtlr ppc::loc-pc) + (la ppc::sp ppc32::lisp-frame.size ppc::sp)) + + + +(define-ppc32-vinsn (restore-full-lisp-context-ool :lispcontext :pop :csp :lrRestore) + (() + ()) + (bla .SPrestorecontext) + (mtlr ppc::loc-pc)) + +(define-ppc32-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR) + (() + ()) + (ba .SPpopj)) + +;;; Exiting from an UNWIND-PROTECT cleanup is similar to +;;; (and a little simpler than) returning from a function. +(define-ppc32-vinsn restore-cleanup-context (() + ()) + (lwz ppc::loc-pc ppc32::lisp-frame.savelr ppc::sp) + (mtlr ppc::loc-pc) + (la ppc::sp ppc32::lisp-frame.size ppc::sp)) + + + +(define-ppc32-vinsn default-1-arg (() + ((min :u16const)) + ((crf :crf))) + (cmplwi crf ppc::nargs (:apply ash min 2)) + (bne crf :done) + ((:pred >= min 3) + (stwu ppc::arg_x -4 ppc::vsp)) + ((:pred >= min 2) + (mr ppc::arg_x ppc::arg_y)) + ((:pred >= min 1) + (mr ppc::arg_y ppc::arg_z)) + (li ppc::arg_z ppc32::nil-value) + :done) + +(define-ppc32-vinsn default-2-args (() + ((min :u16const)) + ((crf :crf))) + (cmplwi crf ppc::nargs (:apply ash (:apply 1+ min) 2)) + (bgt crf :done) + (beq crf :one) + ; We got "min" args; arg_y & arg_z default to nil + ((:pred >= min 3) + (stwu ppc::arg_x -4 ppc::vsp)) + ((:pred >= min 2) + (stwu ppc::arg_y -4 ppc::vsp)) + ((:pred >= min 1) + (mr ppc::arg_x ppc::arg_z)) + (li ppc::arg_y ppc32::nil-value) + (b :last) + :one + ; We got min+1 args: arg_y was supplied, arg_z defaults to nil. + ((:pred >= min 2) + (stwu ppc::arg_x -4 ppc::vsp)) + ((:pred >= min 1) + (mr ppc::arg_x ppc::arg_y)) + (mr ppc::arg_y ppc::arg_z) + :last + (li ppc::arg_z ppc32::nil-value) + :done) + +(define-ppc32-vinsn default-3-args (() + ((min :u16const)) + ((crfx :crf) + (crfy :crf))) + (cmplwi crfx ppc::nargs (:apply ash (:apply + 2 min) 2)) + (cmplwi crfy ppc::nargs (:apply ash min 2)) + (bgt crfx :done) + (beq crfx :two) + (beq crfy :none) + ; The first (of three) &optional args was supplied. + ((:pred >= min 2) + (stwu ppc::arg_x -4 ppc::vsp)) + ((:pred >= min 1) + (stwu ppc::arg_y -4 ppc::vsp)) + (mr ppc::arg_x ppc::arg_z) + (b :last-2) + :two + ; The first two (of three) &optional args were supplied. + ((:pred >= min 1) + (stwu ppc::arg_x -4 ppc::vsp)) + (mr ppc::arg_x ppc::arg_y) + (mr ppc::arg_y ppc::arg_z) + (b :last-1) + ; None of the three &optional args was provided. + :none + ((:pred >= min 3) + (stwu ppc::arg_x -4 ppc::vsp)) + ((:pred >= min 2) + (stwu ppc::arg_y -4 ppc::vsp)) + ((:pred >= min 1) + (stwu ppc::arg_z -4 ppc::vsp)) + (li ppc::arg_x ppc32::nil-value) + :last-2 + (li ppc::arg_y ppc32::nil-value) + :last-1 + (li ppc::arg_z ppc32::nil-value) + :done) + +(define-ppc32-vinsn save-lr (() + ()) + (mflr ppc::loc-pc)) + +;;; "n" is the sum of the number of required args + +;;; the number of &optionals. +(define-ppc32-vinsn (default-optionals :call :subprim-call) (() + ((n :u16const))) + (li ppc::imm0 (:apply ash n 2)) + (bla .SPdefault-optional-args)) + +;;; fname contains a known symbol +(define-ppc32-vinsn (call-known-symbol :call) (((result (:lisp ppc::arg_z))) + ()) + (lwz ppc::nfn ppc32::symbol.fcell ppc::fname) + (lwz ppc::temp0 ppc32::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctrl)) + +(define-ppc32-vinsn (jump-known-symbol :jumplr) (() + ()) + (lwz ppc::nfn ppc32::symbol.fcell ppc::fname) + (lwz ppc::temp0 ppc32::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctr)) + +(define-ppc32-vinsn (call-known-function :call) (() + ()) + (lwz ppc::temp0 ppc32::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctrl)) + +(define-ppc32-vinsn (jump-known-function :jumplr) (() + ()) + (lwz ppc::temp0 ppc32::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctr)) + +(define-ppc32-vinsn %schar8 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32))) + (srwi imm idx ppc32::fixnumshift) + (addi imm imm ppc32::misc-data-offset) + (lbzx imm str imm) + (slwi imm imm ppc32::charcode-shift) + (addi char imm ppc32::subtag-character)) + +(define-ppc32-vinsn %schar32 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32))) + (addi imm idx ppc32::misc-data-offset) + (lwzx imm str imm) + (slwi imm imm ppc32::charcode-shift) + (addi char imm ppc32::subtag-character)) + + +(define-ppc32-vinsn %set-schar8 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm :u32) + (imm1 :u32) + (cr0 (:crf 0)))) + (srwi imm idx ppc32::fixnumshift) + (addi imm imm ppc32::misc-data-offset) + (srwi imm1 char ppc32::charcode-shift) + (stbx imm1 str imm) + ) + +(define-ppc32-vinsn %set-schar32 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm :u32) + (imm1 :u32) + (cr0 (:crf 0)))) + (addi imm idx ppc32::misc-data-offset) + (srwi imm1 char ppc32::charcode-shift) + (stwx imm1 str imm) + ) + +(define-ppc32-vinsn %set-scharcode8 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u32) + (imm1 :u32) + (cr0 (:crf 0)))) + (srwi imm idx ppc32::fixnumshift) + (addi imm imm ppc32::misc-data-offset) + (srwi imm1 code ppc32::fixnumshift) + (stbx imm1 str imm) + ) + + +(define-ppc32-vinsn %set-scharcode32 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u32) + (imm1 :u32))) + (addi imm idx ppc32::misc-data-offset) + (srwi imm1 code ppc32::fixnumshift) + (stwx imm1 str imm) + ) + +(define-ppc32-vinsn %scharcode8 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32) + (cr0 (:crf 0)))) + (srwi imm idx ppc32::fixnumshift) + (addi imm imm ppc32::misc-data-offset) + (lbzx imm str imm) + (slwi code imm ppc32::fixnumshift)) + +(define-ppc32-vinsn %scharcode32 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32) + (cr0 (:crf 0)))) + (addi imm idx ppc32::misc-data-offset) + (lwzx imm str imm) + (slwi code imm ppc32::fixnumshift)) + +;;; Clobbers LR +(define-ppc32-vinsn (%debug-trap :call :subprim-call) (() + ()) + (bla .SPbreakpoint) + ) + + +(define-ppc32-vinsn eep.address (((dest t)) + ((src (:lisp (:ne dest ))))) + (lwz dest (+ (ash 1 2) ppc32::misc-data-offset) src) + (tweqi dest ppc32::nil-value)) + +(define-ppc32-vinsn %natural+ (((dest :u32)) + ((x :u32) (y :u32))) + (add dest x y)) + +(define-ppc32-vinsn %natural+-c (((dest :u32)) + ((x :u32) (y :u16const))) + (addi dest x y)) + +(define-ppc32-vinsn %natural- (((dest :u32)) + ((x :u32) (y :u32))) + (sub dest x y)) + +(define-ppc32-vinsn %natural--c (((dest :u32)) + ((x :u32) (y :u16const))) + (subi dest x y)) + +(define-ppc32-vinsn %natural-logior (((dest :u32)) + ((x :u32) (y :u32))) + (or dest x y)) + +(define-ppc32-vinsn %natural-logior-c (((dest :u32)) + ((x :u32) (high :u16const) (low :u16const))) + ((:not (:pred = high 0)) + (oris dest x high)) + ((:not (:pred = low 0)) + (ori dest x low))) + +(define-ppc32-vinsn %natural-logxor (((dest :u32)) + ((x :u32) (y :u32))) + (xor dest x y)) + +(define-ppc32-vinsn %natural-logxor-c (((dest :u32)) + ((x :u32) (high :u16const) (low :u16const))) + ((:not (:pred = high 0)) + (xoris dest x high)) + ((:not (:pred = low 0)) + (xori dest x low))) + +(define-ppc32-vinsn %natural-logand (((dest :u32)) + ((x :u32) (y :u32))) + (and dest x y)) + +(define-ppc32-vinsn %natural-logand-high-c (((dest :u32)) + ((x :u32) (high :u16const)) + ((cr0 (:crf 0)))) + (andis. dest x high)) + +(define-ppc32-vinsn %natural-logand-low-c (((dest :u64)) + ((x :u64) (low :u16const)) + ((cr0 (:crf 0)))) + (andi. dest x low)) + +(define-ppc32-vinsn %natural-logand-mask-c (((dest :u32)) + ((x :u32) + (start :u8const) + (end :u8const))) + (rlwinm dest x 0 start end)) + +(define-ppc32-vinsn disable-interrupts (((dest :lisp)) + () + ((temp :imm) + (temp2 :imm))) + (lwz temp2 ppc32::tcr.tlb-pointer ppc32::rcontext) + (li temp -4) + (lwz dest ppc32::interrupt-level-binding-index temp2) + (stw temp ppc32::interrupt-level-binding-index temp2)) + +(define-ppc32-vinsn load-character-constant (((dest :lisp)) + ((code :u32const))) + (ori dest ppc::rzero (:apply logior (:apply ash (:apply logand #xff code) ppc32::charcode-shift) ppc32::subtag-character)) + ((:not (:pred = 0 (:apply ldb (byte 16 8) code))) + (oris dest dest (:apply ldb (byte 16 8) code)))) + + +(define-ppc32-vinsn %symbol->symptr (((dest :lisp)) + ((src :lisp)) + ((tag :u8) + (crf0 :crf) + (crf1 :crf))) + (clrlwi tag src (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (cmpwi crf0 src ppc32::nil-value) + (cmpwi crf1 tag ppc32::tag-misc) + (beq crf0 :nilsym) + (bne crf1 :do-trap) + (lbz tag ppc32::misc-subtag-offset src) + :do-trap + (twnei tag ppc32::subtag-symbol) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (mr dest src)) + (b :done) + :nilsym + (li dest (+ ppc32::nilsym-offset ppc32::nil-value)) + :done) + +;;; Subprim calls. Done this way for the benefit of VINSN-OPTIMIZE. +(defmacro define-ppc32-subprim-call-vinsn ((name &rest other-attrs) spno) + `(define-ppc32-vinsn (,name :call :subprim-call ,@other-attrs) (() ()) + (bla ,spno))) + +(defmacro define-ppc32-subprim-jump-vinsn ((name &rest other-attrs) spno) + `(define-ppc32-vinsn (,name :jumpLR ,@other-attrs) (() ()) + (ba ,spno))) + +(define-ppc32-subprim-jump-vinsn (restore-interrupt-level) .SPrestoreintlevel) + +(define-ppc32-subprim-call-vinsn (save-values) .SPsave-values) + +(define-ppc32-subprim-call-vinsn (recover-values) .SPrecover-values) + +(define-ppc32-subprim-call-vinsn (add-values) .SPadd-values) + +(define-ppc32-subprim-jump-vinsn (jump-known-symbol-ool) .SPjmpsym) + +(define-ppc32-subprim-call-vinsn (call-known-symbol-ool) .SPjmpsym) + +(define-ppc32-subprim-call-vinsn (pass-multiple-values) .SPmvpass) + +(define-ppc32-subprim-call-vinsn (pass-multiple-values-symbol) .SPmvpasssym) + +(define-ppc32-subprim-jump-vinsn (tail-call-sym-gen) .SPtcallsymgen) + +(define-ppc32-subprim-jump-vinsn (tail-call-fn-gen) .SPtcallnfngen) + +(define-ppc32-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide) + +(define-ppc32-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide) + +(define-ppc32-subprim-jump-vinsn (tail-call-sym-vsp) .SPtcallsymvsp) + +(define-ppc32-subprim-jump-vinsn (tail-call-fn-vsp) .SPtcallnfnvsp) + +(define-ppc32-subprim-call-vinsn (funcall) .SPfuncall) + +(define-ppc32-subprim-jump-vinsn (tail-funcall-gen) .SPtfuncallgen) + +(define-ppc32-subprim-jump-vinsn (tail-funcall-slide) .SPtfuncallslide) + +(define-ppc32-subprim-jump-vinsn (tail-funcall-vsp) .SPtfuncallvsp) + +(define-ppc32-subprim-call-vinsn (spread-lexpr) .SPspread-lexpr-z) + +(define-ppc32-subprim-call-vinsn (spread-list) .SPspreadargz) + +(define-ppc32-subprim-call-vinsn (pop-argument-registers) .SPvpopargregs) + +(define-ppc32-subprim-call-vinsn (getu32) .SPgetu32) + +(define-ppc32-subprim-call-vinsn (gets32) .SPgets32) + +(define-ppc32-subprim-call-vinsn (getxlong) .SPgetXlong) + +(define-ppc32-subprim-call-vinsn (stack-cons-list) .SPstkconslist) + +(define-ppc32-subprim-call-vinsn (list) .SPconslist) + +(define-ppc32-subprim-call-vinsn (stack-cons-list*) .SPstkconslist-star) + +(define-ppc32-subprim-call-vinsn (list*) .SPconslist-star) + +(define-ppc32-subprim-call-vinsn (make-stack-block) .SPmakestackblock) + +(define-ppc32-subprim-call-vinsn (make-stack-block0) .Spmakestackblock0) + +(define-ppc32-subprim-call-vinsn (make-stack-list) .Spmakestacklist) + +(define-ppc32-subprim-call-vinsn (make-stack-vector) .SPmkstackv) + +(define-ppc32-subprim-call-vinsn (make-stack-gvector) .SPstkgvector) + +(define-ppc32-subprim-call-vinsn (stack-misc-alloc) .SPstack-misc-alloc) + +(define-ppc32-subprim-call-vinsn (stack-misc-alloc-init) .SPstack-misc-alloc-init) + +(define-ppc32-subprim-call-vinsn (bind-nil) .SPbind-nil) + +(define-ppc32-subprim-call-vinsn (bind-self) .SPbind-self) + +(define-ppc32-subprim-call-vinsn (bind-self-boundp-check) .SPbind-self-boundp-check) + +(define-ppc32-subprim-call-vinsn (bind) .SPbind) + +(define-ppc32-subprim-jump-vinsn (nvalret :jumpLR) .SPnvalret) + +(define-ppc32-subprim-call-vinsn (nthrowvalues) .SPnthrowvalues) + +(define-ppc32-subprim-call-vinsn (nthrow1value) .SPnthrow1value) + +(define-ppc32-subprim-call-vinsn (slide-values) .SPmvslide) + +(define-ppc32-subprim-call-vinsn (macro-bind) .SPmacro-bind) + +(define-ppc32-subprim-call-vinsn (destructuring-bind-inner) .SPdestructuring-bind-inner) + +(define-ppc32-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind) + +(define-ppc32-subprim-call-vinsn (simple-keywords) .SPsimple-keywords) + +(define-ppc32-subprim-call-vinsn (keyword-args) .SPkeyword-args) + +(define-ppc32-subprim-call-vinsn (keyword-bind) .SPkeyword-bind) + +(define-ppc32-subprim-call-vinsn (stack-rest-arg) .SPstack-rest-arg) + +(define-ppc32-subprim-call-vinsn (req-stack-rest-arg) .SPreq-stack-rest-arg) + +(define-ppc32-subprim-call-vinsn (stack-cons-rest-arg) .SPstack-cons-rest-arg) + +(define-ppc32-subprim-call-vinsn (heap-rest-arg) .SPheap-rest-arg) + +(define-ppc32-subprim-call-vinsn (req-heap-rest-arg) .SPreq-heap-rest-arg) + +(define-ppc32-subprim-call-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg) + +(define-ppc32-subprim-call-vinsn (opt-supplied-p) .SPopt-supplied-p) + +(define-ppc32-subprim-call-vinsn (gvector) .SPgvector) + +(define-ppc32-vinsn (nth-value :call :subprim-call) (((result :lisp)) + ()) + (bla .SPnthvalue)) + +(define-ppc32-subprim-call-vinsn (fitvals) .SPfitvals) + +(define-ppc32-subprim-call-vinsn (misc-alloc) .SPmisc-alloc) + +(define-ppc32-subprim-call-vinsn (misc-alloc-init) .SPmisc-alloc-init) + +(define-ppc32-subprim-call-vinsn (integer-sign) .SPinteger-sign) + +;;; 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-ppc32-vinsn (throw :jump-unknown) (() + ()) + (bla .SPthrow)) + +(define-ppc32-subprim-call-vinsn (mkcatchmv) .SPmkcatchmv) + +(define-ppc32-subprim-call-vinsn (mkcatch1v) .SPmkcatch1v) + +(define-ppc32-subprim-call-vinsn (setqsym) .SPsetqsym) + +(define-ppc32-subprim-call-vinsn (ksignalerr) .SPksignalerr) + +(define-ppc32-subprim-call-vinsn (subtag-misc-ref) .SPsubtag-misc-ref) + +(define-ppc32-subprim-call-vinsn (subtag-misc-set) .SPsubtag-misc-set) + +(define-ppc32-subprim-call-vinsn (mkunwind) .SPmkunwind) +(define-ppc32-subprim-call-vinsn (nmkunwind) .SPnmkunwind) + + +(define-ppc32-subprim-call-vinsn (progvsave) .SPprogvsave) + +(define-ppc32-subprim-jump-vinsn (progvrestore) .SPprogvrestore) + +(define-ppc32-subprim-call-vinsn (eabi-syscall) .SPeabi-syscall) + +(define-ppc32-subprim-call-vinsn (misc-ref) .SPmisc-ref) + +(define-ppc32-subprim-call-vinsn (misc-set) .SPmisc-set) + +(define-ppc32-subprim-call-vinsn (gets64) .SPgets64) + +(define-ppc32-subprim-call-vinsn (getu64) .SPgetu64) + +(define-ppc32-subprim-call-vinsn (makeu64) .SPmakeu64) + +(define-ppc32-subprim-call-vinsn (makes64) .SPmakes64) + +(define-ppc32-vinsn (poweropen-syscall :call :subprim-call) (() + ()) + (stw ppc::rzero ppc32::c-frame.crsave ppc::sp) + (bla .SPpoweropen-syscall)) + +(define-ppc32-vinsn (poweropen-syscall-s64 :call :subprim-call) (() + ()) + (stw ppc::sp ppc32::c-frame.crsave ppc::sp) + (bla .SPpoweropen-syscall)) + +(define-ppc32-subprim-call-vinsn (eabi-ff-call) .SPeabi-ff-call) + +(define-ppc32-subprim-call-vinsn (poweropen-ff-call) .SPpoweropen-ffcall) + +(define-ppc32-subprim-call-vinsn (poweropen-ff-callX) .SPpoweropen-ffcallX) + +(define-ppc32-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0) + +(define-ppc32-vinsn bind-interrupt-level-0-inline (() + () + ((tlb :imm) + (value :imm) + (link :imm) + (temp :imm))) + (lwz tlb ppc32::tcr.tlb-pointer ppc32::rcontext) + (lwz value ppc32::interrupt-level-binding-index tlb) + (lwz link ppc32::tcr.db-link ppc32::rcontext) + (cmpwi value 0) + (li temp ppc32::interrupt-level-binding-index) + (stwu value -4 ppc::vsp) + (stwu temp -4 ppc::vsp) + (stwu link -4 ppc::vsp) + (stw ppc::rzero ppc32::interrupt-level-binding-index tlb) + (stw ppc::vsp ppc32::tcr.db-link ppc32::rcontext) + (beq+ :done) + (mr ppc::nargs value) + (bgt :do-trap) + (lwz ppc::nargs ppc32::tcr.interrupt-pending ppc32::rcontext) + :do-trap + (twgti ppc::nargs 0) + :done) + + + +(define-ppc32-subprim-call-vinsn (bind-interrupt-level-m1) .SPbind-interrupt-level-m1) + +(define-ppc32-vinsn bind-interrupt-level-m1-inline (() + () + ((tlb :imm) + (oldvalue :imm) + (link :imm) + (newvalue :imm) + (idx :imm))) + (li newvalue (ash -1 ppc32::fixnumshift)) + (li idx ppc32::interrupt-level-binding-index) + (lwz tlb ppc32::tcr.tlb-pointer ppc32::rcontext) + (lwz oldvalue ppc32::interrupt-level-binding-index tlb) + (lwz link ppc32::tcr.db-link ppc32::rcontext) + (stwu oldvalue -4 ppc::vsp) + (stwu idx -4 ppc::vsp) + (stwu link -4 ppc::vsp) + (stw newvalue ppc32::interrupt-level-binding-index tlb) + (stw ppc::vsp ppc32::tcr.db-link ppc32::rcontext) + :done) + +(define-ppc32-subprim-call-vinsn (bind-interrupt-level) .SPbind-interrupt-level) + +(define-ppc32-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level) + +(define-ppc32-vinsn unbind-interrupt-level-inline (() + () + ((tlb :imm) + (link :imm) + (value :imm) + (save-nargs :u32) + (crf0 :crf) + (crf1 :crf))) + (lwz tlb ppc32::tcr.tlb-pointer ppc32::rcontext) + (lwz value ppc32::interrupt-level-binding-index tlb) + (lwz link ppc32::tcr.db-link ppc32::rcontext) + (cmpwi crf1 value 0) + (lwz value 8 link) + (lwz link 0 link) + (cmpwi crf0 value 0) + (stw value ppc32::interrupt-level-binding-index tlb) + (stw link ppc32::tcr.db-link ppc32::rcontext) + (bge crf1 :done) + (blt crf0 :done) + (mr save-nargs ppc::nargs) + (lwz ppc::nargs ppc32::tcr.interrupt-pending ppc32::rcontext) + (twgti ppc::nargs 0) + (mr ppc::nargs save-nargs) + :done) + + + +(define-ppc32-vinsn branch-unless-arg-fixnum (() + ((arg :lisp) + (lab :label)) + ((cr0 (:crf 0)) + (tag :u8))) + (clrlwi. tag arg (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (bne cr0 lab)) + +(define-ppc32-vinsn branch-unless-both-args-fixnums (() + ((arg0 :lisp) + (arg1 :lisp) + (lab :label)) + ((cr0 (:crf 0)) + (tag :u8))) + (clrlwi tag arg0 (- ppc32::nbits-in-word ppc32::nlisptagbits)) + (rlwimi. tag arg1 ppc32::nlisptagbits 28 29) + (bne cr0 lab)) + +;;; In case ppc32::*ppc-opcodes* was changed since this file was compiled. +(queue-fixup + (fixup-vinsn-templates *ppc32-vinsn-templates* ppc::*ppc-opcode-numbers*)) + +(provide "PPC32-VINSNS") + Index: /branches/experimentation/later/source/compiler/PPC/PPC64/.cvsignore =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC64/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC64/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-arch.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-arch.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-arch.lisp (revision 8058) @@ -0,0 +1,995 @@ +;;;-*- Mode: Lisp; Package: (PPC64 :use CL) -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; This file matches "ccl:lisp-kernel;constants64.h" & +;;; "ccl:lisp-kernel;constants64.s" + +(defpackage "PPC64" + (:use "CL") + #+ppc64-target + (:nicknames "TARGET")) + + +(in-package "PPC64") + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant rcontext 2) ;sigh. Could use r13+bias on Linux, + ; but Apple hasn't invented tls yet. +(defconstant nbits-in-word 64) +(defconstant least-significant-bit 63) +(defconstant nbits-in-byte 8) +(defconstant ntagbits 4) +(defconstant nlisptagbits 3) +(defconstant nfixnumtagbits 3) ; See ? +(defconstant nlowtagbits 2) +(defconstant num-subtag-bits 8) ; tag part of header is 8 bits wide +(defconstant fixnumshift nfixnumtagbits) +(defconstant fixnum-shift fixnumshift) ; A pet name for it. +(defconstant fulltagmask (1- (ash 1 ntagbits))) ; Only needed by GC/very low-level code +(defconstant full-tag-mask fulltagmask) +(defconstant tagmask (1- (ash 1 nlisptagbits))) +(defconstant tag-mask tagmask) +(defconstant fixnummask (1- (ash 1 nfixnumtagbits))) +(defconstant fixnum-mask fixnummask) +(defconstant subtag-mask (1- (ash 1 num-subtag-bits))) +(defconstant ncharcodebits 8) ;24 +(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 target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits)))) +(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits))))) +(defmacro define-subtag (name tag value) + `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits)))) + +;;; PPC64 stuff and tags. + +;;; There are several ways to look at the 4 tag bits of any object or +;;; header. Looking at the low 2 bits, we can classify things as +;;; follows (I'm not sure if we'd ever want to do this) : +;;; +;;; #b00 a "primary" object: fixnum, cons, uvector +;;; #b01 an immediate +;;; #b10 the header on an immediate uvector +;;; #b11 the header on a node (pointer-containing) uvector +;; +;;; Note that the ppc64's LD and STD instructions require that the low +;;; two bits of the constant displacement be #b00. If we want to use constant +;;; offsets to access CONS and UVECTOR fields, we're pretty much obligated +;;; to ensure that CONS and UVECTOR have tags that also end in #b00, and +;;; fixnum addition and subtraction work better when fixnum tags are all 0. +;;; We generally have to look at all 4 tag bits before we really know what +;;; class of "potentially primary" object we're looking at. +;;; If we look at 3 tag bits, we can see: +;;; +;;; #b000 fixnum +;;; #b001 immediate +;;; #b010 immedate-header +;;; #b011 node-header +;;; #b100 CONS or UVECTOR +;;; #b101 immediate +;;; #b110 immediate-header +;;; #b111 node-header +;;; + +(defconstant tag-fixnum 0) +(defconstant tag-imm-0 1) +(defconstant tag-immheader-0 2) +(defconstant tag-nodeheader-0 3) +(defconstant tag-memory 4) +(defconstant tag-imm-2 5) +(defconstant tag-immheader2 6) +(defconstant tag-nodeheader2 7) + + +;;; Note how we're already winding up with lots of header and immediate +;;; "classes". That might actually be useful. +;; +;;; When we move to 4 bits, we wind up (obviously) with 4 tags of the form +;;; #bxx00. There are two partitionings that make (some) sense: we can either +;;; use 2 of these for (even and odd) fixnums, or we can give NIL a tag +;;; that's congruent (mod 16) with CONS. There seem to be a lot of tradeoffs +;;; involved, but it ultimately seems best to be able to treat 64-bit +;;; aligned addresses as fixnums: we don't want the VSP to look like a +;;; vector. That basically requires that NIL really be a symbol (good +;;; bye, nilsym) and that we ensure that there are NILs where its CAR and +;;; CDR would be (-4, 4 bytes from the tagged pointer.) That means that +;;; CONS is 4 and UVECTOR is 12, and we have even more immediate/header types. + +(defconstant fulltag-even-fixnum #b0000) +(defconstant fulltag-imm-0 #b0001) +(defconstant fulltag-immheader-0 #b0010) +(defconstant fulltag-nodeheader-0 #b0011) +(defconstant fulltag-cons #b0100) +(defconstant fulltag-imm-1 #b0101) +(defconstant fulltag-immheader-1 #b0110) +(defconstant fulltag-nodeheader-1 #b0111) +(defconstant fulltag-odd-fixnum #b1000) +(defconstant fulltag-imm-2 #b1001) +(defconstant fulltag-immheader-2 #b1010) +(defconstant fulltag-nodeheader-2 #b1011) +(defconstant fulltag-misc #b1100) +(defconstant fulltag-imm-3 #b1101) +(defconstant fulltag-immheader-3 #b1110) +(defconstant fulltag-nodeheader-3 #b1111) + +(defconstant lowtagmask (1- (ash 1 nlowtagbits))) +(defconstant lowtag-mask lowtagmask) +(defconstant lowtag-primary 0) +(defconstant lowtag-imm 1) +(defconstant lowtag-immheader 2) +(defconstant lowtag-nodeheader 3) + +;;; The general algorithm for determining the (primary) type of an +;;; object is something like: +;;; (clrldi tag node 60) +;;; (cmpwi tag fulltag-misc) +;;; (clrldi tag tag 61) +;;; (bne @done) +;;; (lbz tag misc-subtag-offset node) +;;; @done +;; +;;; That's good enough to identify FIXNUM, "generally immediate", cons, +;;; or a header tag from a UVECTOR. In some cases, we may need to hold +;;; on to the full 4-bit tag. +;;; In no specific order: +;;; - it's important to be able to quickly recognize fixnums; that's +;;; simple +;;; - it's important to be able to quickly recognize lists (for CAR/CDR) +;;; and somewhat important to be able to quickly recognize conses. +;;; Also simple, though we have to special-case NIL. +;;; - it's desirable to be able to do VECTORP, ARRAYP, and specific-array-type- +;;; p. We need at least 12 immediate CL vector types (SIGNED/UNSIGNED-BYTE +;;; 8/16/32/64, SINGLE-FLOAT, DOUBLE-FLOAT, BIT, and at least one CHARACTER; +;;; we need SIMPLE-ARRAY, VECTOR-HEADER, and ARRAY-HEADER as node +;;; array types. That's suspciciously close to 16 +;;; - it's desirable to be able (in FUNCALL) to quickly recognize +;;; functions/symbols/other, and probably desirable to trap on other. +;;; Pretty much have to do a memory reference and at least one comparison +;;; here. +;;; - it's sometimes desirable to recognize numbers and distinct numeric +;;; types (other than FIXNUM) quickly. +;;; - The GC (especially) needs to be able to determine the size of +;;; ivectors (ivector elements) fairly cheaply. Most ivectors are CL +;;; arrays, but code-vectors are fairly common (and have 32-bit elements, +;;; naturally.) +;;; - We have a fairly large number of non-array gvector types, and it's +;;; always desirable to have room for expansion. +;;; - we basically have 8 classes of header subtags, each of which has +;;; 16 possible values. If we stole the high bit of the subtag to +;;; indicate CL-array-ness, we'd still have 6 bits to encode non-CL +;;; array types. + +(defconstant cl-array-subtag-bit 7) +(defconstant cl-array-subtag-mask (ash 1 cl-array-subtag-bit)) +(defmacro define-cl-array-subtag (name tag value) + `(defconstant ,(ccl::form-symbol "SUBTAG-" name) + (logior cl-array-subtag-mask (logior ,tag (ash ,value ntagbits))))) + +(define-cl-array-subtag arrayH fulltag-nodeheader-1 0) +(define-cl-array-subtag vectorH fulltag-nodeheader-2 0) +(define-cl-array-subtag simple-vector fulltag-nodeheader-3 0) +(defconstant min-array-subtag subtag-arrayH) +(defconstant min-vector-subtag subtag-vectorH) + +;;; bits: 64 32 16 8 1 +;;; CL-array ivector types DOUBLE-FLOAT SINGLE s16 CHAR BIT +;;; s64 s32 u16 s8 +;;; u64 u32 u8 +;;; Other ivector types MACPTR CODE-VECTOR +;;; DEAD-MACPTR XCODE-VECTOR +;;; BIGNUM +;;; DOUBLE-FLOAT +;;; There might possibly be ivectors with 128-bit (VMX/AltiVec) elements +;;; someday, and there might be multiple character sizes (16/32 bits). +;;; That sort of suggests that we use the four immheader classes to +;;; encode the ivector size (64, 32, 8, other) and make BIT an easily- +;;; detected case of OTHER. + +(defconstant ivector-class-64-bit fulltag-immheader-3) +(defconstant ivector-class-32-bit fulltag-immheader-2) +(defconstant ivector-class-other-bit fulltag-immheader-1) +(defconstant ivector-class-8-bit fulltag-immheader-0) + +(define-cl-array-subtag s64-vector ivector-class-64-bit 1) +(define-cl-array-subtag u64-vector ivector-class-64-bit 2) +(define-cl-array-subtag fixnum-vector ivector-class-64-bit 3) +(define-cl-array-subtag double-float-vector ivector-class-64-bit 4) +(define-cl-array-subtag s32-vector ivector-class-32-bit 1) +(define-cl-array-subtag u32-vector ivector-class-32-bit 2) +(define-cl-array-subtag single-float-vector ivector-class-32-bit 3) +(define-cl-array-subtag simple-base-string ivector-class-32-bit 5) +(define-cl-array-subtag s16-vector ivector-class-other-bit 1) +(define-cl-array-subtag u16-vector ivector-class-other-bit 2) +(define-cl-array-subtag bit-vector ivector-class-other-bit 7) +(define-cl-array-subtag s8-vector ivector-class-8-bit 1) +(define-cl-array-subtag u8-vector ivector-class-8-bit 2) + +;;; 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 code-vector ivector-class-32-bit 0) +(define-subtag xcode-vector ivector-class-32-bit 1) +(define-subtag bignum ivector-class-32-bit 2) +(define-subtag double-float ivector-class-32-bit 3) + +;;; Size doesn't matter for non-CL-array gvectors; I can't think of a good +;;; reason to classify them in any particular way. Let's put funcallable +;;; things in the first slice by themselves, though it's not clear that +;;; that helps FUNCALL much. +(defconstant gvector-funcallable fulltag-nodeheader-0) +(define-subtag function gvector-funcallable 0) +(define-subtag symbol gvector-funcallable 1) + +(define-subtag catch-frame fulltag-nodeheader-1 0) +(define-subtag basic-stream fulltag-nodeheader-1 1) +(define-subtag lock fulltag-nodeheader-1 2) +(define-subtag hash-vector fulltag-nodeheader-1 3) +(define-subtag pool fulltag-nodeheader-1 4) +(define-subtag weak fulltag-nodeheader-1 5) +(define-subtag package fulltag-nodeheader-1 6) +(define-subtag slot-vector fulltag-nodeheader-2 0) +(define-subtag instance fulltag-nodeheader-2 1) +(define-subtag struct fulltag-nodeheader-2 2) +(define-subtag istruct fulltag-nodeheader-2 3) +(define-subtag value-cell fulltag-nodeheader-2 4) +(define-subtag xfunction fulltag-nodeheader-2 5) + +(define-subtag ratio fulltag-nodeheader-3 0) +(define-subtag complex fulltag-nodeheader-3 1) + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "PPC-ARCH") + (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 &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)))) + + + + + + + +(defconstant misc-header-offset (- fulltag-misc)) +(defconstant misc-subtag-offset (+ misc-header-offset 7 )) +(defconstant misc-data-offset (+ misc-header-offset 8)) +(defconstant misc-dfloat-offset (+ misc-header-offset 8)) + + + +(define-subtag single-float fulltag-imm-0 0) + +(define-subtag character fulltag-imm-1 0) + +;;; FULLTAG-IMM-2 is unused, so the only type with lisptag (3-bit tag) +;;; TAG-IMM-0 should be SINGLE-FLOAT. + +(define-subtag unbound fulltag-imm-3 0) +(defconstant unbound-marker subtag-unbound) +(defconstant undefined unbound-marker) +(define-subtag slot-unbound fulltag-imm-3 1) +(defconstant slot-unbound-marker subtag-slot-unbound) +(define-subtag illegal fulltag-imm-3 2) +(defconstant illegal-marker subtag-illegal) + +(define-subtag no-thread-local-binding fulltag-imm-3 3) +(define-subtag forward-marker fulltag-imm-3 7) + + +(defconstant max-64-bit-constant-index (ash (+ #x7fff ppc64::misc-dfloat-offset) -3)) +(defconstant max-32-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -2)) +(defconstant max-16-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -1)) +(defconstant max-8-bit-constant-index (+ #x7fff ppc64::misc-data-offset)) +(defconstant max-1-bit-constant-index (ash (+ #x7fff ppc64::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. +(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-high double-float.value) +(defconstant double-float.val-high-cell double-float.value-cell) +(defconstant double-float.val-low (+ double-float.value 4)) +(defconstant double-float.val-low-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 +) + +; Catch frames go on the tstack; they point to a minimal lisp-frame +; on the cstack. (The catch/unwind-protect PC is on the cstack, where +; the GC expects to find it.) +(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 + csp ; pointer to control stack + db-link ; value of dynamic-binding link on thread entry. + save-save7 ; saved registers + save-save6 + save-save5 + save-save4 + save-save3 + save-save2 + save-save1 + save-save0 + xframe ; exception-frame link + tsp-segment ; mostly padding, for now. +) + +(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 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) + + +;;; 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) + +(defconstant tcr-bias 0) + +(define-storage-layout tcr (- tcr-bias) + prev ; in doubly-linked list + next ; in doubly-linked list + single-float-convert ; per-thread scratch space. + lisp-fpscr-high + db-link ; special binding chain head + catch-top ; top catch frame + save-vsp ; VSP when in foreign code + save-tsp ; TSP when in foreign code + cs-area ; cstack area pointer + vs-area ; vstack area pointer + ts-area ; tstack area pointer + cs-limit ; cstack overflow limit + 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 + safe-ref-address +) + +(defconstant interrupt-level-binding-index (ash 1 fixnumshift)) + +(defconstant tcr.lisp-fpscr-low (+ tcr.lisp-fpscr-high 4)) +(defconstant tcr.total-bytes-allocated-low (+ tcr.total-bytes-allocated-high 4)) + +(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 + ) + +;;; For the eabi port: mark this stack frame as Lisp's (since EABI +;;; foreign frames can be the same size as a lisp frame.) + + +(ppc64::define-storage-layout lisp-frame 0 + backlink + savefn + savelr + savevsp +) + +(ppc64::define-storage-layout c-frame 0 + backlink + crsave + savelr + unused-1 + unused-2 + savetoc + param0 + param1 + param2 + param3 + param4 + param5 + param6 + param7 +) + +(defconstant c-frame.minsize c-frame.size) + +(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 yield-syscall + #+darwinppc-target -60 + #+linuxppc-target #$__NR_sched_yield) +) +) + + + + + + +(defun %kernel-global (sym) + (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=))) + (if pos + (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes))) + (error "Unknown kernel global : ~s ." sym)))) + +(defmacro kernel-global (sym) + (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=))) + (if pos + (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes))) + (error "Unknown kernel global : ~s ." sym)))) + +;;; The kernel imports things that are defined in various other +;;; libraries for us. The objects in question are generally +;;; fixnum-tagged; the entries in the "kernel-imports" vector are 8 +;;; bytes apart. +(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step word-size-in-bytes) + fd-setsize-bytes + do-fd-set + do-fd-clr + do-fd-is-set + do-fd-zero + MakeDataExecutable + GetSharedLibrary + FindSymbol + malloc + free + allocate_tstack + allocate_vstack + register_cstack + raise-thread-interrupt + 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 +) + +(defmacro nrs-offset (name) + (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq))) + (if pos (* (1- pos) symbol.size)))) + +(defconstant nil-value (+ #x3000 symbol.size fulltag-misc)) + + +(defconstant reservation-discharge #x2008) + +(defparameter *ppc64-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 ) + (:code-vector . ,subtag-code-vector) + (: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 ) + (:fixnum-vector . ,subtag-fixnum-vector) + (:signed-64-bit-vector . ,subtag-s64-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 ppc64-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 ppc64-misc-byte-count (subtag element-count) + (declare (fixnum subtag)) + (if (= lowtag-nodeheader (logand subtag lowtagmask)) + (ash element-count 3) + (case (logand subtag fulltagmask) + (#.ivector-class-64-bit (ash element-count 3)) + (#.ivector-class-32-bit (ash element-count 2)) + (#.ivector-class-8-bit element-count) + (t + (if (= subtag subtag-bit-vector) + (ash (+ 7 element-count) -3) + (ash element-count 1)))))) + +(defparameter *ppc64-target-arch* + (arch::make-target-arch :name :ppc64 + :lisp-node-size 8 + :nil-value 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 *ppc64-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 '(#$"CODE") + :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 + #'ppc64-array-type-name-from-ctype + :package-name "PPC64" + :t-offset t-offset + :array-data-size-function #'ppc64-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 ppc::*ppc-subprims-base* + :subprims-shift ppc::*ppc-subprims-shift* + :subprims-table ppc::*ppc-subprims* + :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-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 subtag-symbol + :symbol-tag subtag-symbol + :symbol-tag-is-subtag t + :function-tag subtag-function + :function-tag-is-subtag t + :big-endian t + :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 defppc64archmacro (name lambda-list &body body) + `(arch::defarchmacro :ppc64 ,name ,lambda-list ,@body)) + +(defppc64archmacro ccl::%make-sfloat () + (error "~s shouldn't be used in code targeting :PPC64" 'ccl::%make-sfloat)) + +(defppc64archmacro ccl::%make-dfloat () + `(ccl::%alloc-misc ppc64::double-float.element-count ppc64::subtag-double-float)) + +(defppc64archmacro ccl::%numerator (x) + `(ccl::%svref ,x ppc64::ratio.numer-cell)) + +(defppc64archmacro ccl::%denominator (x) + `(ccl::%svref ,x ppc64::ratio.denom-cell)) + +(defppc64archmacro ccl::%realpart (x) + `(ccl::%svref ,x ppc64::complex.realpart-cell)) + +(defppc64archmacro ccl::%imagpart (x) + `(ccl::%svref ,x ppc64::complex.imagpart-cell)) + +;;; +(defppc64archmacro ccl::%get-single-float-from-double-ptr (ptr offset) + `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset))) + +(defppc64archmacro ccl::codevec-header-p (word) + `(eql ,word #$"CODE")) + +;;; + +(defppc64archmacro ccl::immediate-p-macro (thing) + (let* ((tag (gensym))) + `(let* ((,tag (ccl::lisptag ,thing))) + (declare (fixnum ,tag)) + (or (= ,tag ppc64::tag-fixnum) + (= (logand ,tag ppc64::lowtagmask) ppc64::lowtag-imm))))) + +(defppc64archmacro ccl::hashed-by-identity (thing) + (let* ((typecode (gensym))) + `(let* ((,typecode (ccl::typecode ,thing))) + (declare (fixnum ,typecode)) + (or + (= ,typecode ppc64::tag-fixnum) + (= (logand ,typecode ppc64::lowtagmask) ppc64::lowtag-imm) + (= ,typecode ppc64::subtag-symbol) + (= ,typecode ppc64::subtag-instance))))) + +;;; +(defppc64archmacro ccl::%get-kernel-global (name) + `(ccl::%fixnum-ref 0 (+ ppc64::nil-value + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name))))) + +(defppc64archmacro ccl::%get-kernel-global-ptr (name dest) + `(ccl::%setf-macptr + ,dest + (ccl::%fixnum-ref-macptr 0 (+ ppc64::nil-value + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name)))))) + +(defppc64archmacro ccl::%target-kernel-global (name) + `(ppc64::%kernel-global ,name)) + +(defppc64archmacro ccl::lfun-vector (fn) + fn) + +(defppc64archmacro ccl::lfun-vector-lfun (lfv) + lfv) + +(defppc64archmacro ccl::area-code () + area.code) + +(defppc64archmacro ccl::area-succ () + area.succ) + + +(defppc64archmacro ccl::nth-immediate (f i) + `(ccl::%svref ,f ,i)) + +(defppc64archmacro ccl::set-nth-immediate (f i new) + `(setf (ccl::%svref ,f ,i) ,new)) + + +(defppc64archmacro ccl::symptr->symvector (s) + s) + +(defppc64archmacro ccl::symvector->symptr (s) + s) + +(defppc64archmacro ccl::function-to-function-vector (f) + f) + +(defppc64archmacro ccl::function-vector-to-function (v) + v) + +(defppc64archmacro ccl::with-ffcall-results ((buf) &body body) + (let* ((size (+ (* 8 8) (* 13 8)))) + `(ccl::%stack-block ((,buf ,size)) + ,@body))) + + + +(provide "PPC64-ARCH") Index: /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-backend.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-backend.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-backend.lisp (revision 8058) @@ -0,0 +1,308 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2004, 2005 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPCENV")) + + +;;; Callbacks. Both LinuxPPC64 and DarwinPPC64 follow something +;;; close to the PowerOpen ABI. LinuxPPC uses transition vectors +;;; and a TOC, but it's not clear that we need to care about that +;;; here. +(defun define-ppc64-poweropen-callback (name args body env) + (let* ((stack-word (gensym)) + (stack-ptr (gensym)) + (fp-arg-regs (gensym)) + (fp-arg-num 0) + (arg-names ()) + (arg-types ()) + (return-type :void) + (args args) + (woi nil) + (monitor nil) + (dynamic-extent-names ()) + (error-return nil)) + (loop + (when (null args) (return)) + (when (null (cdr args)) + (setq return-type (car args)) + (return)) + (if (eq (car args) :without-interrupts) + (setq woi (cadr args) args (cddr args)) + (if (eq (car args) :monitor-exception-ports) + (setq monitor (cadr args) args (cddr args)) + (if (eq (car args) :error-return) + (setq error-return + (cadr args) + args (cddr args)) + (progn + (push (foreign-type-to-representation-type (pop args)) arg-types) + (push (pop args) arg-names)))))) + (setq arg-names (nreverse arg-names) + arg-types (nreverse arg-types)) + (setq return-type (foreign-type-to-representation-type return-type)) + (when (eq return-type :void) + (setq return-type nil)) + (let* ((offset 0) + (need-stack-pointer (or arg-names return-type error-return)) + (lets + (mapcar + #'(lambda (name type) + (let* ((delta 8) + (bias 0) + (use-fp-args nil)) + (prog1 + (list name + `(, + (if (typep type 'unsigned-byte) + (progn (setq delta (* 8 type)) '%inc-ptr) + (ecase type + (:single-float + (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))) + (:double-float + (setq delta 8) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + (:signed-doubleword (setq delta 8) '%%get-signed-longlong) + (:signed-fullword + (setq bias 4) + '%get-signed-long) + (:signed-halfword (setq bias 6) + '%get-signed-word) + (:signed-byte (setq bias 7) + '%get-signed-byte) + (:unsigned-doubleword (setq delta 8) '%%get-unsigned-longlong) + (:unsigned-fullword + (setq bias 4) + '%get-unsigned-long) + (:unsigned-halfword + (setq bias 6) + '%get-unsigned-word) + (:unsigned-byte + (setq bias 7) + '%get-unsigned-byte) + (:address '%get-ptr))) + ,(if use-fp-args fp-arg-regs stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + `(+ ,offset ,bias)))) + (when (or (eq type :address) + (typep type 'unsigned-byte)) + (push name dynamic-extent-names)) + (incf offset delta)))) + arg-names arg-types))) + (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 (,@(and need-stack-pointer (list `(,stack-ptr)))) + ,(when need-stack-pointer + `(%setf-macptr-to-object ,stack-ptr ,stack-word)) + ,(defcallback-body stack-ptr lets dynamic-extent-names + decls body return-type error-return + (- ppc64::c-frame.savelr ppc64::c-frame.param0) + fp-arg-regs + ))))) + ,doc + ,woi + ,monitor)))))) + +(defun defcallback-body-ppc64-poweropen (stack-ptr lets dynamic-extent-names decls body return-type error-return error-delta fp-arg-ptr) + (let* ((result (gensym)) + (result-ptr (case return-type + ((:single-float :double-float) fp-arg-ptr) + (t stack-ptr))) + (condition-name (if (atom error-return) 'error (car error-return))) + (error-return-function (if (atom error-return) error-return (cadr error-return))) + (body + `(with-macptrs ((,fp-arg-ptr (%get-ptr ,stack-ptr (- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))) + (declare (ignorable ,fp-arg-ptr)) + (let ,lets + (declare (dynamic-extent ,@dynamic-extent-names)) + ,@decls + + (let ((,result (progn ,@body))) + (declare (ignorable ,result)) + ,@(progn + ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT + (when (eq return-type :single-float) + (setq result `(float ,result 0.0d0))) + nil) + + ,(when return-type + `(setf (, + (case return-type + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) '%get-double-float) + (t '%%get-signed-longlong )) ,result-ptr 0) ,result))))))) + (if error-return + (let* ((cond (gensym))) + `(handler-case ,body + (,condition-name (,cond) (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))))) + body))) + +(defvar *ppc64-vinsn-templates* (make-hash-table :test #'eq)) + + + +(defvar *known-ppc64-backends* ()) + + +#+linuxppc-target +(defvar *linuxppc64-backend* + (make-backend :lookup-opcode #'lookup-ppc-opcode + :lookup-macro #'ppc::ppc-macro-function + :lap-opcodes ppc::*ppc-opcodes* + :define-vinsn 'define-ppc-vinsn + :platform-syscall-mask (logior platform-os-linux platform-cpu-ppc) + + :p2-dispatch *ppc2-specials* + :p2-vinsn-templates *ppc64-vinsn-templates* + :p2-template-hash-name '*ppc64-vinsn-templates* + :p2-compile 'ppc2-compile + :target-specific-features + '(:powerpc :ppc-target :poweropen-target :linux-target :linuxppc-target :ppc64-target :64-bit-target :big-endian-target) + :target-fasl-pathname (make-pathname :type "p64fsl") + :target-platform (logior platform-cpu-ppc + platform-os-linux + platform-word-size-64) + :target-os :linuxppc + :name :linuxppc64 + :target-arch-name :ppc64 + :target-foreign-type-data nil + :target-arch ppc64::*ppc64-target-arch* + :define-callback 'define-ppc64-poweropen-callback + :defcallback-body 'defcallback-body-ppc64-poweropen + )) + + +#+darwinppc-target +(defvar *darwinppc64-backend* + (make-backend :lookup-opcode #'lookup-ppc-opcode + :lookup-macro #'ppc::ppc-macro-function + :lap-opcodes ppc::*ppc-opcodes* + :define-vinsn 'define-ppc-vinsn + :platform-syscall-mask (logior platform-os-darwin platform-cpu-ppc) + + :p2-dispatch *ppc2-specials* + :p2-vinsn-templates *ppc64-vinsn-templates* + :p2-template-hash-name '*ppc64-vinsn-templates* + :p2-compile 'ppc2-compile + :target-specific-features + '(:powerpc :ppc-target :darwin-target :darwinppc-target :ppc64-target :64-bit-target :big-endian-target) + :target-fasl-pathname (make-pathname :type "d64fsl") + :target-platform (logior platform-cpu-ppc + platform-os-darwin + platform-word-size-64) + :target-os :darwinppc + :name :darwinppc64 + :target-arch-name :ppc64 + :target-foreign-type-data nil + :target-arch ppc64::*ppc64-target-arch* + :define-callback 'define-ppc64-poweropen-callback + :defcallback-body 'defcallback-body-ppc64-poweropen)) + +#+linuxppc-target +(pushnew *linuxppc64-backend* *known-ppc64-backends* :key #'backend-name) + + +#+darwinppc-target +(pushnew *darwinppc64-backend* *known-ppc64-backends* :key #'backend-name) + +(defvar *ppc64-backend* (car *known-ppc64-backends*)) + +(defun fixup-ppc64-backend () + (dolist (b *known-ppc64-backends*) + (setf (backend-lap-opcodes b) ppc::*ppc-opcodes* + (backend-p2-dispatch b) *ppc2-specials* + (backend-p2-vinsn-templates b) *ppc64-vinsn-templates*) + (or (backend-lap-macros b) (setf (backend-lap-macros b) + (make-hash-table :test #'equalp))))) + + + +(fixup-ppc64-backend) + +#+ppc64-target +(setq *host-backend* *ppc64-backend* *target-backend* *ppc64-backend*) +#-ppc64-target +(unless (backend-target-foreign-type-data *ppc64-backend*) + (let* ((ftd (make-ftd + :interface-db-directory + #+darwinppc-target "ccl:darwin-headers64;" + #+linuxppc-target "ccl:headers64;" + :interface-package-name + #+darwinppc-target "DARWIN64" + #+linuxppc-target "LINUX64" + :attributes + #+darwinppc-target + '(:signed-char t + :struct-by-value t + :struct-return-in-registers t + :struct-return-explicit t + :struct-by-value-by-field t + :prepend-underscores t + :bits-per-word 64) + #+linuxppc-target + '(:bits-per-word 64) + :ff-call-expand-function + #+linuxppc-target + 'linux64::expand-ff-call + #+darwinppc-target + 'darwin64::expand-ff-call + :ff-call-struct-return-by-implicit-arg-function + #+linuxppc-target + linux64::record-type-returns-structure-as-first-arg + #+darwinppc-target + darwin64::record-type-returns-structure-as-first-arg + :callback-bindings-function + #+linuxppc-target + linux64::generate-callback-bindings + #+darwinppc-target + darwin64::generate-callback-bindings + :callback-return-value-function + #+linuxppc-target + linux64::generate-callback-return-value + #+darwinppc-target + darwin64::generate-callback-return-value + ))) + (install-standard-foreign-types ftd) + (use-interface-dir :libc ftd) + (setf (backend-target-foreign-type-data *ppc64-backend*) ftd))) + +(pushnew *ppc64-backend* *known-backends* :key #'backend-name) + +#+ppc64-target +(require "PPC64-VINSNS") + +(provide "PPC64-BACKEND") Index: /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-vinsns.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-vinsns.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/PPC64/ppc64-vinsns.lisp (revision 8058) @@ -0,0 +1,4016 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2004-2005, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPC64-BACKEND")) + +(eval-when (:compile-toplevel :execute) + (require "PPCENV")) + +(defmacro define-ppc64-vinsn (vinsn-name (results args &optional temps) &body body) + (%define-vinsn *ppc64-backend* vinsn-name results args temps body)) + + +;;; Index "scaling" and constant-offset misc-ref vinsns. + + +(define-ppc64-vinsn scale-node-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (addi dest idx ppc64::misc-data-offset)) + +(define-ppc64-vinsn scale-32bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (srdi dest idx 1) + (addi dest dest ppc64::misc-data-offset)) + +(define-ppc64-vinsn scale-16bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (srdi dest idx 2) + (addi dest dest ppc64::misc-data-offset)) + +(define-ppc64-vinsn scale-8bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (srdi dest idx ppc64::word-shift) + (addi dest dest ppc64::misc-data-offset)) + + +(define-ppc64-vinsn scale-64bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (addi dest idx ppc64::misc-data-offset)) + +(define-ppc64-vinsn scale-1bit-misc-index (((word-index :s64) + (bitnum :u8)) ; (unsigned-byte 5) + ((idx :imm) ; A fixnum + ) + ) + (srdi word-index idx (+ 5 ppc64::fixnum-shift)) + (sldi word-index word-index 2) + (addi word-index word-index ppc64::misc-data-offset) ; Hmmm. Also one instruction, but less impressive somehow. + (extrwi bitnum idx 5 (- 32 (+ ppc64::fixnum-shift 5)))) + + + +(define-ppc64-vinsn misc-ref-u64 (((dest :u64)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (ldx dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-s64 (((dest :s64)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (ldx dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-u64 (((dest :u64)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + (ld dest (:apply + ppc64::misc-data-offset (:apply ash idx ppc64::word-shift)) v)) + +(define-ppc64-vinsn misc-ref-c-s64 (((dest :s64)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + (ld dest (:apply + ppc64::misc-data-offset (:apply ash idx ppc64::word-shift)) v)) + + +(define-ppc64-vinsn misc-set-u64 (() + ((val :u64) + (v :lisp) + (scaled-idx :u64))) + (stdx val v scaled-idx)) + +(define-ppc64-vinsn misc-set-c-u64 (() + ((val :u64) + (v :lisp) + (idx :u32const))) + (std val (:apply + ppc64::misc-data-offset (:apply ash idx 3)) v)) + +(define-ppc64-vinsn misc-set-s64 (() + ((val :s64) + (v :lisp) + (scaled-idx :u64))) + (stdx val v scaled-idx)) + + +(define-ppc64-vinsn misc-set-c-s64 (() + ((val :s64) + (v :lisp) + (idx :u32const))) + (std val (:apply + ppc64::misc-data-offset (:apply ash idx 3)) v)) + +(define-ppc64-vinsn misc-ref-u32 (((dest :u32)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (lwzx dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-u32 (((dest :u32)) + ((v :lisp) + (idx :u32const)) + ()) + (lwz dest (:apply + ppc64::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc64-vinsn misc-ref-s32 (((dest :s32)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (lwax dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-s32 (((dest :s32)) + ((v :lisp) + (idx :u32const)) + ()) + (lwa dest (:apply + ppc64::misc-data-offset (:apply ash idx 2)) v)) + + +(define-ppc64-vinsn misc-set-c-u32 (() + ((val :u32) + (v :lisp) + (idx :u32const))) + (stw val (:apply + ppc64::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc64-vinsn misc-set-u32 (() + ((val :u32) + (v :lisp) + (scaled-idx :u64))) + (stwx val v scaled-idx)) + +(define-ppc64-vinsn misc-set-c-s32 (() + ((val :s32) + (v :lisp) + (idx :u32const))) + (stw val (:apply + ppc64::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc64-vinsn misc-set-s32 (() + ((val :s32) + (v :lisp) + (scaled-idx :u64))) + (stwx val v scaled-idx)) + +(define-ppc64-vinsn misc-ref-single-float (((dest :single-float)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (lfsx dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-single-float (((dest :single-float)) + ((v :lisp) + (idx :u32const)) + ()) + (lfs dest (:apply + ppc64::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc64-vinsn misc-ref-double-float (((dest :double-float)) + ((v :lisp) + (scaled-idx :u32)) + ()) + (lfdx dest v scaled-idx)) + + +(define-ppc64-vinsn misc-ref-c-double-float (((dest :double-float)) + ((v :lisp) + (idx :u32const)) + ()) + (lfd dest (:apply + ppc64::misc-dfloat-offset (:apply ash idx 3)) v)) + +(define-ppc64-vinsn misc-set-c-double-float (((val :double-float)) + ((v :lisp) + (idx :u32const))) + (stfd val (:apply + ppc64::misc-dfloat-offset (:apply ash idx 3)) v)) + +(define-ppc64-vinsn misc-set-double-float (() + ((val :double-float) + (v :lisp) + (scaled-idx :u32))) + (stfdx val v scaled-idx)) + +(define-ppc64-vinsn misc-set-c-single-float (((val :single-float)) + ((v :lisp) + (idx :u32const))) + (stfs val (:apply + ppc64::misc-data-offset (:apply ash idx 2)) v)) + +(define-ppc64-vinsn misc-set-single-float (() + ((val :single-float) + (v :lisp) + (scaled-idx :u32))) + (stfsx val v scaled-idx)) + + +(define-ppc64-vinsn misc-ref-u16 (((dest :u16)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (lhzx dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-u16 (((dest :u16)) + ((v :lisp) + (idx :u32const)) + ()) + (lhz dest (:apply + ppc64::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc64-vinsn misc-set-c-u16 (((val :u16)) + ((v :lisp) + (idx :u32const)) + ()) + (sth val (:apply + ppc64::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc64-vinsn misc-set-u16 (((val :u16)) + ((v :lisp) + (scaled-idx :s64))) + (sthx val v scaled-idx)) + +(define-ppc64-vinsn misc-ref-s16 (((dest :s16)) + ((v :lisp) + (scaled-idx :s64)) + ()) + (lhax dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-s16 (((dest :s16)) + ((v :lisp) + (idx :u32const)) + ()) + (lha dest (:apply + ppc64::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc64-vinsn misc-set-c-s16 (((val :s16)) + ((v :lisp) + (idx :u32const)) + ()) + (sth val (:apply + ppc64::misc-data-offset (:apply ash idx 1)) v)) + +(define-ppc64-vinsn misc-set-s16 (((val :s16)) + ((v :lisp) + (scaled-idx :s64))) + (sthx val v scaled-idx)) + +(define-ppc64-vinsn misc-ref-u8 (((dest :u8)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (lbzx dest v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-u8 (((dest :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (lbz dest (:apply + ppc64::misc-data-offset idx) v)) + +(define-ppc64-vinsn misc-set-c-u8 (((val :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (stb val (:apply + ppc64::misc-data-offset idx) v)) + +(define-ppc64-vinsn misc-set-u8 (((val :u8)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (stbx val v scaled-idx)) + +(define-ppc64-vinsn misc-ref-s8 (((dest :s8)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (lbzx dest v scaled-idx) + (extsb dest dest)) + +(define-ppc64-vinsn misc-ref-c-s8 (((dest :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (lbz dest (:apply + ppc64::misc-data-offset idx) v) + (extsb dest dest)) + +(define-ppc64-vinsn misc-set-c-s8 (((val :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (stb val (:apply + ppc64::misc-data-offset idx) v)) + +(define-ppc64-vinsn misc-set-s8 (((val :s8)) + ((v :lisp) + (scaled-idx :u64)) + ()) + (stbx val v scaled-idx)) + +(define-ppc64-vinsn misc-ref-c-bit (((dest :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (lwz dest (:apply + ppc64::misc-data-offset (:apply ash idx -5)) v) + (rlwinm dest dest (:apply 1+ (:apply logand idx #x1f)) 31 31)) + +(define-ppc64-vinsn misc-ref-c-bit-fixnum (((dest :imm)) + ((v :lisp) + (idx :u32const)) + ((temp :u32))) + (lwz temp (:apply + ppc64::misc-data-offset (:apply ash idx -5)) v) + (rlwinm dest + temp + (:apply + 1 ppc64::fixnumshift (:apply logand idx #x1f)) + (- ppc64::least-significant-bit ppc64::fixnumshift) + (- ppc64::least-significant-bit ppc64::fixnumshift))) + + +(define-ppc64-vinsn misc-ref-node (((dest :lisp)) + ((v :lisp) + (scaled-idx :s64)) + ()) + (ldx dest v scaled-idx)) + +(define-ppc64-vinsn misc-set-node (() + ((val :lisp) + (v :lisp) + (scaled-idx :s64)) + ()) + (stdx val v scaled-idx)) + + + + +(define-ppc64-vinsn misc-ref-c-node (((dest :lisp)) + ((v :lisp) + (idx :s16const)) + ()) + (ld dest (:apply + ppc64::misc-data-offset (:apply ash idx 3)) v)) + +(define-ppc64-vinsn misc-set-c-node (() + ((val :lisp) + (v :lisp) + (idx :s16const)) + ()) + (std val (:apply + ppc64::misc-data-offset (:apply ash idx 3)) v)) + + +(define-ppc64-vinsn misc-element-count-fixnum (((dest :imm)) + ((v :lisp)) + ((temp :u64))) + (ld temp ppc64::misc-header-offset v) + (srdi temp temp ppc64::num-subtag-bits) + (sldi dest temp ppc64::fixnumshift)) + +(define-ppc64-vinsn check-misc-bound (() + ((idx :imm) + (v :lisp)) + ((temp :u64))) + (ld temp ppc64::misc-header-offset v) + (srdi temp temp ppc64::num-subtag-bits) + (sldi temp temp ppc64::fixnumshift) + (tdlge idx temp)) + +(define-ppc64-vinsn 2d-unscaled-index (((dest :imm) + (dim1 :u32)) + ((dim1 :u32) + (i :imm) + (j :imm))) + (mulld dim1 i dim1) + (add dest dim1 j)) + + +;; dest <- (+ (* i dim1 dim2) (* j dim2) k) +(define-ppc64-vinsn 3d-unscaled-index (((dest :imm) + (dim1 :u64) + (dim2 :u64)) + ((dim1 :u64) + (dim2 :u64) + (i :imm) + (j :imm) + (k :imm))) + (mulld dim1 dim1 dim2) + (mulld dim2 j dim2) + (mulld dim1 i dim1) + (add dim2 dim1 dim2) + (add dest dim2 k)) + + +(define-ppc64-vinsn 2d-32-scaled-index (((dest :u64)) + ((array :lisp) + (i :imm) + (j :imm) + (dim1 :u32))) + (mulld dest i dim1) + (add dest dest j) + (la dest ppc64::misc-data-offset dest)) + +(define-ppc64-vinsn 2d-dim1 (((dest :u64)) + ((header :lisp))) + (ld dest (+ ppc64::misc-data-offset (* 8 (1+ ppc64::arrayH.dim0-cell))) header) + (sradi dest dest ppc64::fixnumshift)) + +(define-ppc64-vinsn 3d-dims (((dim1 :u64) + (dim2 :u64)) + ((header :lisp))) + (ld dim1 (+ ppc64::misc-data-offset (* 8 (1+ ppc64::arrayH.dim0-cell))) header) + (ld dim2 (+ ppc64::misc-data-offset (* 8 (+ 2 ppc64::arrayH.dim0-cell))) header) + (sradi dim1 dim1 ppc64::fixnumshift) + (sradi dim2 dim2 ppc64::fixnumshift)) + +;;; Return dim1 (unboxed) +(define-ppc64-vinsn check-2d-bound (((dim :u64)) + ((i :imm) + (j :imm) + (header :lisp))) + (ld dim (+ ppc64::misc-data-offset (* 8 ppc64::arrayH.dim0-cell)) header) + (tdlge i dim) + (ld dim (+ ppc64::misc-data-offset (* 8 (1+ ppc64::arrayH.dim0-cell))) header) + (tdlge j dim) + (sradi dim dim ppc64::fixnumshift)) + +(define-ppc64-vinsn check-3d-bound (((dim1 :u64) + (dim2 :u64)) + ((i :imm) + (j :imm) + (k :imm) + (header :lisp))) + (ld dim1 (+ ppc64::misc-data-offset (* 8 ppc64::arrayH.dim0-cell)) header) + (tdlge i dim1) + (ld dim1 (+ ppc64::misc-data-offset (* 8 (1+ ppc64::arrayH.dim0-cell))) header) + (tdlge j dim1) + (ld dim2 (+ ppc64::misc-data-offset (* 8 (+ 2 ppc64::arrayH.dim0-cell))) header) + (tdlge k dim2) + (sradi dim1 dim1 ppc64::fixnumshift) + (sradi dim2 dim2 ppc64::fixnumshift)) + +(define-ppc64-vinsn array-data-vector-ref (((dest :lisp)) + ((header :lisp))) + (ld dest ppc64::arrayH.data-vector header)) + + +(define-ppc64-vinsn check-arrayH-rank (() + ((header :lisp) + (expected :u32const)) + ((rank :imm))) + (ld rank ppc64::arrayH.rank header) + (tdi 27 rank (:apply ash expected ppc64::fixnumshift))) + +(define-ppc64-vinsn check-arrayH-flags (() + ((header :lisp) + (expected :u16const)) + ((flags :imm) + (xreg :u32))) + (lis xreg (:apply ldb (byte 16 16) (:apply ash expected ppc64::fixnumshift))) + (ori xreg xreg (:apply ldb (byte 16 0) (:apply ash expected ppc64::fixnumshift))) + (ld flags ppc64::arrayH.flags header) + (td 27 flags xreg)) + + +(define-ppc64-vinsn trap-unless-simple-array-2 (() + ((object :lisp) + (expected-flags :u64const) + (type-error :u8const)) + ((tag :u8) + (flags :u64) + (crf :crf))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :bad) + (lbz tag ppc64::misc-subtag-offset object) + (cmpdi crf tag ppc64::subtag-arrayH) + (bne crf :bad) + (ld tag ppc64::arrayH.rank object) + (cmpdi crf tag (ash 2 ppc64::fixnumshift)) + (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags ppc64::fixnumshift))) + (ld flags ppc64::arrayH.flags object) + (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags ppc64::fixnumshift))) + (bne crf :bad) + (cmpd crf tag flags) + (beq crf :good) + :bad + (uuo_interr type-error object) + :good) + +(define-ppc64-vinsn trap-unless-simple-array-3 (() + ((object :lisp) + (expected-flags :u64const) + (type-error :u8const)) + ((tag :u8) + (flags :u64) + (crf :crf))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :bad) + (lbz tag ppc64::misc-subtag-offset object) + (cmpdi crf tag ppc64::subtag-arrayH) + (bne crf :bad) + (ld tag ppc64::arrayH.rank object) + (cmpdi crf tag (ash 3 ppc64::fixnumshift)) + (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags ppc64::fixnumshift))) + (ld flags ppc64::arrayH.flags object) + (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags ppc64::fixnumshift))) + (bne crf :bad) + (cmpd crf tag flags) + (beq crf :good) + :bad + (uuo_interr type-error object) + :good) + + +(define-ppc64-vinsn node-slot-ref (((dest :lisp)) + ((node :lisp) + (cellno :u32const))) + (ld dest (:apply + ppc64::misc-data-offset (:apply ash cellno 3)) node)) + + + +(define-ppc64-vinsn %slot-ref (((dest :lisp)) + ((instance (:lisp (:ne dest))) + (index :lisp)) + ((scaled :s64))) + (la scaled ppc64::misc-data-offset index) + (ldx dest instance scaled) + (tdeqi dest ppc64::slot-unbound-marker)) + + +;;; Untagged memory reference & assignment. + +(define-ppc64-vinsn mem-ref-c-fullword (((dest :u32)) + ((src :address) + (index :s16const))) + (lwz dest index src)) + +(define-ppc64-vinsn mem-ref-c-signed-fullword (((dest :s32)) + ((src :address) + (index :s16const))) + (lwa dest index src)) + +(define-ppc64-vinsn mem-ref-c-doubleword (((dest :u64)) + ((src :address) + (index :s16const))) + (ld dest index src)) + +(define-ppc64-vinsn mem-ref-c-signed-doubleword (((dest :s64)) + ((src :address) + (index :s16const))) + (ld dest index src)) + +(define-ppc64-vinsn mem-ref-c-natural (((dest :u64)) + ((src :address) + (index :s16const))) + (ld dest index src)) + +(define-ppc64-vinsn mem-ref-fullword (((dest :u32)) + ((src :address) + (index :s64))) + (lwzx dest src index)) + +(define-ppc64-vinsn mem-ref-signed-fullword (((dest :s32)) + ((src :address) + (index :s64))) + (lwax dest src index)) + +(define-ppc64-vinsn mem-ref-doubleword (((dest :u64)) + ((src :address) + (index :s64))) + (ldx dest src index)) + +(define-ppc64-vinsn mem-ref-natural (((dest :u64)) + ((src :address) + (index :s64))) + (ldx dest src index)) + +(define-ppc64-vinsn mem-ref-signed-doubleword (((dest :s64)) + ((src :address) + (index :s64))) + (ldx dest src index)) + +(define-ppc64-vinsn mem-ref-c-u16 (((dest :u16)) + ((src :address) + (index :s16const))) + (lhz dest index src)) + +(define-ppc64-vinsn mem-ref-u16 (((dest :u16)) + ((src :address) + (index :s32))) + (lhzx dest src index)) + + +(define-ppc64-vinsn mem-ref-c-s16 (((dest :s16)) + ((src :address) + (index :s16const))) + (lha dest index src)) + +(define-ppc64-vinsn mem-ref-s16 (((dest :s16)) + ((src :address) + (index :s32))) + (lhax dest src index)) + +(define-ppc64-vinsn mem-ref-c-u8 (((dest :u8)) + ((src :address) + (index :s16const))) + (lbz dest index src)) + +(define-ppc64-vinsn mem-ref-u8 (((dest :u8)) + ((src :address) + (index :s32))) + (lbzx dest src index)) + +(define-ppc64-vinsn mem-ref-c-s8 (((dest :s8)) + ((src :address) + (index :s16const))) + (lbz dest index src) + (extsb dest dest)) + +(define-ppc64-vinsn mem-ref-s8 (((dest :s8)) + ((src :address) + (index :s32))) + (lbzx dest src index) + (extsb dest dest)) + +(define-ppc64-vinsn mem-ref-c-bit (((dest :u8)) + ((src :address) + (byte-index :s16const) + (bit-shift :u8const))) + (lbz dest byte-index src) + (rlwinm dest dest bit-shift 31 31)) + +(define-ppc64-vinsn mem-ref-c-bit-fixnum (((dest :lisp)) + ((src :address) + (byte-index :s16const) + (bit-shift :u8const)) + ((byteval :u8))) + (lbz byteval byte-index src) + (rlwinm dest byteval bit-shift 29 29)) + +(define-ppc64-vinsn mem-ref-bit (((dest :u8)) + ((src :address) + (bit-index :lisp)) + ((byte-index :s16) + (bit-shift :u8))) + (srwi byte-index bit-index (+ ppc64::fixnumshift 3)) + (extrwi bit-shift bit-index 3 27) + (addi bit-shift bit-shift 29) + (lbzx dest src byte-index) + (rlwnm dest dest bit-shift 31 31)) + + +(define-ppc64-vinsn mem-ref-bit-fixnum (((dest :lisp)) + ((src :address) + (bit-index :lisp)) + ((byte-index :s16) + (bit-shift :u8))) + (srwi byte-index bit-index (+ ppc64::fixnumshift 3)) + (extrwi bit-shift bit-index 3 27) + (addi bit-shift bit-shift 27) + (lbzx byte-index src byte-index) + (rlwnm dest + byte-index + bit-shift + (- ppc64::least-significant-bit ppc64::fixnum-shift) + (- ppc64::least-significant-bit ppc64::fixnum-shift))) + +(define-ppc64-vinsn mem-ref-c-double-float (((dest :double-float)) + ((src :address) + (index :s16const))) + (lfd dest index src)) + +(define-ppc64-vinsn mem-ref-double-float (((dest :double-float)) + ((src :address) + (index :s32))) + (lfdx dest src index)) + +(define-ppc64-vinsn mem-set-c-double-float (() + ((val :double-float) + (src :address) + (index :s16const))) + (stfd val index src)) + +(define-ppc64-vinsn mem-set-double-float (() + ((val :double-float) + (src :address) + (index :s32))) + (stfdx val src index)) + +(define-ppc64-vinsn mem-ref-c-single-float (((dest :single-float)) + ((src :address) + (index :s16const))) + (lfs dest index src)) + +(define-ppc64-vinsn mem-ref-single-float (((dest :single-float)) + ((src :address) + (index :s32))) + (lfsx dest src index)) + +(define-ppc64-vinsn mem-set-c-single-float (() + ((val :single-float) + (src :address) + (index :s16const))) + (stfs val index src)) + +(define-ppc64-vinsn mem-set-single-float (() + ((val :single-float) + (src :address) + (index :s32))) + (stfsx val src index)) + + +(define-ppc64-vinsn mem-set-c-doubleword (() + ((val :u64) + (src :address) + (index :s16const))) + (std val index src)) + +(define-ppc64-vinsn mem-set-doubleword (() + ((val :u64) + (src :address) + (index :s64))) + (stdx val index src)) + +(define-ppc64-vinsn mem-set-c-address (() + ((val :address) + (src :address) + (index :s16const))) + (std val index src)) + +(define-ppc64-vinsn mem-set-address (() + ((val :address) + (src :address) + (index :s64))) + (stdx val src index)) + +(define-ppc64-vinsn mem-set-c-fullword (() + ((val :u32) + (src :address) + (index :s16const))) + (stw val index src)) + +(define-ppc64-vinsn mem-set-fullword (() + ((val :u32) + (src :address) + (index :s32))) + (stwx val src index)) + +(define-ppc64-vinsn mem-set-c-halfword (() + ((val :u16) + (src :address) + (index :s16const))) + (sth val index src)) + +(define-ppc64-vinsn mem-set-halfword (() + ((val :u16) + (src :address) + (index :s32))) + (sthx val src index)) + +(define-ppc64-vinsn mem-set-c-byte (() + ((val :u16) + (src :address) + (index :s16const))) + (stb val index src)) + +(define-ppc64-vinsn mem-set-byte (() + ((val :u8) + (src :address) + (index :s32))) + (stbx val src index)) + +(define-ppc64-vinsn mem-set-c-bit-0 (() + ((src :address) + (byte-index :s16const) + (mask-begin :u8const) + (mask-end :u8const)) + ((val :u8))) + (lbz val byte-index src) + (rlwinm val val 0 mask-begin mask-end) + (stb val byte-index src)) + +(define-ppc64-vinsn mem-set-c-bit-1 (() + ((src :address) + (byte-index :s16const) + (mask :u8const)) + ((val :u8))) + (lbz val byte-index src) + (ori val val mask) + (stb val byte-index src)) + +(define-ppc64-vinsn mem-set-c-bit (() + ((src :address) + (byte-index :s16const) + (bit-index :u8const) + (val :imm)) + ((byteval :u8))) + (lbz byteval byte-index src) + (rlwimi byteval val (:apply logand 31 (:apply - 29 bit-index)) bit-index bit-index) + (stb byteval byte-index src)) + + +(define-ppc64-vinsn mem-set-bit (() + ((src :address) + (bit-index :lisp) + (val :lisp)) + ((bit-shift :u32) + (mask :u32) + (byte-index :u32) + (crf :crf))) + (cmplwi crf val (ash 1 ppc64::fixnumshift)) + (extrwi bit-shift bit-index 3 27) + (li mask #x80) + (srw mask mask bit-shift) + (ble+ crf :got-it) + (uuo_interr arch::error-object-not-bit src) + :got-it + (srwi bit-shift bit-index (+ 3 ppc64::fixnumshift)) + (lbzx bit-shift src bit-shift) + (beq crf :set) + (andc mask bit-shift mask) + (b :done) + :set + (or mask bit-shift mask) + :done + (srwi bit-shift bit-index (+ 3 ppc64::fixnumshift)) + (stbx mask src bit-shift)) + +;;; Tag and subtag extraction, comparison, checking, trapping ... + +(define-ppc64-vinsn extract-tag (((tag :u8)) + ((object :lisp)) + ()) + (clrldi tag object (- ppc64::nbits-in-word ppc64::nlisptagbits))) + +(define-ppc64-vinsn extract-tag-fixnum (((tag :imm)) + ((object :lisp))) + (clrlsldi tag object (- ppc64::nbits-in-word ppc64::nlisptagbits) ppc64::fixnum-shift)) + +(define-ppc64-vinsn extract-fulltag (((tag :u8)) + ((object :lisp)) + ()) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits))) + + +(define-ppc64-vinsn extract-fulltag-fixnum (((tag :imm)) + ((object :lisp))) + (clrlsldi tag object (- ppc64::nbits-in-word ppc64::ntagbits) ppc64::fixnum-shift)) + + +(define-ppc64-vinsn extract-typecode (((code :u8)) + ((object :lisp)) + ((crf :crf))) + (clrldi code object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf code ppc64::fulltag-misc) + (clrldi code code (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (bne crf :not-misc) + (lbz code ppc64::misc-subtag-offset object) + :not-misc) + +(define-ppc64-vinsn extract-typecode-fixnum (((code :imm)) + ((object (:lisp (:ne code)))) + ((crf :crf) (subtag :u8))) + (clrldi subtag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf subtag ppc64::fulltag-misc) + (clrldi subtag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (bne crf :not-misc) + (lbz subtag ppc64::misc-subtag-offset object) + :not-misc + (sldi code subtag ppc64::fixnum-shift)) + + +(define-ppc64-vinsn require-fixnum (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u8))) + :again + (clrldi. tag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-fixnum object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-integer (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u8))) + :again + (clrldi. tag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (beq+ crf0 :got-it) + (cmpdi crf0 tag ppc64::fulltag-misc) + (bne crf0 :no-got) + (lbz tag ppc64::misc-subtag-offset object) + (cmpdi crf0 tag ppc64::subtag-bignum) + (beq+ crf0 :got-it) + :no-got + (uuo_intcerr arch::error-object-not-integer object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-simple-vector (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :no-got) + (lbz tag ppc64::misc-subtag-offset object) + (cmpdi crf tag ppc64::subtag-simple-vector) + (beq+ crf :got-it) + :no-got + (uuo_intcerr arch::error-object-not-simple-vector object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-simple-string (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :no-got) + (lbz tag ppc64::misc-subtag-offset object) + (cmpdi crf tag ppc64::subtag-simple-base-string) + (beq+ crf :got-it) + :no-got + (uuo_intcerr arch::error-object-not-simple-string object) + (b :again) + :got-it) + + +(define-ppc64-vinsn require-real (() + ((object :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (tag :u8) + (mask :u64))) + :again + (lis mask (ash 1 (- ppc64::subtag-double-float (+ 32 16)))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (ori mask mask (ash 1 (- ppc64::subtag-bignum 32))) + (cmpdi crf0 tag ppc64::fulltag-misc) + (sldi mask mask 32) + (bne crf0 :have-typecode) + (lbz tag ppc64::misc-subtag-offset object) + :have-typecode + (ori mask mask (logior (ash 1 ppc64::subtag-ratio) + (ash 1 ppc64::fulltag-odd-fixnum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::fulltag-even-fixnum))) + (cmpdi crf1 tag ppc64::subtag-double-float) + (srd mask mask tag) + (clrldi. mask mask 63) + (bgt crf1 :no-got) + (bne+ :got-it) + :no-got + (uuo_intcerr arch::error-object-not-real object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-number (() + ((object :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (tag :u8) + (mask :u64))) + :again + (lis mask (ash 1 (- ppc64::subtag-double-float (+ 32 16)))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (ori mask mask (ash 1 (- ppc64::subtag-bignum 32))) + (cmpdi crf0 tag ppc64::fulltag-misc) + (sldi mask mask 32) + (bne crf0 :have-typecode) + (lbz tag ppc64::misc-subtag-offset object) + :have-typecode + (ori mask mask (logior (ash 1 ppc64::subtag-ratio) + (ash 1 ppc64::fulltag-odd-fixnum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::fulltag-even-fixnum))) + (cmpdi crf1 tag ppc64::subtag-double-float) + (oris mask mask (ash 1 (- ppc64::subtag-complex 16))) + (srd mask mask tag) + (clrldi. mask mask 63) + (bgt crf1 :no-got) + (bne+ :got-it) + :no-got + (uuo_intcerr arch::error-object-not-number object) + (b :again) + :got-it) + + +(define-ppc64-vinsn require-list (() + ((object :lisp)) + ((tag :u8) + (crfx :crf) + (crfy :crf))) + :again + (cmpdi crfx object ppc64::nil-value) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crfy tag ppc64::fulltag-cons) + (beq crfx :got-it) + (beq+ crfy :got-it) + (uuo_intcerr arch::error-object-not-list object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-symbol (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :no-got) + (lbz tag ppc64::misc-subtag-offset object) + (cmpdi crf tag ppc64::subtag-symbol) + (beq+ crf :got-it) + :no-got + (uuo_intcerr arch::error-object-not-symbol object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-character (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + :again + (clrldi tag object (- ppc64::nbits-in-word ppc64::num-subtag-bits)) + (cmpdi crf tag ppc64::subtag-character) + (beq+ crf :got-it) + (uuo_intcerr arch::error-object-not-character object) + (b :again) + :got-it) + + +(define-ppc64-vinsn require-s8 (() + ((object :lisp)) + ((crf :crf) + (tag :s64))) + :again + (sldi tag object (- ppc64::nbits-in-word (+ 8 ppc64::fixnumshift))) + (sradi tag tag (- ppc64::nbits-in-word 8)) + (sldi tag tag ppc64::fixnumshift) + (cmpd crf tag object) + (beq+ crf :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-8 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-u8 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :u32))) + :again + ;; The bottom ppc64::fixnumshift bits and the top (- 64 (+ + ;; ppc64::fixnumshift 8)) must all be zero. + (rldicr. tag object (- 64 ppc64::fixnumshift) 55) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-unsigned-byte-8 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-s16 (() + ((object :lisp)) + ((crf :crf) + (tag :s64))) + :again + (sldi tag object (- ppc64::nbits-in-word (+ 16 ppc64::fixnumshift))) + (sradi tag tag (- ppc64::nbits-in-word 16)) + (sldi tag tag ppc64::fixnumshift) + (cmpd crf tag object) + (beq+ crf :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-16 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-u16 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :s64))) + :again + ;; The bottom ppc64::fixnumshift bits and the top (- 64 (+ + ;; ppc64::fixnumshift 8)) must all be zero. + (rldicr. tag object (- 64 ppc64::fixnumshift) 47) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-unsigned-byte-16 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-s32 (() + ((object :lisp)) + ((crf :crf) + (tag :s64))) + :again + (sldi tag object (- ppc64::nbits-in-word (+ 32 ppc64::fixnumshift))) + (sradi tag tag (- ppc64::nbits-in-word 32)) + (sldi tag tag ppc64::fixnumshift) + (cmpd crf tag object) + (beq+ crf :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-32 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-u32 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (tag :s64))) + :again + ;; The bottom ppc64::fixnumshift bits and the top (- 64 (+ + ;; ppc64::fixnumshift 32)) must all be zero. + (rldicr. tag object (- 64 ppc64::fixnumshift) 31) + (beq+ crf0 :got-it) + (uuo_intcerr arch::error-object-not-unsigned-byte-32 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-s64 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (tag :s64))) + :again + (clrldi. tag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (beq+ crf0 :got-it) + (cmpdi crf1 tag ppc64::fulltag-misc) + (bne- crf1 :bad) + (ld tag ppc64::misc-header-offset object) + (cmpdi crf0 tag ppc64::two-digit-bignum-header) + (beq+ crf0 :got-it) + :bad + (uuo_intcerr arch::error-object-not-signed-byte-64 object) + (b :again) + :got-it) + +(define-ppc64-vinsn require-u64 (() + ((object :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (crf2 :crf) + (temp :u64))) + (clrldi. temp object (- ppc64::nbits-in-word ppc64::fixnumshift)) + (clrldi temp object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf1 temp ppc64::fulltag-misc) + (sradi temp object ppc64::fixnumshift) + (beq crf0 :good-if-positive) + (bne crf1 :bad) + (ld temp ppc64::misc-header-offset object) + (cmpdi crf0 temp ppc64::three-digit-bignum-header) + (cmpdi crf2 temp ppc64::two-digit-bignum-header) + (beq crf0 :three-digit) + (bne crf2 :bad) + ;; two-digit case. Must be positive. + (ld temp ppc64::misc-data-offset object) + (rotldi temp temp 32) + :good-if-positive + (cmpdi crf1 temp 0) + (bge crf1 :good) + :bad + (uuo_interr arch::error-object-not-unsigned-byte-64 object) + :three-digit + (lwz temp (+ ppc64::misc-data-offset 8) object) + (cmpwi crf1 temp 0) + (bne crf1 :bad) + :good + ) + + +(define-ppc64-vinsn require-char-code (() + ((object :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (tag :u32))) + :again + (clrldi. tag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (lis tag (ash (ash #x110000 ppc64::fixnumshift) -16)) + (cmpld crf1 object tag) + (bne crf0 :bad) + (blt+ crf1 :got-it) + :bad + (uuo_intcerr arch::error-object-not-mod-char-code-limit object) + (b :again) + :got-it) + + +(define-ppc64-vinsn box-fixnum (((dest :imm)) + ((src :s64))) + (sldi dest src ppc64::fixnumshift)) + +(define-ppc64-vinsn fixnum->signed-natural (((dest :s64)) + ((src :imm))) + (sradi dest src ppc64::fixnumshift)) + +(define-ppc64-vinsn fixnum->unsigned-natural (((dest :u64)) + ((src :imm))) + (srdi dest src ppc64::fixnumshift)) + + + +(define-ppc64-vinsn unbox-u64 (((dest :u64)) + ((src :lisp)) + ((crf0 (:crf 0)) + (crf1 :crf) + (crf2 :crf))) + (clrldi. dest src (- ppc64::nbits-in-word ppc64::fixnumshift)) + (clrldi dest src (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf1 dest ppc64::fulltag-misc) + (sradi dest src ppc64::fixnumshift) + (beq crf0 :good-if-positive) + (bne crf1 :bad) + (ld dest ppc64::misc-header-offset src) + (cmpdi crf0 dest ppc64::three-digit-bignum-header) + (cmpdi crf2 dest ppc64::two-digit-bignum-header) + (beq crf0 :three-digit) + (bne crf2 :bad) + ;; two-digit case. Must be positive. + (ld dest ppc64::misc-data-offset src) + (rotldi dest dest 32) + :good-if-positive + (cmpdi crf1 dest 0) + (bge crf1 :good) + :bad + (uuo_interr arch::error-object-not-unsigned-byte-64 src) + :three-digit + (lwz dest (+ ppc64::misc-data-offset 8) src) + (cmpwi crf1 dest 0) + (ld dest ppc64::misc-data-offset src) + (rotldi dest dest 32) + (bne crf1 :bad) + :good + ) + +(define-ppc64-vinsn unbox-s64 (((dest :s64)) + ((src :lisp)) + ((crf0 :crf) + (crf1 :crf) + (tag :u64))) + + (clrldi. tag src (- ppc64::nbits-in-word ppc64::fixnumshift)) + (clrldi tag src (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf1 tag ppc64::fulltag-misc) + (sradi dest src ppc64::fixnumshift) + (beq+ crf0 :good) + (beq+ crf1 :bignum) + :bad + (uuo_interr arch::error-object-not-signed-byte-64 src) + :bignum + (ld tag ppc64::misc-header-offset src) + (ld dest ppc64::misc-data-offset src) + (cmpdi crf0 tag ppc64::two-digit-bignum-header) + (rotldi dest dest 32) + (bne- crf0 :bad) + :good + ) + +;;; An object is of type (UNSIGNED-BYTE 32) iff +;;; a) it's of type (UNSIGNED-BYTE 32) +;;; That pretty much narrows it down. + +(define-ppc64-vinsn unbox-u32 (((dest :u32)) + ((src :lisp)) + ((crf0 (:crf 0)))) + (rldicr. dest src (- 64 ppc64::fixnumshift) 31) + (srdi dest src ppc64::fixnumshift) + (beq crf0 :got-it) + :bad + (uuo_interr arch::error-object-not-unsigned-byte-32 src) + :got-it) + +;;; an object is of type (SIGNED-BYTE 32) iff +;;; a) it's of type (SIGNED-BYTE 32) +;;; b) see (a). + + +(define-ppc64-vinsn unbox-s32 (((dest :s32)) + ((src :lisp)) + ((crf :crf))) + (sldi dest src (- ppc64::nbits-in-word (+ 32 ppc64::fixnumshift))) + (sradi dest dest (- ppc64::nbits-in-word 32)) + (sldi dest dest ppc64::fixnumshift) + (cmpd crf dest src) + (sradi dest src ppc64::fixnumshift) + (beq crf :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-32 src) + :got-it) + + +(define-ppc64-vinsn unbox-u16 (((dest :u16)) + ((src :lisp)) + ((crf0 (:crf 0)))) + ;; The bottom ppc64::fixnumshift bits and the top (- 31 (+ + ;; ppc64::fixnumshift 16)) must all be zero. + (rldicr. dest src (- 64 ppc64::fixnumshift) 47) + (srdi dest src ppc64::fixnumshift) + (beq+ crf0 :got-it) + (uuo_interr arch::error-object-not-unsigned-byte-16 src) + :got-it) + +(define-ppc64-vinsn unbox-s16 (((dest :s16)) + ((src :lisp)) + ((crf :crf))) + (sldi dest src (- ppc64::nbits-in-word (+ 16 ppc64::fixnumshift))) + (sradi dest dest (- ppc64::nbits-in-word 16)) + (sldi dest dest ppc64::fixnumshift) + (cmpd crf dest src) + (sradi dest src ppc64::fixnumshift) + (beq+ crf :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-16 src) + :got-it) + + + +(define-ppc64-vinsn unbox-u8 (((dest :u8)) + ((src :lisp)) + ((crf0 (:crf 0)))) + ;; The bottom ppc64::fixnumshift bits and the top (- 63 (+ + ;; ppc64::fixnumshift 8)) must all be zero. + (rldicr. dest src (- 64 ppc64::fixnumshift) 55) + (srdi dest src ppc64::fixnumshift) + (beq+ crf0 :got-it) + (uuo_interr arch::error-object-not-unsigned-byte-8 src) + :got-it) + +(define-ppc64-vinsn %unbox-u8 (((dest :u8)) + ((src :lisp))) + ;; The bottom ppc64::fixnumshift bits and the top (- 63 (+ + ;; ppc64::fixnumshift 8)) must all be zero. + (rldicl dest src (- 64 ppc64::fixnumshift) 56)) + +(define-ppc64-vinsn unbox-s8 (((dest :s8)) + ((src :lisp)) + ((crf :crf))) + (sldi dest src (- ppc64::nbits-in-word (+ 8 ppc64::fixnumshift))) + (sradi dest dest (- ppc64::nbits-in-word 8)) + (sldi dest dest ppc64::fixnumshift) + (cmpd crf dest src) + (sradi dest src ppc64::fixnumshift) + (beq+ crf :got-it) + :bad + (uuo_interr arch::error-object-not-signed-byte-16 src) + :got-it) + +(define-ppc64-vinsn unbox-base-char (((dest :u32)) + ((src :lisp)) + ((crf :crf))) + (clrldi dest src (- 64 ppc64::num-subtag-bits)) + (cmpdi crf dest ppc64::subtag-character) + (srdi dest src ppc64::charcode-shift) + (beq+ crf :got-it) + (uuo_interr arch::error-object-not-character src) + :got-it) + +(define-ppc64-vinsn unbox-bit (((dest :u32)) + ((src :lisp)) + ((crf :crf))) + (cmplwi crf src (ash 1 ppc64::fixnumshift)) + (srawi dest src ppc64::fixnumshift) + (ble+ crf :got-it) + (uuo_interr arch::error-object-not-bit src) + :got-it) + +(define-ppc64-vinsn unbox-bit-bit0 (((dest :u32)) + ((src :lisp)) + ((crf :crf))) + (cmplwi crf src (ash 1 ppc64::fixnumshift)) + (rlwinm dest src (- 32 (1+ ppc64::fixnumshift)) 0 0) + (ble+ crf :got-it) + (uuo_interr arch::error-object-not-bit src) + :got-it) + + + + +(define-ppc64-vinsn shift-right-variable-word (((dest :u32)) + ((src :u32) + (sh :u32))) + (srw dest src sh)) + +;;; These vinsns are used in bit extraction operations, which +;;; currently do 32-bit memory references on both platforms. +(define-ppc64-vinsn u32logandc2 (((dest :u32)) + ((x :u32) + (y :u32))) + (andc dest x y)) + +(define-ppc64-vinsn u32logior (((dest :u32)) + ((x :u32) + (y :u32))) + (or dest x y)) + + +(define-ppc64-vinsn trap-unless-fixnum (() + ((object :lisp)) + ((tag :u8))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (tdnei tag ppc64::tag-fixnum)) + +(define-ppc64-vinsn trap-unless-character (() + ((object :lisp)) + ((tag :u8))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::num-subtag-bits)) + (tdnei tag ppc64::subtag-character)) + + +(define-ppc64-vinsn trap-unless-cons (() + ((object :lisp)) + ((tag :u8))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (tdnei tag ppc64::fulltag-cons)) + +(define-ppc64-vinsn trap-unless-list (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (cmpldi crf object ppc64::nil-value) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (beq crf :ok) + (tdi 3 tag ppc64::fulltag-cons) + :ok) + +(define-ppc64-vinsn trap-unless-uvector (() + ((object :lisp)) + ((tag :u8))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (tdnei tag ppc64::fulltag-misc)) + +(define-ppc64-vinsn trap-unless-single-float (() + ((object :lisp)) + ((tag :u8))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (tdnei tag ppc64::subtag-single-float)) + +(define-ppc64-vinsn trap-unless-double-float (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :do-trap) + (lbz tag ppc64::misc-subtag-offset object) + :do-trap + (tdnei tag ppc64::subtag-double-float)) + +(define-ppc64-vinsn trap-unless-array-header (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :do-trap) + (lbz tag ppc64::misc-subtag-offset object) + :do-trap + (tdnei tag ppc64::subtag-arrayH)) + +(define-ppc64-vinsn trap-unless-macptr (() + ((object :lisp)) + ((tag :u8) + (crf :crf))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :do-trap) + (lbz tag ppc64::misc-subtag-offset object) + :do-trap + (tdnei tag ppc64::subtag-macptr)) + + +(define-ppc64-vinsn trap-unless-typecode= (() + ((object :lisp) + (tagval :u16const)) + ((tag :u8) + (crf :crf))) + (clrldi tag object (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (clrldi tag object (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (bne crf :do-trap) + (lbz tag ppc64::misc-subtag-offset object) + :do-trap + (tdnei tag tagval)) + +(define-ppc64-vinsn subtract-constant (((dest :imm)) + ((src :imm) + (const :s16const))) + (subi dest src const)) + + + + +;;; Bit-extraction & boolean operations + + +;;; For some mind-numbing reason, IBM decided to call the most significant +;;; bit in a 32-bit word "bit 0" and the least significant bit "bit 31" +;;; (this despite the fact that it's essentially a big-endian architecture +;;; (it was exclusively big-endian when this decision was made.)) +;;; We'll probably be least confused if we consistently use this backwards +;;; bit ordering (letting things that have a "sane" bit-number worry about +;;; it at compile-time or run-time (subtracting the "sane" bit number from +;;; 31.)) + +(define-ppc64-vinsn extract-variable-bit (((dest :u8)) + ((src :u32) + (bitnum :u8)) + ()) + (rotlw dest src bitnum) + (extrwi dest dest 1 0)) + + +(define-ppc64-vinsn extract-variable-bit-fixnum (((dest :imm)) + ((src :u32) + (bitnum :u8)) + ((temp :u32))) + (rotlw temp src bitnum) + (rlwinm dest + temp + (1+ ppc64::fixnumshift) + (- ppc64::least-significant-bit ppc64::fixnumshift) + (- ppc64::least-significant-bit ppc64::fixnumshift))) + + +(define-ppc64-vinsn lowbit->truth (((dest :lisp) + (bits :u64)) + ((bits :u64)) + ()) + (mulli bits bits ppc64::t-offset) + (addi dest bits ppc64::nil-value)) + +(define-ppc64-vinsn invert-lowbit (((bits :u64)) + ((bits :u64)) + ()) + (xori bits bits 1)) + + + +;;; Some of the obscure-looking instruction sequences - which map some +;;; relation to PPC bit 31 of some register - were found by the GNU +;;; SuperOptimizer. Some of them use extended-precision instructions +;;; (which may cause interlocks on some superscalar PPCs, if I +;;; remember correctly.) In general, sequences that GSO found that +;;; -don't- do extended precision are longer and/or use more +;;; temporaries. On the 604, the penalty for using an instruction +;;; that uses the CA bit is "at least" one cycle: it can't complete +;;; execution until all "older" instructions have. That's not +;;; horrible, especially given that the alternative is usually to use +;;; more instructions (and, more importantly, more temporaries) to +;;; avoid using extended-precision. + + +(define-ppc64-vinsn eq0->bit31 (((bits :u64)) + ((src (t (:ne bits))))) + (cntlzd bits src) + (srdi bits bits 6)) ; bits = 0000...000X + +(define-ppc64-vinsn ne0->bit31 (((bits :u64)) + ((src (t (:ne bits))))) + (cntlzd bits src) + (sld bits src bits) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn lt0->bit31 (((bits :u64)) + ((src (t (:ne bits))))) + (srdi bits src 63)) ; bits = 0000...000X + + +(define-ppc64-vinsn ge0->bit31 (((bits :u64)) + ((src (t (:ne bits))))) + (srdi bits src 63) + (xori bits bits 1)) ; bits = 0000...000X + + +(define-ppc64-vinsn le0->bit31 (((bits :u64)) + ((src (t (:ne bits))))) + (neg bits src) + (orc bits bits src) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn gt0->bit31 (((bits :u64)) + ((src (t (:ne bits))))) + (subi bits src 1) + (nor bits bits src) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn ne->bit31 (((bits :u64)) + ((x t) + (y t)) + ((temp :u64))) + (subf temp x y) + (cntlzd bits temp) + (sld bits temp bits) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn fulltag->bit31 (((bits :u64)) + ((lispobj :lisp) + (tagval :u8const)) + ()) + (clrldi bits lispobj (- ppc64::nbits-in-word ppc64::ntagbits)) + (subi bits bits tagval) + (cntlzd bits bits) + (srdi bits bits 6)) + + +(define-ppc64-vinsn eq->bit31 (((bits :u64)) + ((x t) + (y t))) + (subf bits x y) + (cntlzd bits bits) + (srdi bits bits 6)) ; bits = 0000...000X + +(define-ppc64-vinsn eqnil->bit31 (((bits :u64)) + ((x t))) + (subi bits x ppc64::nil-value) + (cntlzd bits bits) + (srdi bits bits 6)) + +(define-ppc64-vinsn ne->bit31 (((bits :u64)) + ((x t) + (y t))) + (subf bits x y) + (cntlzd bits bits) + (srdi bits bits 6) + (xori bits bits 1)) + +(define-ppc64-vinsn nenil->bit31 (((bits :u64)) + ((x t))) + (subi bits x ppc64::nil-value) + (cntlzd bits bits) + (srdi bits bits 6) + (xori bits bits 1)) + +(define-ppc64-vinsn lt->bit31 (((bits :u64)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + + (xor bits x y) + (sradi bits bits 63) + (or bits bits x) + (subf bits y bits) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn ltu->bit31 (((bits :u64)) + ((x :u64) + (y :u64))) + (subfc bits y x) + (subfe bits bits bits) + (neg bits bits)) + +(define-ppc64-vinsn le->bit31 (((bits :u64)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + + (xor bits x y) + (sradi bits bits 63) + (nor bits bits y) + (add bits bits x) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn leu->bit31 (((bits :u32)) + ((x :u32) + (y :u32))) + (subfc bits x y) + (addze bits ppc::rzero)) + +(define-ppc64-vinsn gt->bit31 (((bits :u32)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + + (eqv bits x y) + (sradi bits bits 63) + (and bits bits x) + (subf bits bits y) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn gtu->bit31 (((bits :u64)) + ((x :u64) + (y :u64))) + (subfc bits x y) + (subfe bits bits bits) + (neg bits bits)) + +(define-ppc64-vinsn ge->bit31 (((bits :u64)) + ((x (t (:ne bits))) + (y (t (:ne bits))))) + (eqv bits x y) + (sradi bits bits 63) + (andc bits bits x) + (add bits bits y) + (srdi bits bits 63)) ; bits = 0000...000X + +(define-ppc64-vinsn geu->bit31 (((bits :u64)) + ((x :u64) + (y :u64))) + (subfc bits y x) + (addze bits ppc::rzero)) + + +;;; there are big-time latencies associated with MFCR on more heavily +;;; pipelined processors; that implies that we should avoid this like +;;; the plague. +;;; GSO can't find anything much quicker for LT or GT, even though +;;; MFCR takes three cycles and waits for previous instructions to complete. +;;; Of course, using a CR field costs us something as well. +(define-ppc64-vinsn crbit->bit31 (((bits :u64)) + ((crf :crf) + (bitnum :crbit)) + ()) + (mfcr bits) ; Suffer. + (rlwinm bits bits (:apply + 1 bitnum (:apply ash crf 2)) 31 31)) ; bits = 0000...000X + + +(define-ppc64-vinsn compare (((crf :crf)) + ((arg0 t) + (arg1 t)) + ()) + (cmpd crf arg0 arg1)) + +(define-ppc64-vinsn compare-to-nil (((crf :crf)) + ((arg0 t))) + (cmpdi crf arg0 ppc64::nil-value)) + +(define-ppc64-vinsn compare-logical (((crf :crf)) + ((arg0 t) + (arg1 t)) + ()) + (cmpld crf arg0 arg1)) + +(define-ppc64-vinsn double-float-compare (((crf :crf)) + ((arg0 :double-float) + (arg1 :double-float)) + ()) + (fcmpo crf arg0 arg1)) + + +(define-ppc64-vinsn double-float+-2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fadd result x y)) + +(define-ppc64-vinsn double-float--2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fsub result x y)) + +(define-ppc64-vinsn double-float*-2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fmul result x y)) + +(define-ppc64-vinsn double-float/-2 (((result :double-float)) + ((x :double-float) + (y :double-float)) + ((crf (:crf 4)))) + (fdiv result x y)) + +(define-ppc64-vinsn single-float+-2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fadds result x y)) + +(define-ppc64-vinsn single-float--2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fsubs result x y)) + +(define-ppc64-vinsn single-float*-2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fmuls result x y)) + +(define-ppc64-vinsn single-float/-2 (((result :single-float)) + ((x :single-float) + (y :single-float)) + ((crf (:crf 4)))) + (fdivs result x y)) + + + +(define-ppc64-vinsn compare-signed-s16const (((crf :crf)) + ((arg0 :imm) + (imm :s16const)) + ()) + (cmpdi crf arg0 imm)) + +(define-ppc64-vinsn compare-unsigned-u16const (((crf :crf)) + ((arg0 :u32) + (imm :u16const)) + ()) + (cmpldi crf arg0 imm)) + + + +;;; Extract a constant bit (0-63) from src; make it be bit 63 of dest. +;;; Bitnum is treated mod 64. (This is used in LOGBITP). +(define-ppc64-vinsn extract-constant-ppc-bit (((dest :u64)) + ((src :imm) + (bitnum :u16const)) + ()) + (rldicl dest src (:apply + 1 bitnum) 63)) + + +(define-ppc64-vinsn set-constant-ppc-bit-to-variable-value (((dest :u32)) + ((src :u32) + (bitval :u32) ; 0 or 1 + (bitnum :u8const))) + (rlwimi dest bitval (:apply - 31 bitnum) bitnum bitnum)) + +(define-ppc64-vinsn set-constant-ppc-bit-to-1 (((dest :u32)) + ((src :u32) + (bitnum :u8const))) + ((:pred < bitnum 16) + (oris dest src (:apply ash #x8000 (:apply - bitnum)))) + ((:pred >= bitnum 16) + (ori dest src (:apply ash #x8000 (:apply - (:apply - bitnum 16)))))) + +(define-ppc64-vinsn set-constant-ppc-bit-to-0 (((dest :u32)) + ((src :u32) + (bitnum :u8const))) + (rlwinm dest src 0 (:apply logand #x1f (:apply 1+ bitnum)) (:apply logand #x1f (:apply 1- bitnum)))) + + +(define-ppc64-vinsn insert-bit-0 (((dest :u32)) + ((src :u32) + (val :u32))) + (rlwimi dest val 0 0 0)) + +;;; The bit number is boxed and wants to think of the +;;; least-significant bit as 0. Imagine that. To turn the boxed, +;;; lsb-0 bitnumber into an unboxed, msb-0 rotate count, we +;;; (conceptually) unbox it, add ppc64::fixnumshift to it, subtract it +;;; from 31, and add one. This can also be done as "unbox and +;;; subtract from 28", I think ... Actually, it'd be "unbox, then +;;; subtract from 30". +(define-ppc64-vinsn extract-variable-non-insane-bit (((dest :u64)) + ((src :imm) + (bit :imm)) + ((temp :u64))) + (srdi temp bit ppc64::fixnumshift) + (subfic temp temp (- 64 ppc64::fixnumshift)) + (rldcl dest src temp 63)) + +;;; Operations on lists and cons cells + +(define-ppc64-vinsn %cdr (((dest :lisp)) + ((src :lisp))) + (ld dest ppc64::cons.cdr src)) + +(define-ppc64-vinsn %car (((dest :lisp)) + ((src :lisp))) + (ld dest ppc64::cons.car src)) + +(define-ppc64-vinsn %set-car (() + ((cell :lisp) + (new :lisp))) + (std new ppc64::cons.car cell)) + +(define-ppc64-vinsn %set-cdr (() + ((cell :lisp) + (new :lisp))) + (std new ppc64::cons.cdr cell)) + +(define-ppc64-vinsn load-adl (() + ((n :u32const))) + (lis ppc::nargs (:apply ldb (byte 16 16) n)) + (ori ppc::nargs ppc::nargs (:apply ldb (byte 16 0) n))) + +(define-ppc64-vinsn set-nargs (() + ((n :s16const))) + (li ppc::nargs (:apply ash n ppc64::word-shift))) + +(define-ppc64-vinsn scale-nargs (() + ((nfixed :s16const))) + ((:pred > nfixed 0) + (la ppc::nargs (:apply - (:apply ash nfixed ppc64::word-shift)) ppc::nargs))) + + + +(define-ppc64-vinsn (vpush-register :push :node :vsp) + (() + ((reg :lisp))) + (stdu reg -8 ppc::vsp)) + +(define-ppc64-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument) + (() + ((reg :lisp))) + (stdu reg -8 ppc::vsp)) + +(define-ppc64-vinsn (vpop-register :pop :node :vsp) + (((dest :lisp)) + ()) + (ld dest 0 ppc::vsp) + (la ppc::vsp ppc64::word-size-in-bytes ppc::vsp)) + + +(define-ppc64-vinsn copy-node-gpr (((dest :lisp)) + ((src :lisp))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (mr dest src))) + +(define-ppc64-vinsn copy-gpr (((dest t)) + ((src t))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (mr dest src))) + + +(define-ppc64-vinsn copy-fpr (((dest :double-float)) + ((src :double-float))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (fmr dest src))) + +(define-ppc64-vinsn vcell-ref (((dest :lisp)) + ((vcell :lisp))) + (ld dest ppc64::misc-data-offset vcell)) + +(define-ppc64-vinsn vcell-set (() + ((vcell :lisp) + (value :lisp))) + (std value ppc64::misc-data-offset vcell)) + + +(define-ppc64-vinsn make-vcell (((dest :lisp)) + ((closed (:lisp :ne dest))) + ((header :u64))) + (li header ppc64::value-cell-header) + (la ppc::allocptr (- ppc64::fulltag-misc ppc64::value-cell.size) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + (std closed ppc64::value-cell.value dest)) + +(define-ppc64-vinsn make-tsp-vcell (((dest :lisp)) + ((closed :lisp)) + ((header :u64))) + (li header ppc64::value-cell-header) + (stdu ppc::tsp -32 ppc::tsp) + (std ppc::tsp 8 ppc::tsp) + (stfd ppc::fp-zero 16 ppc::tsp) + (stfd ppc::fp-zero 24 ppc::tsp) + (std ppc::rzero 8 ppc::tsp) + (std header (+ 16 ppc64::fulltag-misc ppc64::value-cell.header) ppc::tsp) + (std closed (+ 16 ppc64::fulltag-misc ppc64::value-cell.value) ppc::tsp) + (la dest (+ 16 ppc64::fulltag-misc) ppc::tsp)) + +(define-ppc64-vinsn make-tsp-cons (((dest :lisp)) + ((car :lisp) (cdr :lisp)) + ()) + (stdu ppc::tsp -32 ppc::tsp) + (std ppc::tsp 8 ppc::tsp) + (stfd ppc::fp-zero 16 ppc::tsp) + (stfd ppc::fp-zero 24 ppc::tsp) + (std ppc::rzero 8 ppc::tsp) + (std car (+ 16 ppc64::fulltag-cons ppc64::cons.car) ppc::tsp) + (std cdr (+ 16 ppc64::fulltag-cons ppc64::cons.cdr) ppc::tsp) + (la dest (+ 16 ppc64::fulltag-cons) ppc::tsp)) + + +(define-ppc64-vinsn %closure-code% (((dest :lisp)) + ()) + (ld dest (+ ppc64::symbol.vcell (ppc64::nrs-offset %closure-code%) ppc64::nil-value) 0)) + +(define-ppc64-vinsn single-float-bits (((dest :u32)) + ((src :lisp))) + (srdi dest src 32)) + +(define-ppc64-vinsn (call-subprim :call :subprim-call) (() + ((spno :s32const))) + (bla spno)) + +(define-ppc64-vinsn (jump-subprim :jumpLR) (() + ((spno :s32const))) + (ba spno)) + +;;; Same as "call-subprim", but gives us a place to +;;; track args, results, etc. +(define-ppc64-vinsn (call-subprim-0 :call :subprim-call) (((dest t)) + ((spno :s32const))) + (bla spno)) + +(define-ppc64-vinsn (call-subprim-1 :call :subprim-call) (((dest t)) + ((spno :s32const) + (z t))) + (bla spno)) + +(define-ppc64-vinsn (call-subprim-2 :call :subprim-call) (((dest t)) + ((spno :s32const) + (y t) + (z t))) + (bla spno)) + +(define-ppc64-vinsn (call-subprim-3 :call :subprim-call) (((dest t)) + ((spno :s32const) + (x t) + (y t) + (z t))) + (bla spno)) + +(define-ppc64-vinsn event-poll (() + () + ((crf :crf))) + (ld ppc::nargs ppc64::tcr.tlb-pointer ppc64::rcontext) + (ld ppc::nargs ppc64::interrupt-level-binding-index ppc::nargs) + (cmpdi crf ppc::nargs 0) + (blt crf :done) + (bgt crf :trap) + (ld ppc::nargs ppc64::tcr.interrupt-pending ppc64::rcontext) + :trap + (tdgti ppc::nargs 0) + :done) + +(define-ppc64-vinsn ref-interrupt-level (((dest :imm)) + () + ((temp :u64))) + (ld temp ppc64::tcr.tlb-pointer ppc64::rcontext) + (ld dest ppc64::INTERRUPT-LEVEL-BINDING-INDEX temp)) + +;;; Unconditional (pc-relative) branch +(define-ppc64-vinsn (jump :jump) + (() + ((label :label))) + (b label)) + +(define-ppc64-vinsn (call-label :call) (() + ((label :label))) + (bl label)) + +;;; just like JUMP, only (implicitly) asserts that the following +;;; code is somehow reachable. +(define-ppc64-vinsn (non-barrier-jump :xref) (() + ((label :label))) + (b label)) + + +(define-ppc64-vinsn (cbranch-true :branch) (() + ((label :label) + (crf :crf) + (crbit :u8const))) + (bt (:apply + crf crbit) label)) + +(define-ppc64-vinsn (cbranch-false :branch) (() + ((label :label) + (crf :crf) + (crbit :u8const))) + (bf (:apply + crf crbit) label)) + +(define-ppc64-vinsn check-trap-error (() + ()) + (beq+ 0 :no-error) + (uuo_interr arch::error-reg-regnum ppc::arg_z) + :no-error) + + +(define-ppc64-vinsn lisp-word-ref (((dest t)) + ((base t) + (offset t))) + (ldx dest base offset)) + +(define-ppc64-vinsn lisp-word-ref-c (((dest t)) + ((base t) + (offset :s16const))) + (ld dest offset base)) + + +(define-ppc64-vinsn (lri :constant-ref) (((dest :imm)) + ((intval :u64const)) + ()) + ((:or (:pred = (:apply ash intval -15) #x1FFFFFFFFFFFF) + (:pred = (:apply ash intval -15) 0)) + (li dest (:apply %word-to-int (:apply logand #xffff intval)))) + ((:not + (:or (:pred = (:apply ash intval -15) #x1FFFFFFFFFFFF) + (:pred = (:apply ash intval -15) 0))) + ((:or (:pred = (:apply ash intval -31) 0) + (:pred = (:apply ash intval -31) #x1ffffffff)) + (lis dest (:apply %word-to-int (:apply ldb (:apply byte 16 16) intval))) + ((:not (:pred = (:apply ldb (:apply byte 16 0) intval) 0)) + (ori dest dest (:apply ldb (:apply byte 16 0) intval)))) + ((:not (:or (:pred = (:apply ash intval -31) 0) + (:pred = (:apply ash intval -31) #x1ffffffff))) + ((:pred = (:apply ash intval -32) 0) + (oris dest ppc::rzero (:apply ldb (:apply byte 16 16) intval)) + ((:not (:pred = (:apply ldb (:apply byte 16 0) intval) 0)) + (ori dest dest (:apply ldb (:apply byte 16 0) intval)))) + ((:not (:pred = (:apply ash intval -32) 0)) + ;; This is the general case, where all halfwords are significant. + ;; Hopefully, something above catches lots of other cases. + (lis dest (:apply %word-to-int (:apply ldb (:apply byte 16 48) intval))) + ((:not (:pred = (:apply ldb (:apply byte 16 32) intval) 0)) + (ori dest dest (:apply ldb (:apply byte 16 32) intval))) + (sldi dest dest 32) + ((:not (:pred = (:apply ldb (:apply byte 16 16) intval) 0)) + (oris dest dest (:apply ldb (:apply byte 16 16) intval))) + ((:not (:pred = (:apply ldb (:apply byte 16 0) intval) 0)) + (ori dest dest (:apply ldb (:apply byte 16 0) intval))))))) + + +(define-ppc64-vinsn discard-temp-frame (() + ()) + (ld ppc::tsp 0 ppc::tsp)) + + +;;; Somewhere, deep inside the "OS_X_PPC_RuntimeConventions.pdf" +;;; document, they bother to document the fact that SP should +;;; maintain 32-byte alignment on OSX. (The example prologue +;;; code in that document incorrectly assumes 8-byte alignment. +;;; Or something. It's wrong in a number of other ways.) +;;; The caller always has to reserve a 24-byte linkage area +;;; (large chunks of which are unused). +(define-ppc64-vinsn alloc-c-frame (() + ((n-c-args :u16const))) + ;; Always reserve space for at least 8 args and space for a lisp + ;; frame (for the kernel) underneath it. + ;; Zero the c-frame's savelr field, not that the GC cares .. + ((:pred <= n-c-args 10) + (stdu ppc::sp (- (+ 16 ppc64::c-frame.size ppc64::lisp-frame.size)) ppc::sp)) + ((:pred > n-c-args 10) + ;; A normal C frame has room for 10 args (when padded out to + ;; 32-byte alignment. Add enough double words to accomodate the + ;; remaining args, in multiples of 4. + (stdu ppc::sp (:apply - (:apply + + 16 + (+ ppc64::c-frame.size ppc64::lisp-frame.size) + (:apply ash + (:apply logand + (lognot 7) + (:apply + + + 7 + (:apply - n-c-args 10))) + 3))) + ppc::sp)) + (std ppc::rzero ppc64::c-frame.savelr ppc::sp)) + + +(define-ppc64-vinsn alloc-variable-c-frame (() + ((n-c-args :lisp)) + ((crf :crf) + (size :s64))) + (cmpdi crf n-c-args (ash 10 ppc64::fixnumshift)) + (subi size n-c-args (ash 10 ppc64::fixnumshift)) + (bgt :variable) + ;; Always reserve space for at least 8 args and space for a lisp + ;; frame (for the kernel) underneath it. + (stdu ppc::sp (- (+ 16 ppc64::c-frame.size ppc64::lisp-frame.size)) ppc::sp) + (b :done) + :variable + (addi size size (+ (+ 16 ppc64::c-frame.size ppc64::lisp-frame.size) (ash 3 ppc64::fixnumshift))) + (clrrdi size size 4) + (neg size size) + (stdux ppc::sp ppc::sp size) + :done + (stw ppc::rzero ppc64::c-frame.savelr ppc::sp)) + +;;; We should rarely have to do this. It's easier to just generate code +;;; to do the memory reference than it would be to keep track of the size +;;; of each frame. +(define-ppc64-vinsn discard-c-frame (() + ()) + (ld ppc::sp 0 ppc::sp)) + + + + +(define-ppc64-vinsn set-c-arg (() + ((argval :u32) + (argnum :u16const))) + (std argval (:apply + ppc64::c-frame.param0 (:apply ash argnum ppc64::word-shift)) ppc::sp)) + +(define-ppc64-vinsn set-single-c-arg (() + ((argval :single-float) + (argnum :u16const))) + (stfs argval (:apply + ppc64::c-frame.param0 4 (:apply ash argnum ppc64::word-shift)) ppc::sp)) + +(define-ppc64-vinsn set-double-c-arg (() + ((argval :double-float) + (argnum :u16const))) + (stfd argval (:apply + ppc64::c-frame.param0 (:apply ash argnum ppc64::word-shift)) ppc::sp)) + +(define-ppc64-vinsn reload-single-c-arg (((argval :single-float)) + ((argnum :u16const))) + (lfs argval (:apply + ppc64::c-frame.param0 4 (:apply ash argnum ppc64::word-shift)) ppc::sp)) + +(define-ppc64-vinsn reload-single-c-arg-high (((argval :single-float)) + ((argnum :u16const))) + (lfs argval (:apply + ppc64::c-frame.param0 (:apply ash argnum ppc64::word-shift)) ppc::sp)) + +(define-ppc64-vinsn reload-double-c-arg (((argval :double-float)) + ((argnum :u16const))) + (lfd argval (:apply + ppc64::c-frame.param0 (:apply ash argnum ppc64::word-shift)) ppc::sp)) + +(define-ppc64-vinsn (load-nil :constant-ref) (((dest t)) + ()) + (li dest ppc64::nil-value)) + + +(define-ppc64-vinsn (load-t :constant-ref) (((dest t)) + ()) + (li dest (+ ppc64::t-offset ppc64::nil-value))) + +(define-ppc64-vinsn set-eq-bit (((dest :crf)) + ()) + (creqv (:apply + ppc::ppc-eq-bit dest) + (:apply + ppc::ppc-eq-bit dest) + (:apply + ppc::ppc-eq-bit dest))) + +(define-ppc64-vinsn (ref-constant :constant-ref) (((dest :lisp)) + ((src :s16const))) + (ld dest (:apply + ppc64::misc-data-offset (:apply ash (:apply 1+ src) 3)) ppc::fn)) + +(define-ppc64-vinsn ref-indexed-constant (((dest :lisp)) + ((idxreg :s64))) + (ldx dest ppc::fn idxreg)) + + +(define-ppc64-vinsn cons (((dest :lisp)) + ((newcar :lisp) + (newcdr :lisp))) + (la ppc::allocptr (- ppc64::fulltag-cons ppc64::cons.size) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std newcdr ppc64::cons.cdr ppc::allocptr) + (std newcar ppc64::cons.car ppc::allocptr) + (mr dest ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits))) + + + +;;; subtag had better be a PPC-NODE-SUBTAG of some sort! +(define-ppc64-vinsn %ppc-gvector (((dest :lisp)) + ((Rheader :u32) + (nbytes :u32const)) + ((immtemp0 :u32) + (nodetemp :lisp) + (crf :crf))) + (la ppc::allocptr (:apply - ppc64::fulltag-misc + (:apply logand (lognot 15) + (:apply + (+ 15 8) nbytes))) + ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std Rheader ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + ((:not (:pred = nbytes 0)) + (li immtemp0 (:apply + ppc64::misc-data-offset nbytes)) + :loop + (subi immtemp0 immtemp0 8) + (cmpdi crf immtemp0 ppc64::misc-data-offset) + (ld nodetemp 0 ppc::vsp) + (la ppc::vsp 8 ppc::vsp) + (stdx nodetemp dest immtemp0) + (bne crf :loop))) + +;;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag +(define-ppc64-vinsn %alloc-misc-fixed (((dest :lisp)) + ((Rheader :u64) + (nbytes :u32const))) + (la ppc::allocptr (:apply - ppc64::fulltag-misc + (:apply logand (lognot 15) + (:apply + (+ 15 8) nbytes))) + ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std Rheader ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits))) + +(define-ppc64-vinsn vstack-discard (() + ((nwords :u32const))) + ((:not (:pred = nwords 0)) + (la ppc::vsp (:apply ash nwords ppc64::word-shift) ppc::vsp))) + + +(define-ppc64-vinsn lcell-load (((dest :lisp)) + ((cell :lcell) + (top :lcell))) + (ld dest (:apply - + (:apply - (:apply calc-lcell-depth top) ppc64::word-size-in-bytes) + (:apply calc-lcell-offset cell)) ppc::vsp)) + +(define-ppc64-vinsn vframe-load (((dest :lisp)) + ((frame-offset :u16const) + (cur-vsp :u16const))) + (ld dest (:apply - (:apply - cur-vsp ppc64::word-size-in-bytes) frame-offset) ppc::vsp)) + +(define-ppc64-vinsn lcell-store (() + ((src :lisp) + (cell :lcell) + (top :lcell))) + (stw src (:apply - + (:apply - (:apply calc-lcell-depth top) 4) + (:apply calc-lcell-offset cell)) ppc::vsp)) + +(define-ppc64-vinsn vframe-store (() + ((src :lisp) + (frame-offset :u16const) + (cur-vsp :u16const))) + (std src (:apply - (:apply - cur-vsp 8) frame-offset) ppc::vsp)) + +(define-ppc64-vinsn load-vframe-address (((dest :imm)) + ((offset :s16const))) + (la dest offset ppc::vsp)) + +(define-ppc64-vinsn copy-lexpr-argument (() + () + ((temp :lisp))) + (ldx temp ppc::vsp ppc::nargs) + (stdu temp -8 ppc::vsp)) + +;;; Boxing/unboxing of integers. + +;;; Treat the low 8 bits of VAL as an unsigned integer; set RESULT to +;;; the equivalent fixnum. +(define-ppc64-vinsn u8->fixnum (((result :imm)) + ((val :u8)) + ()) + (clrlsldi result val (- ppc64::nbits-in-word 8) ppc64::fixnumshift)) + +;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the +;;; equivalent fixnum. +(define-ppc64-vinsn s8->fixnum (((result :imm)) + ((val :s8)) + ()) + (sldi result val (- ppc64::nbits-in-word 8)) + (sradi result result (- (- ppc64::nbits-in-word 8) ppc64::fixnumshift))) + + +;;; Treat the low 16 bits of VAL as an unsigned integer; set RESULT to +;;; the equivalent fixnum. +(define-ppc64-vinsn u16->fixnum (((result :imm)) + ((val :u16)) + ()) + (clrlsldi result val (- ppc64::nbits-in-word 16) ppc64::fixnumshift)) + +;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to +;;; the equivalent fixnum. +(define-ppc64-vinsn s16->fixnum (((result :imm)) + ((val :s16)) + ()) + (sldi result val (- ppc64::nbits-in-word 16)) + (sradi result result (- (- ppc64::nbits-in-word 16) ppc64::fixnumshift))) + +(define-ppc64-vinsn fixnum->s16 (((result :s16)) + ((src :imm))) + (sradi result src ppc64::fixnumshift)) + +(define-ppc64-vinsn s32->integer (((result :lisp)) + ((src :s32)) + ((temp :s64))) + (extsw temp src) + (sldi result temp ppc64::fixnumshift)) + + +;;; A signed 64-bit untagged value can be at worst a 2-digit +;;; (minimal-sized) bignum. There should be something very much like +;;; this that takes a stack-consed bignum result ... +(define-ppc64-vinsn s64->integer (((result :lisp)) + ((src :s64)) + ((crf (:crf 0)) ; a casualty + (temp :s64) + (header :s64))) + (addo temp src src) + (addo temp temp temp) + (addo. result temp temp) + (rotldi temp src 32) + (bns+ :done) + (mtxer ppc::rzero) + (li header ppc64::two-digit-bignum-header) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + (std temp ppc64::misc-data-offset result) + :done) + + +;;; An unsigned 32-bit untagged value is a fixnum. +(define-ppc64-vinsn u32->integer (((result :lisp)) + ((src :u32))) + (sldi result src ppc64::fixnumshift)) + +;;; An unsigned 64-bit untagged value is either a fixnum, a 2 (32-bit) +;;; digit bignum, or a 3 (32-bit) digit bignum. +(define-ppc64-vinsn u64->integer (((result :lisp)) + ((src :u64)) + ((temp :u64) + (header :u64) + (crf0 (:crf 0)) + (crf1 :crf))) + (clrrdi. temp src (- 63 ppc64::nfixnumtagbits)) + (cmpdi crf1 src 0) + (sldi result src ppc64::fixnumshift) + (beq crf0 :done) + (rotldi temp src 32) + (li header ppc64::two-digit-bignum-header) + (blt crf1 :three) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + (b :store) + :three + (la ppc::allocptr (- ppc64::fulltag-misc 32) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + :store + (std temp ppc64::misc-data-offset result) + :done) + +(define-ppc64-vinsn u16->u32 (((dest :u32)) + ((src :u16))) + (clrlwi dest src 16)) + +(define-ppc64-vinsn u8->u32 (((dest :u32)) + ((src :u8))) + (clrlwi dest src 24)) + + +(define-ppc64-vinsn s16->s32 (((dest :s32)) + ((src :s16))) + (extsh dest src)) + +(define-ppc64-vinsn s8->s32 (((dest :s32)) + ((src :s8))) + (extsb dest src)) + + +;;; ... of floats ... + +;;; Heap-cons a double-float to store contents of FPREG. Hope that we +;;; don't do this blindly. +(define-ppc64-vinsn double->heap (((result :lisp)) ; tagged as a double-float + ((fpreg :double-float)) + ((header-temp :u32))) + (li header-temp (arch::make-vheader ppc64::double-float.element-count ppc64::subtag-double-float)) + (la ppc::allocptr (- ppc64::fulltag-misc ppc64::double-float.size) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header-temp ppc64::misc-header-offset ppc::allocptr) + (mr result ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + (stfd fpreg ppc64::double-float.value result) ) + + +(define-ppc64-vinsn single->node (((result :lisp)) ; tagged as a single-float + ((fpreg :single-float))) + (stfs fpreg ppc64::tcr.single-float-convert ppc64::rcontext) + (ld result ppc64::tcr.single-float-convert ppc64::rcontext)) + + +;;; "dest" is preallocated, presumably on a stack somewhere. +(define-ppc64-vinsn store-double (() + ((dest :lisp) + (source :double-float)) + ()) + (stfd source ppc64::double-float.value dest)) + +(define-ppc64-vinsn get-double (((target :double-float)) + ((source :lisp)) + ()) + (lfd target ppc64::double-float.value source)) + +;;; 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-ppc64-vinsn get-double? (((target :double-float)) + ((source :lisp)) + ((tag :u8) + (crf :crf))) + (clrldi tag source (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne crf :do-trap) + (lbz tag ppc64::misc-subtag-offset source) + :do-trap + (tdnei tag ppc64::subtag-double-float) + (lfd target ppc64::double-float.value source)) + +(define-ppc64-vinsn double-to-single (((result :single-float)) + ((arg :double-float))) + (frsp result arg)) + + +(define-ppc64-vinsn store-single (() + ((dest :lisp) + (source :single-float)) + ()) + (stfs source ppc64::tcr.single-float-convert ppc64::rcontext) + (ld dest ppc64::tcr.single-float-convert ppc64::rcontext)) + +(define-ppc64-vinsn get-single (((target :single-float)) + ((source :lisp))) + (std source ppc64::tcr.single-float-convert ppc64::rcontext) + (lfs target ppc64::tcr.single-float-convert ppc64::rcontext)) + +;;; ... of characters ... +(define-ppc64-vinsn charcode->u16 (((dest :u16)) + ((src :imm)) + ()) + (srdi dest src ppc64::charcode-shift)) + +(define-ppc64-vinsn character->fixnum (((dest :lisp)) + ((src :lisp)) + ()) + (srdi dest src (- ppc64::charcode-shift ppc64::fixnumshift))) + +(define-ppc64-vinsn character->code (((dest :u32)) + ((src :lisp))) + (srdi dest src ppc64::charcode-shift)) + + +(define-ppc64-vinsn fixnum->char (((dest :lisp)) + ((src :imm)) + ((temp :u64) + (crf0 (:crf 0)))) + (srdi temp src (+ ppc64::fixnumshift 11)) + (cmpdi temp 27) + (sldi dest src (- ppc64::charcode-shift ppc64::fixnumshift)) + (bne+ :ok) + (li dest ppc64::nil-value) + (b :done) + :ok + (addi dest dest ppc64::subtag-character) + :done) + +(define-ppc64-vinsn u32->char (((dest :lisp)) + ((src :u32)) + ()) + (sldi dest src ppc64::charcode-shift) + (ori dest dest ppc64::subtag-character)) + +;;; ... Macptrs ... + +(define-ppc64-vinsn deref-macptr (((addr :address)) + ((src :lisp)) + ()) + (ld addr ppc64::macptr.address src)) + +(define-ppc64-vinsn set-macptr-address (() + ((addr :address) + (src :lisp)) + ()) + (std addr ppc64::macptr.address src)) + + +(define-ppc64-vinsn macptr->heap (((dest :lisp)) + ((address :address)) + ((header :u64))) + (li header (logior (ash ppc64::macptr.element-count ppc64::num-subtag-bits) ppc64::subtag-macptr)) + (la ppc::allocptr (- ppc64::fulltag-misc ppc64::macptr.size) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (rldicr ppc::allocptr ppc::allocptr 0 (- 63 ppc64::ntagbits)) + ;; It's not necessary to zero out the domain/type fields, since newly + ;; heap-allocated memory's guaranteed to be 0-filled. + (std address ppc64::macptr.address dest)) + +(define-ppc64-vinsn macptr->stack (((dest :lisp)) + ((address :address)) + ((header :u64))) + (li header ppc64::macptr-header) + (stdu ppc::tsp (- (+ 16 ppc64::macptr.size)) ppc::tsp) + (std ppc::tsp 8 ppc::tsp) + (std header (+ 16 ppc64::fulltag-misc ppc64::macptr.header) ppc::tsp) + (std address (+ 16 ppc64::fulltag-misc ppc64::macptr.address) ppc::tsp) + ;; It -is- necessary to zero out the domain/type fields here, since + ;; stack-allocated memory isn't guaranteed to be 0-filled. + (std ppc::rzero (+ 16 ppc64::fulltag-misc ppc64::macptr.domain) ppc::tsp) + (std ppc::rzero (+ 16 ppc64::fulltag-misc ppc64::macptr.type) ppc::tsp) + (la dest (+ 16 ppc64::fulltag-misc) ppc::tsp)) + + +(define-ppc64-vinsn adjust-stack-register (() + ((reg t) + (amount :s16const))) + (la reg amount reg)) + +(define-ppc64-vinsn adjust-vsp (() + ((amount :s16const))) + (la ppc::vsp amount ppc::vsp)) + +(define-ppc64-vinsn adjust-sp (() + ((amount :s16const))) + (la ppc::sp amount ppc::sp)) + +;;; Arithmetic on fixnums & unboxed numbers + +(define-ppc64-vinsn u64-lognot (((dest :u64)) + ((src :u64)) + ()) + (not dest src)) + +(define-ppc64-vinsn fixnum-lognot (((dest :imm)) + ((src :imm)) + ((temp :u64))) + (not temp src) + (rldicr dest temp 0 (- 63 ppc64::nfixnumtagbits))) + + +(define-ppc64-vinsn negate-fixnum-overflow-inline (((dest :lisp)) + ((src :imm)) + ((unboxed :s64) + (header :u64))) + (nego. dest src) + (bns+ :done) + (mtxer ppc::rzero) + (sradi unboxed dest ppc64::fixnumshift) + (li header ppc64::two-digit-bignum-header) + (rotldi unboxed unboxed 32) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc64::fixnumshift)))) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrdi ppc::allocptr ppc::allocptr ppc64::ntagbits) + (std unboxed ppc64::misc-data-offset dest) + :done) + +(define-ppc64-vinsn negate-fixnum-overflow-ool (() + ((src :imm)) + ) + (nego. ppc::arg_z src) + (bsola- .SPfix-overflow) + :done) + + + +(define-ppc64-vinsn negate-fixnum-no-ovf (((dest :lisp)) + ((src :imm))) + + (neg dest src)) + + +(define-ppc64-vinsn logior-high (((dest :imm)) + ((src :imm) + (high :u16const))) + (oris dest src high)) + +(define-ppc64-vinsn logior-low (((dest :imm)) + ((src :imm) + (low :u16const))) + (ori dest src low)) + + + +(define-ppc64-vinsn %logior2 (((dest :imm)) + ((x :imm) + (y :imm)) + ()) + (or dest x y)) + +(define-ppc64-vinsn logand-high (((dest :imm)) + ((src :imm) + (high :u16const)) + ((crf0 (:crf 0)))) + (andis. dest src high)) + +(define-ppc64-vinsn logand-low (((dest :imm)) + ((src :imm) + (low :u16const)) + ((crf0 (:crf 0)))) + (andi. dest src low)) + + +(define-ppc64-vinsn %logand2 (((dest :imm)) + ((x :imm) + (y :imm)) + ()) + (and dest x y)) + +(define-ppc64-vinsn clear-left (((dest :imm)) + ((src :imm) + (nbits :s8const))) + (rldicl dest src 0 (:apply 1+ nbits))) + +(define-ppc64-vinsn clear-right (((dest :imm)) + ((src :imm) + (nbits :s8const))) + (rldicr dest src 0 (:apply - 63 nbits))) + +(define-ppc64-vinsn logxor-high (((dest :imm)) + ((src :imm) + (high :u16const))) + (xoris dest src high)) + +(define-ppc64-vinsn logxor-low (((dest :imm)) + ((src :imm) + (low :u16const))) + (xori dest src low)) + + + +(define-ppc64-vinsn %logxor2 (((dest :imm)) + ((x :imm) + (y :imm)) + ()) + (xor dest x y)) + +(define-ppc64-vinsn %ilsl (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :u32) + (crx :crf))) + (cmpdi crx count (ash 63 ppc64::fixnumshift)) + (srdi temp count ppc64::fixnumshift) + (sld dest src temp) + (ble+ crx :foo) + (li dest 0) + :foo) + +(define-ppc64-vinsn %ilsl-c (((dest :imm)) + ((count :u8const) + (src :imm))) + ;; Hard to use ppcmacroinstructions that expand into expressions + ;; involving variables. + (rldicr dest src count (:apply - ppc64::least-significant-bit count))) + + +(define-ppc64-vinsn %ilsr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s64))) + (rldicl temp src (:apply - 64 count) count) + (rldicr dest temp 0 (- 63 ppc64::fixnumshift))) + + + +;;; 68k did the right thing for counts < 64 - fixnumshift but not if greater +;;; so load-byte fails in 3.0 also + + +(define-ppc64-vinsn %iasr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s32) + (crx :crf))) + (cmpdi crx count (ash 63 ppc64::fixnumshift)) + (sradi temp count ppc64::fixnumshift) + (srad temp src temp) + (ble+ crx :foo) + (sradi temp src 63) + :foo + (rldicr dest temp 0 (- 63 ppc64::fixnumshift))) + +(define-ppc64-vinsn %iasr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s32))) + (sradi temp src count) + (rldicr dest temp 0 (- 63 ppc64::fixnumshift))) + +(define-ppc64-vinsn %ilsr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s32) + (crx :crf))) + (cmpdi crx count (ash 63 ppc64::fixnumshift)) + (srdi temp count ppc64::fixnumshift) + (srd temp src temp) + (rldicr dest temp 0 (- 63 ppc64::fixnumshift)) + (ble+ crx :foo) + (li dest 0) + :foo + ) + +(define-ppc64-vinsn natural-shift-left (((dest :u64)) + ((src :u64) + (count :u8const))) + (rldicr dest src count (:apply - 63 count))) + +(define-ppc64-vinsn natural-shift-right (((dest :u64)) + ((src :u64) + (count :u8const))) + (rldicr dest src (:apply - 64 count) count)) + +(define-ppc64-vinsn sign-extend-halfword (((dest :imm)) + ((src :imm))) + (sldi dest src (- 48 ppc64::fixnumshift)) + (sradi dest dest (- 48 ppc64::fixnumshift))) + + + +(define-ppc64-vinsn fixnum-add (((dest t)) + ((x t) + (y t))) + (add dest x y)) + + +(define-ppc64-vinsn fixnum-add-overflow-ool (() + ((x :imm) + (y :imm)) + ((cr0 (:crf 0)))) + (addo. ppc::arg_z x y) + (bsola- .SPfix-overflow)) + +(define-ppc64-vinsn fixnum-add-overflow-inline (((dest :lisp)) + ((x :imm) + (y :imm)) + ((cr0 (:crf 0)) + (unboxed :s64) + (header :u64))) + (addo. dest x y) + (bns+ cr0 :done) + (mtxer ppc::rzero) + (sradi unboxed dest ppc64::fixnumshift) + (li header ppc64::two-digit-bignum-header) + (rotldi unboxed unboxed 32) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc64::fixnumshift)))) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrdi ppc::allocptr ppc::allocptr ppc64::ntagbits) + (std unboxed ppc64::misc-data-offset dest) + :done) + +(define-ppc64-vinsn fixnum-add-overflow-inline-skip (((dest :lisp)) + ((x :imm) + (y :imm) + (done :label)) + ((cr0 (:crf 0)) + (unboxed :s64) + (header :u64))) + (addo. dest x y) + (bns+ cr0 done) + (mtxer ppc::rzero) + (sradi unboxed dest ppc64::fixnumshift) + (li header ppc64::two-digit-bignum-header) + (rotldi unboxed unboxed 32) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc64::fixnumshift)))) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrdi ppc::allocptr ppc::allocptr ppc64::ntagbits) + (std unboxed ppc64::misc-data-offset dest) + (b done)) + + + + +;;; (setq dest (- x y)) +(define-ppc64-vinsn fixnum-sub (((dest t)) + ((x t) + (y t))) + (subf dest y x)) + +(define-ppc64-vinsn fixnum-sub-from-constant (((dest :imm)) + ((x :s16const) + (y :imm))) + (subfic dest y (:apply ash x ppc64::fixnumshift))) + + + + +(define-ppc64-vinsn fixnum-sub-overflow-ool (() + ((x :imm) + (y :imm))) + (subo. ppc::arg_z x y) + (bsola- .SPfix-overflow)) + +(define-ppc64-vinsn fixnum-sub-overflow-inline (((dest :lisp)) + ((x :imm) + (y :imm)) + ((cr0 (:crf 0)) + (unboxed :s64) + (header :u64))) + (subo. dest x y) + (bns+ cr0 :done) + (mtxer ppc::rzero) + (sradi unboxed dest ppc64::fixnumshift) + (li header ppc64::two-digit-bignum-header) + (rotldi unboxed unboxed 32) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc64::fixnumshift)))) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrdi ppc::allocptr ppc::allocptr ppc64::ntagbits) + (std unboxed ppc64::misc-data-offset dest) + :done) + +(define-ppc64-vinsn fixnum-sub-overflow-inline-skip (((dest :lisp)) + ((x :imm) + (y :imm) + (done :label)) + ((cr0 (:crf 0)) + (unboxed :s64) + (header :u64))) + (subo. dest x y) + (bns+ cr0 done) + (mtxer ppc::rzero) + (sradi unboxed dest ppc64::fixnumshift) + (li header ppc64::two-digit-bignum-header) + (rotldi unboxed unboxed 32) + (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 ppc64::fixnumshift)))) + (la ppc::allocptr (- ppc64::fulltag-misc 16) ppc::allocptr) + (tdlt ppc::allocptr ppc::allocbase) + (std header ppc64::misc-header-offset ppc::allocptr) + (mr dest ppc::allocptr) + (clrrdi ppc::allocptr ppc::allocptr ppc64::ntagbits) + (std unboxed ppc64::misc-data-offset dest) + (b done)) + +;;; This is, of course, also "subtract-immediate." +(define-ppc64-vinsn add-immediate (((dest t)) + ((src t) + (upper :u32const) + (lower :u32const))) + ((:not (:pred = upper 0)) + (addis dest src upper) + ((:not (:pred = lower 0)) + (addi dest dest lower))) + ((:and (:pred = upper 0) (:not (:pred = lower 0))) + (addi dest src lower))) + +;This must unbox one reg, but hard to tell which is better. +;(The one with the smaller absolute value might be) +(define-ppc64-vinsn multiply-fixnums (((dest :imm)) + ((a :imm) + (b :imm)) + ((unboxed :s32))) + (sradi unboxed b ppc64::fixnumshift) + (mulld dest a unboxed)) + +(define-ppc64-vinsn multiply-immediate (((dest :imm)) + ((boxed :imm) + (const :s16const))) + (mulli dest boxed const)) + +;;; Mask out the code field of a base character; the result +;;; should be EXACTLY = to subtag-base-char +(define-ppc64-vinsn mask-base-char (((dest :u32)) + ((src :imm))) + (clrldi dest src (- ppc64::nbits-in-word ppc64::num-subtag-bits))) + +;;; Set dest (of type :s64!) to 0 iff VAL is an istruct of type TYPE +(define-ppc64-vinsn istruct-typep (((dest :s64)) + ((val :lisp) + (type :lisp)) + ((crf :crf) + (temp :lisp))) + (clrldi dest val (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf dest ppc64::fulltag-misc) + (li dest -1) + (bne crf :done) + (lbz dest ppc64::misc-subtag-offset val) + (cmpdi crf dest ppc64::subtag-istruct) + (bne crf :done) + (ld temp ppc64::misc-data-offset val) + (subf dest type temp) + :done) + +;;; Boundp, fboundp stuff. +(define-ppc64-vinsn (ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val))))) + (bla .SPspecrefcheck)) + +(define-ppc64-vinsn ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + (ld idx ppc64::symbol.binding-index src) + (ld table ppc64::tcr.tlb-limit ppc64::rcontext) + (cmpd idx table) + (ld table ppc64::tcr.tlb-pointer ppc64::rcontext) + (bge :symbol) + (ldx dest table idx) + (cmpdi dest ppc64::subtag-no-thread-local-binding) + (bne :done) + :symbol + (ld dest ppc64::symbol.vcell src) + :done + (tdeqi dest ppc64::unbound-marker)) + +(define-ppc64-vinsn (%ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val))))) + (bla .SPspecref)) + +(define-ppc64-vinsn %ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + (ld idx ppc64::symbol.binding-index src) + (ld table ppc64::tcr.tlb-limit ppc64::rcontext) + (cmpd idx table) + (ld table ppc64::tcr.tlb-pointer ppc64::rcontext) + (bge :symbol) + (ldx dest table idx) + (cmpdi dest ppc64::subtag-no-thread-local-binding) + (bne :done) + :symbol + (ld dest ppc64::symbol.vcell src) + :done + ) + +(define-ppc64-vinsn (setq-special :call :subprim-call) + (() + ((sym :lisp) + (val :lisp))) + (bla .SPspecset)) + + +(define-ppc64-vinsn symbol-function (((val :lisp)) + ((sym (:lisp (:ne val)))) + ((crf :crf) + (tag :u32))) + (ld val ppc64::symbol.fcell sym) + (clrldi tag val (- 64 ppc64::ntagbits)) + (cmpdi crf tag ppc64::fulltag-misc) + (bne- crf :bad) + (lbz tag ppc64::misc-subtag-offset val) + (cmpdi crf tag ppc64::subtag-function) + (beq+ crf :good) + :bad + (uuo_interr arch::error-udf sym) + :good) + +(define-ppc64-vinsn (temp-push-unboxed-word :push :word :tsp) + (() + ((w :u64))) + (stdu ppc::tsp -32 ppc::tsp) + (std ppc::tsp 8 ppc::tsp) + (std w 16 ppc::tsp)) + +(define-ppc64-vinsn (temp-pop-unboxed-word :pop :word :tsp) + (((w :u64)) + ()) + (ld w 16 ppc::tsp) + (la ppc::tsp 32 ppc::tsp)) + +(define-ppc64-vinsn (temp-push-double-float :push :doubleword :tsp) + (((d :double-float)) + ()) + (stdu ppc::tsp -32 ppc::tsp) + (std ppc::tsp 8 ppc::tsp) + (stfd d 16 ppc::tsp)) + +(define-ppc64-vinsn (temp-pop-double-float :pop :doubleword :tsp) + (() + ((d :double-float))) + (lfd d 16 ppc::tsp) + (la ppc::tsp 32 ppc::tsp)) + +(define-ppc64-vinsn (temp-push-single-float :push :word :tsp) + (((s :single-float)) + ()) + (stdu ppc::tsp -32 ppc::tsp) + (std ppc::tsp 8 ppc::tsp) + (stfs s 16 ppc::tsp)) + +(define-ppc64-vinsn (temp-pop-single-float :pop :word :tsp) + (() + ((s :single-float))) + (lfs s 16 ppc::tsp) + (la ppc::tsp 32 ppc::tsp)) + + +(define-ppc64-vinsn (save-nvrs-individually :push :node :vsp :multiple) + (() + ((first :u8const))) + (stdu ppc::save0 -8 ppc::vsp) + ((:pred <= first ppc::save1) + (stdu ppc::save1 -8 ppc::vsp) + ((:pred <= first ppc::save2) + (stdu ppc::save2 -8 ppc::vsp) + ((:pred <= first ppc::save3) + (stdu ppc::save3 -8 ppc::vsp) + ((:pred <= first ppc::save4) + (stdu ppc::save4 -8 ppc::vsp) + ((:pred <= first ppc::save5) + (stdu ppc::save5 -8 ppc::vsp) + ((:pred <= first ppc::save6) + (stdu ppc::save6 -8 ppc::vsp) + ((:pred = first ppc::save7) + (stdu ppc::save7 -8 ppc::vsp))))))))) + +(define-ppc64-vinsn (save-nvrs :push :node :vsp :multiple) + (() + ((first :u8const))) + ;; There's no "stmd" instruction. + (stdu ppc::save0 -8 ppc::vsp) + ((:pred <= first ppc::save1) + (stdu ppc::save1 -8 ppc::vsp) + ((:pred <= first ppc::save2) + (stdu ppc::save2 -8 ppc::vsp) + ((:pred <= first ppc::save3) + (stdu ppc::save3 -8 ppc::vsp) + ((:pred <= first ppc::save4) + (stdu ppc::save4 -8 ppc::vsp) + ((:pred <= first ppc::save5) + (stdu ppc::save5 -8 ppc::vsp) + ((:pred <= first ppc::save6) + (stdu ppc::save6 -8 ppc::vsp) + ((:pred = first ppc::save7) + (stdu ppc::save7 -8 ppc::vsp))))))))) + + +(define-ppc64-vinsn (restore-nvrs :pop :node :vsp :multiple) + (() + ((firstreg :u8const) + (basereg :imm) + (offset :s16const))) + ((:pred = firstreg ppc::save7) + (ld ppc::save7 offset basereg) + (ld ppc::save6 (:apply + offset 8) basereg) + (ld ppc::save5 (:apply + offset 16) basereg) + (ld ppc::save4 (:apply + offset 24) basereg) + (ld ppc::save3 (:apply + offset 32) basereg) + (ld ppc::save2 (:apply + offset 40) basereg) + (ld ppc::save1 (:apply + offset 48) basereg) + (ld ppc::save0 (:apply + offset 56) basereg)) + ((:pred = firstreg ppc::save6) + (ld ppc::save6 offset basereg) + (ld ppc::save5 (:apply + offset 8) basereg) + (ld ppc::save4 (:apply + offset 16) basereg) + (ld ppc::save3 (:apply + offset 24) basereg) + (ld ppc::save2 (:apply + offset 32) basereg) + (ld ppc::save1 (:apply + offset 40) basereg) + (ld ppc::save0 (:apply + offset 48) basereg)) + ((:pred = firstreg ppc::save5) + (ld ppc::save5 offset basereg) + (ld ppc::save4 (:apply + offset 8) basereg) + (ld ppc::save3 (:apply + offset 16) basereg) + (ld ppc::save2 (:apply + offset 24) basereg) + (ld ppc::save1 (:apply + offset 32) basereg) + (ld ppc::save0 (:apply + offset 40) basereg)) + ((:pred = firstreg ppc::save4) + (ld ppc::save4 offset basereg) + (ld ppc::save3 (:apply + offset 8) basereg) + (ld ppc::save2 (:apply + offset 16) basereg) + (ld ppc::save1 (:apply + offset 24) basereg) + (ld ppc::save0 (:apply + offset 32) basereg)) + ((:pred = firstreg ppc::save3) + (ld ppc::save3 offset basereg) + (ld ppc::save2 (:apply + offset 8) basereg) + (ld ppc::save1 (:apply + offset 16) basereg) + (ld ppc::save0 (:apply + offset 24) basereg)) + ((:pred = firstreg ppc::save2) + (ld ppc::save2 offset basereg) + (ld ppc::save1 (:apply + offset 8) basereg) + (ld ppc::save0 (:apply + offset 16) basereg)) + ((:pred = firstreg ppc::save1) + (ld ppc::save1 offset basereg) + (ld ppc::save0 (:apply + offset 8) basereg)) + ((:pred = firstreg ppc::save0) + (ld ppc::save0 offset basereg))) + +(define-ppc64-vinsn %current-frame-ptr (((dest :imm)) + ()) + (mr dest ppc::sp)) + +(define-ppc64-vinsn %current-tcr (((dest :imm)) + ()) + (mr dest ppc64::rcontext)) + +(define-ppc64-vinsn (dpayback :call :subprim-call) (() + ((n :s16const)) + ((temp (:u32 #.ppc::imm0)))) + ((:pred > n 1) + (li temp n) + (bla .SPunbind-n)) + ((:pred = n 1) + (bla .SPunbind))) + +(define-ppc64-vinsn zero-double-float-register + (((dest :double-float)) + ()) + (fmr dest ppc::fp-zero)) + +(define-ppc64-vinsn zero-single-float-register + (((dest :single-float)) + ()) + (fmr dest ppc::fp-zero)) + +(define-ppc64-vinsn load-double-float-constant + (((dest :double-float)) + ((high :u32) + (low :u32))) + (stw high -8 ppc::sp) + (stw low -4 ppc::sp) + (lfd dest -8 ppc::sp)) + +(define-ppc64-vinsn load-single-float-constant + (((dest :single-float)) + ((src t))) + (stw src -4 ppc::sp) + (lfs dest -4 ppc::sp)) + +(define-ppc64-vinsn load-indexed-node (((node :lisp)) + ((base :lisp) + (offset :s16const))) + (ld node offset base)) + +(define-ppc64-vinsn recover-saved-vsp (((dest :imm)) + ()) + (ld dest ppc64::lisp-frame.savevsp ppc::sp)) + + +(define-ppc64-vinsn check-exact-nargs (() + ((n :u16const))) + (tdnei ppc::nargs (:apply ash n ppc64::word-shift))) + +(define-ppc64-vinsn check-min-nargs (() + ((min :u16const))) + (tdllti ppc::nargs (:apply ash min ppc64::word-shift))) + +(define-ppc64-vinsn check-max-nargs (() + ((max :u16const))) + (tdlgti ppc::nargs (:apply ash max ppc64::word-shift))) + +;;; Save context and establish FN. The current VSP is the the +;;; same as the caller's, e.g., no arguments were vpushed. +(define-ppc64-vinsn save-lisp-context-vsp (() + () + ((imm :u64))) + (stdu ppc::sp (- ppc64::lisp-frame.size) ppc::sp) + (std ppc::fn ppc64::lisp-frame.savefn ppc::sp) + (std ppc::loc-pc ppc64::lisp-frame.savelr ppc::sp) + (std ppc::vsp ppc64::lisp-frame.savevsp ppc::sp) + (mr ppc::fn ppc::nfn) + ;; Do a stack-probe ... + (ld imm ppc64::tcr.cs-limit ppc64::rcontext) + (tdllt ppc::sp imm)) + +;;; Do the same thing via a subprim call. +(define-ppc64-vinsn (save-lisp-context-vsp-ool :call :subprim-call) + (() + () + ((imm (:u64 #.ppc::imm0)))) + (bla .SPsavecontextvsp)) + +(define-ppc64-vinsn save-lisp-context-offset (() + ((nbytes-vpushed :u16const)) + ((imm :u64))) + (la imm nbytes-vpushed ppc::vsp) + (stdu ppc::sp (- ppc64::lisp-frame.size) ppc::sp) + (std ppc::fn ppc64::lisp-frame.savefn ppc::sp) + (std ppc::loc-pc ppc64::lisp-frame.savelr ppc::sp) + (std imm ppc64::lisp-frame.savevsp ppc::sp) + (mr ppc::fn ppc::nfn) + ;; Do a stack-probe ... + (ld imm ppc64::tcr.cs-limit ppc64::rcontext) + (tdllt ppc::sp imm)) + +(define-ppc64-vinsn save-lisp-context-offset-ool (() + ((nbytes-vpushed :u16const)) + ((imm (:u64 #.ppc::imm0)))) + (li imm nbytes-vpushed) + (bla .SPsavecontext0)) + + +(define-ppc64-vinsn save-lisp-context-lexpr (() + () + ((imm :u64))) + (stdu ppc::sp (- ppc64::lisp-frame.size) ppc::sp) + (std ppc::rzero ppc64::lisp-frame.savefn ppc::sp) + (std ppc::loc-pc ppc64::lisp-frame.savelr ppc::sp) + (std ppc::vsp ppc64::lisp-frame.savevsp ppc::sp) + (mr ppc::fn ppc::nfn) + ;; Do a stack-probe ... + (ld imm ppc64::tcr.cs-limit ppc64::rcontext) + (tdllt ppc::sp imm)) + +(define-ppc64-vinsn save-cleanup-context (() + ()) + ;; SP was this deep just a second ago, so no need to do a stack-probe. + (mflr ppc::loc-pc) + (stdu ppc::sp (- ppc64::lisp-frame.size) ppc::sp) + (std ppc::rzero ppc64::lisp-frame.savefn ppc::sp) + (std ppc::loc-pc ppc64::lisp-frame.savelr ppc::sp) + (std ppc::vsp ppc64::lisp-frame.savevsp ppc::sp)) + +;;; Vpush the argument registers. We got at least "min-fixed" args; +;;; that knowledge may help us generate better code. +(define-ppc64-vinsn (save-lexpr-argregs :call :subprim-call) + (() + ((min-fixed :u16const)) + ((crfx :crf) + (crfy :crf) + (entry-vsp (:u64 #.ppc::imm0)) + (arg-temp :u64))) + ((:pred >= min-fixed $numppcargregs) + (stdu ppc::arg_x -8 ppc::vsp) + (stdu ppc::arg_y -8 ppc::vsp) + (stdu ppc::arg_z -8 ppc::vsp)) + ((:pred = min-fixed 2) ; at least 2 args + (cmpldi crfx ppc::nargs (ash 2 ppc64::word-shift)) + (beq crfx :yz2) ; skip arg_x if exactly 2 + (stdu ppc::arg_x -8 ppc::vsp) + :yz2 + (stdu ppc::arg_y -8 ppc::vsp) + (stdu ppc::arg_z -8 ppc::vsp)) + ((:pred = min-fixed 1) ; at least one arg + (cmpldi crfx ppc::nargs (ash 2 ppc64::word-shift)) + (blt crfx :z1) ; branch if exactly one + (beq crfx :yz1) ; branch if exactly two + (stdu ppc::arg_x -8 ppc::vsp) + :yz1 + (stdu ppc::arg_y -8 ppc::vsp) + :z1 + (stdu ppc::arg_z -8 ppc::vsp)) + ((:pred = min-fixed 0) + (cmpldi crfx ppc::nargs (ash 2 ppc64::word-shift)) + (cmpldi crfy ppc::nargs 0) + (beq crfx :yz0) ; exactly two + (beq crfy :none) ; exactly zero + (blt crfx :z0) ; one + ; Three or more ... + (stdu ppc::arg_x -8 ppc::vsp) + :yz0 + (stdu ppc::arg_y -8 ppc::vsp) + :z0 + (stdu ppc::arg_z -8 ppc::vsp) + :none + ) + ((:pred = min-fixed 0) + (stdu ppc::nargs -8 ppc::vsp)) + ((:not (:pred = min-fixed 0)) + (subi arg-temp ppc::nargs (:apply ash min-fixed ppc64::word-shift)) + (stdu arg-temp -8 ppc::vsp)) + (add entry-vsp ppc::vsp ppc::nargs) + (la entry-vsp 8 entry-vsp) + (bla .SPlexpr-entry)) + + +(define-ppc64-vinsn (jump-return-pc :jumpLR) + (() + ()) + (blr)) + +(define-ppc64-vinsn (restore-full-lisp-context :lispcontext :pop :csp :lrRestore) + (() + ()) + (ld ppc::loc-pc ppc64::lisp-frame.savelr ppc::sp) + (ld ppc::vsp ppc64::lisp-frame.savevsp ppc::sp) + (ld ppc::fn ppc64::lisp-frame.savefn ppc::sp) + (mtlr ppc::loc-pc) + (la ppc::sp ppc64::lisp-frame.size ppc::sp)) + +(define-ppc64-vinsn (restore-full-lisp-context-ool :lispcontext :pop :csp :lrRestore) + (() + ()) + (bla .SPrestorecontext) + (mtlr ppc::loc-pc)) + +(define-ppc64-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR) + (() + ()) + (ba .SPpopj)) + +;;; Exiting from an UNWIND-PROTECT cleanup is similar to +;;; (and a little simpler than) returning from a function. +(define-ppc64-vinsn restore-cleanup-context (() + ()) + (ld ppc::loc-pc ppc64::lisp-frame.savelr ppc::sp) + (mtlr ppc::loc-pc) + (la ppc::sp ppc64::lisp-frame.size ppc::sp)) + + + +(define-ppc64-vinsn default-1-arg (() + ((min :u16const)) + ((crf :crf))) + (cmpldi crf ppc::nargs (:apply ash min ppc64::word-shift)) + (bne crf :done) + ((:pred >= min 3) + (stdu ppc::arg_x -8 ppc::vsp)) + ((:pred >= min 2) + (mr ppc::arg_x ppc::arg_y)) + ((:pred >= min 1) + (mr ppc::arg_y ppc::arg_z)) + (li ppc::arg_z ppc64::nil-value) + :done) + +(define-ppc64-vinsn default-2-args (() + ((min :u16const)) + ((crf :crf))) + (cmpldi crf ppc::nargs (:apply ash (:apply 1+ min) ppc64::word-shift)) + (bgt crf :done) + (beq crf :one) + ;; We got "min" args; arg_y & arg_z default to nil + ((:pred >= min 3) + (stdu ppc::arg_x -8 ppc::vsp)) + ((:pred >= min 2) + (stdu ppc::arg_y -8 ppc::vsp)) + ((:pred >= min 1) + (mr ppc::arg_x ppc::arg_z)) + (li ppc::arg_y ppc64::nil-value) + (b :last) + :one + ;; We got min+1 args: arg_y was supplied, arg_z defaults to nil. + ((:pred >= min 2) + (stdu ppc::arg_x -8 ppc::vsp)) + ((:pred >= min 1) + (mr ppc::arg_x ppc::arg_y)) + (mr ppc::arg_y ppc::arg_z) + :last + (li ppc::arg_z ppc64::nil-value) + :done) + +(define-ppc64-vinsn default-3-args (() + ((min :u16const)) + ((crfx :crf) + (crfy :crf))) + (cmpldi crfx ppc::nargs (:apply ash (:apply + 2 min) ppc64::word-shift)) + (cmpldi crfy ppc::nargs (:apply ash min ppc64::word-shift)) + (bgt crfx :done) + (beq crfx :two) + (beq crfy :none) + ;; The first (of three) &optional args was supplied. + ((:pred >= min 2) + (stdu ppc::arg_x -8 ppc::vsp)) + ((:pred >= min 1) + (stdu ppc::arg_y -8 ppc::vsp)) + (mr ppc::arg_x ppc::arg_z) + (b :last-2) + :two + ;; The first two (of three) &optional args were supplied. + ((:pred >= min 1) + (stdu ppc::arg_x -8 ppc::vsp)) + (mr ppc::arg_x ppc::arg_y) + (mr ppc::arg_y ppc::arg_z) + (b :last-1) + ;; None of the three &optional args was provided. + :none + ((:pred >= min 3) + (stdu ppc::arg_x -8 ppc::vsp)) + ((:pred >= min 2) + (stdu ppc::arg_y -8 ppc::vsp)) + ((:pred >= min 1) + (stdu ppc::arg_z -8 ppc::vsp)) + (li ppc::arg_x ppc64::nil-value) + :last-2 + (li ppc::arg_y ppc64::nil-value) + :last-1 + (li ppc::arg_z ppc64::nil-value) + :done) + +(define-ppc64-vinsn save-lr (() + ()) + (mflr ppc::loc-pc)) + +;;; "n" is the sum of the number of required args + +;;; the number of &optionals. +(define-ppc64-vinsn (default-optionals :call :subprim-call) (() + ((n :u16const))) + (li ppc::imm0 (:apply ash n ppc64::word-shift)) + (bla .SPdefault-optional-args)) + +;;; fname contains a known symbol +(define-ppc64-vinsn (call-known-symbol :call) (((result (:lisp ppc::arg_z))) + ()) + (ld ppc::nfn ppc64::symbol.fcell ppc::fname) + (ld ppc::temp0 ppc64::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctrl)) + +(define-ppc64-vinsn (jump-known-symbol :jumplr) (() + ()) + (ld ppc::nfn ppc64::symbol.fcell ppc::fname) + (ld ppc::temp0 ppc64::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctr)) + +(define-ppc64-vinsn (call-known-function :call) (() + ()) + (ld ppc::temp0 ppc64::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctrl)) + +(define-ppc64-vinsn (jump-known-function :jumplr) (() + ()) + (ld ppc::temp0 ppc64::misc-data-offset ppc::nfn) + (mtctr ppc::temp0) + (bctr)) + +(define-ppc64-vinsn %schar8 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32) + (cr0 (:crf 0)))) + (srdi imm idx ppc64::fixnumshift) + (addi imm imm ppc64::misc-data-offset) + (lbzx imm str imm) + (rldicr imm imm ppc64::charcode-shift (- 63 ppc64::charcode-shift)) + (ori char imm ppc64::subtag-character)) + +(define-ppc64-vinsn %schar32 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32) + (cr0 (:crf 0)))) + (srdi imm idx 1) + (addi imm imm ppc64::misc-data-offset) + (lwzx imm str imm) + (rldicr imm imm ppc64::charcode-shift (- 63 ppc64::charcode-shift)) + (ori char imm ppc64::subtag-character)) + +(define-ppc64-vinsn %set-schar8 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm :u64) + (imm1 :u64) + (cr0 (:crf 0)))) + (srdi imm idx ppc64::fixnumshift) + (addi imm imm ppc64::misc-data-offset) + (srdi imm1 char ppc64::charcode-shift) + (stbx imm1 str imm) + ) + +(define-ppc64-vinsn %set-schar32 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm :u64) + (imm1 :u64) + (cr0 (:crf 0)))) + (srdi imm idx 1) + (addi imm imm ppc64::misc-data-offset) + (srdi imm1 char ppc64::charcode-shift) + (stwx imm1 str imm) + ) + +(define-ppc64-vinsn %set-scharcode8 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u64) + (imm1 :u64) + (cr0 (:crf 0)))) + (srdi imm idx ppc64::fixnumshift) + (addi imm imm ppc64::misc-data-offset) + (srdi imm1 code ppc64::fixnumshift) + (stbx imm1 str imm) + ) + +(define-ppc64-vinsn %set-scharcode32 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u64) + (imm1 :u64) + (cr0 (:crf 0)))) + (srdi imm idx 1) + (addi imm imm ppc64::misc-data-offset) + (srdi imm1 code ppc64::fixnumshift) + (stwx imm1 str imm) + ) + + +(define-ppc64-vinsn %scharcode8 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u64) + (cr0 (:crf 0)))) + (srdi imm idx ppc64::fixnumshift) + (addi imm imm ppc64::misc-data-offset) + (lbzx imm str imm) + (sldi code imm ppc64::fixnumshift)) + +(define-ppc64-vinsn %scharcode32 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u64) + (cr0 (:crf 0)))) + (srdi imm idx 1) + (addi imm imm ppc64::misc-data-offset) + (lwzx imm str imm) + (sldi code imm ppc64::fixnumshift)) + +;;; Clobbers LR +(define-ppc64-vinsn (%debug-trap :call :subprim-call) (() + ()) + (bla .SPbreakpoint) + ) + + +(define-ppc64-vinsn eep.address (((dest t)) + ((src (:lisp (:ne dest ))))) + (ld dest (+ (ash 1 ppc64::word-shift) ppc64::misc-data-offset) src) + (tdeqi dest ppc64::nil-value)) + +(define-ppc64-vinsn %natural+ (((dest :u64)) + ((x :u64) (y :u64))) + (add dest x y)) + +(define-ppc64-vinsn %natural+-c (((dest :u64)) + ((x :u64) (y :u16const))) + (addi dest x y)) + +(define-ppc64-vinsn %natural- (((dest :u64)) + ((x :u64) (y :u64))) + (sub dest x y)) + +(define-ppc64-vinsn %natural--c (((dest :u64)) + ((x :u64) (y :u16const))) + (subi dest x y)) + +(define-ppc64-vinsn %natural-logior (((dest :u64)) + ((x :u64) (y :u64))) + (or dest x y)) + +(define-ppc64-vinsn %natural-logior-c (((dest :u64)) + ((x :u64) (high :u16const) (low :u16const))) + ((:not (:pred = high 0)) + (oris dest x high)) + ((:not (:pred = low 0)) + (ori dest x low))) + +(define-ppc64-vinsn %natural-logxor (((dest :u64)) + ((x :u64) (y :u64))) + (xor dest x y)) + +(define-ppc64-vinsn %natural-logxor-c (((dest :u64)) + ((x :u64) (high :u16const) (low :u16const))) + ((:not (:pred = high 0)) + (xoris dest x high)) + ((:not (:pred = low 0)) + (xori dest x low))) + +(define-ppc64-vinsn %natural-logand (((dest :u64)) + ((x :u64) (y :u64))) + (and dest x y)) + +(define-ppc64-vinsn %natural-logand-high-c (((dest :u64)) + ((x :u64) (high :u16const)) + ((cr0 (:crf 0)))) + (andis. dest x high)) + +(define-ppc64-vinsn %natural-logand-low-c (((dest :u64)) + ((x :u64) (low :u16const)) + ((cr0 (:crf 0)))) + (andi. dest x low)) + +(define-ppc64-vinsn %natural-logand-mask-c (((dest :u32)) + ((x :u32) + (start :u8const) + (end :u8const))) + (rlwinm dest x 0 start end)) + +(define-ppc64-vinsn disable-interrupts (((dest :lisp)) + () + ((temp :imm) + (temp2 :imm))) + (ld temp2 ppc64::tcr.tlb-pointer ppc64::rcontext) + (li temp -8) + (ld dest ppc64::interrupt-level-binding-index temp2) + (std temp ppc64::interrupt-level-binding-index temp2)) + +(define-ppc64-vinsn load-character-constant (((dest :lisp)) + ((code :u32const)) + ()) + (ori dest ppc::rzero (:apply logior (:apply ash (:apply logand #xff code) 8) ppc64::subtag-character)) + ((:not (:pred = 0 (:apply ldb (byte 16 8) code))) + (oris dest dest (:apply ldb (byte 16 8) code)))) + + +(define-ppc64-vinsn %symbol->symptr (((dest :lisp)) + ((src :lisp)) + ((tag :u8) + (crf0 :crf))) + (clrldi tag src (- ppc64::nbits-in-word ppc64::ntagbits)) + (cmpdi crf0 tag ppc64::fulltag-misc) + (bne crf0 :do-trap) + (lbz tag ppc64::misc-subtag-offset src) + :do-trap + (tdnei tag ppc64::subtag-symbol) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (mr dest src))) + + + +;;; Subprim calls. Done this way for the benefit of VINSN-OPTIMIZE. +(defmacro define-ppc64-subprim-call-vinsn ((name &rest other-attrs) spno) + `(define-ppc64-vinsn (,name :call :subprim-call ,@other-attrs) (() ()) + (bla ,spno))) + +(defmacro define-ppc64-subprim-jump-vinsn ((name &rest other-attrs) spno) + `(define-ppc64-vinsn (,name :jumpLR ,@other-attrs) (() ()) + (ba ,spno))) + +(define-ppc64-subprim-jump-vinsn (restore-interrupt-level) .SPrestoreintlevel) + +(define-ppc64-subprim-call-vinsn (save-values) .SPsave-values) + +(define-ppc64-subprim-call-vinsn (recover-values) .SPrecover-values) + +(define-ppc64-subprim-call-vinsn (add-values) .SPadd-values) + +(define-ppc64-subprim-jump-vinsn (jump-known-symbol-ool) .SPjmpsym) + +(define-ppc64-subprim-call-vinsn (call-known-symbol-ool) .SPjmpsym) + +(define-ppc64-subprim-call-vinsn (pass-multiple-values) .SPmvpass) + +(define-ppc64-subprim-call-vinsn (pass-multiple-values-symbol) .SPmvpasssym) + +(define-ppc64-subprim-jump-vinsn (tail-call-sym-gen) .SPtcallsymgen) + +(define-ppc64-subprim-jump-vinsn (tail-call-fn-gen) .SPtcallnfngen) + +(define-ppc64-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide) + +(define-ppc64-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide) + +(define-ppc64-subprim-jump-vinsn (tail-call-sym-vsp) .SPtcallsymvsp) + +(define-ppc64-subprim-jump-vinsn (tail-call-fn-vsp) .SPtcallnfnvsp) + +(define-ppc64-subprim-call-vinsn (funcall) .SPfuncall) + +(define-ppc64-subprim-jump-vinsn (tail-funcall-gen) .SPtfuncallgen) + +(define-ppc64-subprim-jump-vinsn (tail-funcall-slide) .SPtfuncallslide) + +(define-ppc64-subprim-jump-vinsn (tail-funcall-vsp) .SPtfuncallvsp) + +(define-ppc64-subprim-call-vinsn (spread-lexpr) .SPspread-lexpr-z) + +(define-ppc64-subprim-call-vinsn (spread-list) .SPspreadargz) + +(define-ppc64-subprim-call-vinsn (pop-argument-registers) .SPvpopargregs) + +(define-ppc64-subprim-call-vinsn (getxlong) .SPgetXlong) + +(define-ppc64-subprim-call-vinsn (stack-cons-list) .SPstkconslist) + +(define-ppc64-subprim-call-vinsn (list) .SPconslist) + +(define-ppc64-subprim-call-vinsn (stack-cons-list*) .SPstkconslist-star) + +(define-ppc64-subprim-call-vinsn (list*) .SPconslist-star) + +(define-ppc64-subprim-call-vinsn (make-stack-block) .SPmakestackblock) + +(define-ppc64-subprim-call-vinsn (make-stack-block0) .Spmakestackblock0) + +(define-ppc64-subprim-call-vinsn (make-stack-list) .Spmakestacklist) + +(define-ppc64-subprim-call-vinsn (make-stack-vector) .SPmkstackv) + +(define-ppc64-subprim-call-vinsn (make-stack-gvector) .SPstkgvector) + +(define-ppc64-subprim-call-vinsn (stack-misc-alloc) .SPstack-misc-alloc) + +(define-ppc64-subprim-call-vinsn (stack-misc-alloc-init) .SPstack-misc-alloc-init) + +(define-ppc64-subprim-call-vinsn (bind-nil) .SPbind-nil) + +(define-ppc64-subprim-call-vinsn (bind-self) .SPbind-self) + +(define-ppc64-subprim-call-vinsn (bind-self-boundp-check) .SPbind-self-boundp-check) + +(define-ppc64-subprim-call-vinsn (bind) .SPbind) + +(define-ppc64-subprim-jump-vinsn (nvalret :jumpLR) .SPnvalret) + +(define-ppc64-subprim-call-vinsn (nthrowvalues) .SPnthrowvalues) + +(define-ppc64-subprim-call-vinsn (nthrow1value) .SPnthrow1value) + +(define-ppc64-subprim-call-vinsn (slide-values) .SPmvslide) + +(define-ppc64-subprim-call-vinsn (macro-bind) .SPmacro-bind) + +(define-ppc64-subprim-call-vinsn (destructuring-bind-inner) .SPdestructuring-bind-inner) + +(define-ppc64-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind) + +(define-ppc64-subprim-call-vinsn (simple-keywords) .SPsimple-keywords) + +(define-ppc64-subprim-call-vinsn (keyword-args) .SPkeyword-args) + +(define-ppc64-subprim-call-vinsn (keyword-bind) .SPkeyword-bind) + +(define-ppc64-subprim-call-vinsn (stack-rest-arg) .SPstack-rest-arg) + +(define-ppc64-subprim-call-vinsn (req-stack-rest-arg) .SPreq-stack-rest-arg) + +(define-ppc64-subprim-call-vinsn (stack-cons-rest-arg) .SPstack-cons-rest-arg) + +(define-ppc64-subprim-call-vinsn (heap-rest-arg) .SPheap-rest-arg) + +(define-ppc64-subprim-call-vinsn (req-heap-rest-arg) .SPreq-heap-rest-arg) + +(define-ppc64-subprim-call-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg) + +(define-ppc64-subprim-call-vinsn (opt-supplied-p) .SPopt-supplied-p) + +(define-ppc64-subprim-call-vinsn (gvector) .SPgvector) + +(define-ppc64-vinsn (nth-value :call :subprim-call) (((result :lisp)) + ()) + (bla .SPnthvalue)) + +(define-ppc64-subprim-call-vinsn (fitvals) .SPfitvals) + +(define-ppc64-subprim-call-vinsn (misc-alloc) .SPmisc-alloc) + +(define-ppc64-subprim-call-vinsn (misc-alloc-init) .SPmisc-alloc-init) + +(define-ppc64-subprim-call-vinsn (integer-sign) .SPinteger-sign) + +;;; 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-ppc64-vinsn (throw :jump-unknown) (() + ()) + (bla .SPthrow)) + +(define-ppc64-subprim-call-vinsn (mkcatchmv) .SPmkcatchmv) + +(define-ppc64-subprim-call-vinsn (mkcatch1v) .SPmkcatch1v) + +(define-ppc64-subprim-call-vinsn (setqsym) .SPsetqsym) + +(define-ppc64-subprim-call-vinsn (ksignalerr) .SPksignalerr) + +(define-ppc64-subprim-call-vinsn (subtag-misc-ref) .SPsubtag-misc-ref) + +(define-ppc64-subprim-call-vinsn (subtag-misc-set) .SPsubtag-misc-set) + +(define-ppc64-subprim-call-vinsn (mkunwind) .SPmkunwind) +(define-ppc64-subprim-call-vinsn (nmkunwind) .SPnmkunwind) + +(define-ppc64-subprim-call-vinsn (progvsave) .SPprogvsave) + +(define-ppc64-subprim-jump-vinsn (progvrestore) .SPprogvrestore) + +(define-ppc64-subprim-call-vinsn (eabi-syscall) .SPeabi-syscall) + +(define-ppc64-subprim-call-vinsn (misc-ref) .SPmisc-ref) + +(define-ppc64-subprim-call-vinsn (misc-set) .SPmisc-set) + +(define-ppc64-subprim-call-vinsn (gets64) .SPgets64) + +(define-ppc64-subprim-call-vinsn (getu64) .SPgetu64) + +(define-ppc64-subprim-call-vinsn (makeu64) .SPmakeu64) + +(define-ppc64-subprim-call-vinsn (makes64) .SPmakes64) + +(define-ppc64-vinsn (poweropen-syscall :call :subprim-call) (() + ()) + (stw ppc::rzero ppc64::c-frame.crsave ppc::sp) + (bla .SPpoweropen-syscall)) + +(define-ppc64-vinsn (poweropen-syscall-s64 :call :subprim-call) (() + ()) + (std ppc::sp ppc64::c-frame.crsave ppc::sp) + (bla .SPpoweropen-syscall)) + +(define-ppc64-subprim-call-vinsn (eabi-ff-call) .SPeabi-ff-call) + +(define-ppc64-subprim-call-vinsn (poweropen-ff-call) .SPpoweropen-ffcall) + +(define-ppc64-subprim-call-vinsn (poweropen-ff-call-regs) .SPpoweropen-ffcall-return-registers) + +(define-ppc64-subprim-call-vinsn (poweropen-ff-callX) .SPpoweropen-ffcallX) + +(define-ppc64-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0) + +(define-ppc64-vinsn bind-interrupt-level-0-inline (() + () + ((tlb :imm) + (value :imm) + (link :imm) + (temp :imm))) + (ld tlb ppc64::tcr.tlb-pointer ppc64::rcontext) + (ld value ppc64::interrupt-level-binding-index tlb) + (ld link ppc64::tcr.db-link ppc64::rcontext) + (cmpdi value 0) + (li temp ppc64::interrupt-level-binding-index) + (stdu value -8 ppc::vsp) + (stdu temp -8 ppc::vsp) + (stdu link -8 ppc::vsp) + (std ppc::rzero ppc64::interrupt-level-binding-index tlb) + (std ppc::vsp ppc64::tcr.db-link ppc64::rcontext) + (beq+ :done) + (mr ppc::nargs value) + (bgt :do-trap) + (ld ppc::nargs ppc64::tcr.interrupt-pending ppc64::rcontext) + :do-trap + (tdgti ppc::nargs 0) + :done) + +(define-ppc64-subprim-call-vinsn (bind-interrupt-level-m1) .SPbind-interrupt-level-m1) + +(define-ppc64-vinsn bind-interrupt-level-m1-inline (() + () + ((tlb :imm) + (oldvalue :imm) + (link :imm) + (newvalue :imm) + (idx :imm))) + (li newvalue (ash -1 ppc64::fixnumshift)) + (li idx ppc64::interrupt-level-binding-index) + (ld tlb ppc64::tcr.tlb-pointer ppc64::rcontext) + (ld oldvalue ppc64::interrupt-level-binding-index tlb) + (ld link ppc64::tcr.db-link ppc64::rcontext) + (stdu oldvalue -8 ppc::vsp) + (stdu idx -8 ppc::vsp) + (stdu link -8 ppc::vsp) + (std newvalue ppc64::interrupt-level-binding-index tlb) + (std ppc::vsp ppc64::tcr.db-link ppc64::rcontext) + :done) + +(define-ppc64-subprim-call-vinsn (bind-interrupt-level) .SPbind-interrupt-level) + +(define-ppc64-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level) + +(define-ppc64-vinsn unbind-interrupt-level-inline (() + () + ((tlb :imm) + (link :imm) + (value :imm) + (save-nargs :u32) + (crf0 :crf) + (crf1 :crf))) + (ld tlb ppc64::tcr.tlb-pointer ppc64::rcontext) + (ld value ppc64::interrupt-level-binding-index tlb) + (ld link ppc64::tcr.db-link ppc64::rcontext) + (cmpdi crf1 value 0) + (ld value 16 link) + (ld link 0 link) + (cmpdi crf0 value 0) + (std value ppc64::interrupt-level-binding-index tlb) + (std link ppc64::tcr.db-link ppc64::rcontext) + (bge crf1 :done) + (blt crf0 :done) + (mr save-nargs ppc::nargs) + (ld ppc::nargs ppc64::tcr.interrupt-pending ppc64::rcontext) + (tdgti ppc::nargs 0) + (mr ppc::nargs save-nargs) + :done) + +(define-ppc64-vinsn fixnum->fpr (((f :double-float)) + ((fixnum :imm)) + ((imm :s64))) + (srawi imm fixnum ppc64::fixnumshift) + (std imm -8 ppc::sp) + (lfd f -8 ppc::sp) + (fcfid f f)) + +(define-ppc64-vinsn branch-unless-arg-fixnum (() + ((arg :lisp) + (lab :label)) + ((cr0 (:crf 0)) + (tag :u8))) + (clrldi. tag arg (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (bne cr0 lab)) + +(define-ppc64-vinsn branch-unless-both-args-fixnums (() + ((arg0 :lisp) + (arg1 :lisp) + (lab :label)) + ((cr0 (:crf 0)) + (tag :u8))) + (clrldi tag arg0 (- ppc64::nbits-in-word ppc64::nlisptagbits)) + (rldimi. tag arg1 ppc64::nlisptagbits 58) + (bne cr0 lab)) + + + + +;;; In case ppc64::*ppc-opcodes* was changed since this file was compiled. +(queue-fixup + (fixup-vinsn-templates *ppc64-vinsn-templates* ppc::*ppc-opcode-numbers*)) + +(provide "PPC64-VINSNS") Index: /branches/experimentation/later/source/compiler/PPC/ppc-arch.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc-arch.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc-arch.lisp (revision 8058) @@ -0,0 +1,498 @@ +;;;-*- Mode: Lisp; Package: (PPC :use CL) -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage "PPC" + (:use "CL")) + +(require "ARCH") + +(in-package "PPC") +;;; Lisp registers. +(eval-when (:compile-toplevel :execute) + (defmacro defregs (&body regs) + `(progn + (ccl::defenum () ,@regs) + (defparameter *gpr-register-names* ,(coerce (mapcar #'string regs) 'vector)))) + (defmacro deffpregs (&body regs) + `(progn + (ccl::defenum () ,@regs) + (defparameter *fpr-register-names* ,(coerce (mapcar #'string regs) 'vector)))) + (defmacro defvregs (&body regs) + `(progn + (ccl::defenum () ,@regs) + (defparameter *vector-register-names* ,(coerce (mapcar #'string regs) 'vector)) + ))) + +(defregs + rzero ; Always contains 0; not as handy as it sounds. + sp ; The control stack. Aligned on 16-byte boundary. + target-1 ; volatile reg on Darwin, tp or TOC on Linux. + imm0 ; Unboxed, volatile registers. + imm1 + imm2 + imm3 + imm4 + imm5 + allocptr + allocbase + nargs ; Volatile. SHOULDN'T be used for tag extraction. (TWI handler confusion.) + tsp ; Temp-stack pointer. + target-2 + loc-pc ; for return PC only. + vsp ; Value stack pointer; grows towards 0. + fn ; Current function (constants vector). + temp3 ; Boxed, volatile registers. Some + ; may be defined on function entry. + temp2 + temp1 + temp0 + arg_x ; Next-to-next-to-last function arg. + arg_y ; Next-to-last function argument. + arg_z ; Last function argument. + save7 ; Boxed, nonvolatile registers. + save6 + save5 + save4 + save3 + save2 + save1 + save0 + ) + +(deffpregs + fp0 + fp1 + fp2 + fp3 + fp4 + fp5 + fp6 + fp7 + fp8 + fp9 + fp10 + fp11 + fp12 + fp13 + fp14 + fp15 + fp16 + fp17 + fp18 + fp19 + fp20 + fp21 + fp22 + fp23 + fp24 + fp25 + fp26 + fp27 + fp28 + fp29 + fp30 + fp31) + +(defvregs + vr0 ; General temp vector register + vr1 ; Most-significant quadword when word-aligning + vr2 ; Least-significant quadword when word-aligning + vr3 ; Operand A resulting from word-aligning + vr4 ; Operand B resulting from word-aligning + vr5 ; Result from operations on A and B + vr6 + vr7 + vr8 + vr9 + vr10 + vr11 + vr12 + vr13 + vr14 + vr15 + vr16 + vr17 + vr18 + vr19 + ;;By convention, registers after this point are considered non-volatile. Callee should save. + vr20 + vr21 + vr22 + vr23 + vr24 + vr25 + vr26 + vr27 ; Permutation control register A for loads + vr28 ; Permutation control register B for stores + vr29 ; mask register + vr30 ; All zeros + vr31 ; All ones + ) + + + +;;; Calling sequence may pass additional arguments in temp registers. +;;; "nfn" (new function) is always passed; it's the new value of "fn". +(defconstant nfn temp2) + +;;; CLOS may pass the context for, e.g.., CALL-NEXT-METHOD in +;;;; the "next-method-context" register. +(defconstant next-method-context temp1) + + +;;; It's handy to have 0.0 in an fpr. +(defconstant fp-zero fp31) + +; Also handy to have #x4330000080000000 in an fpr, for s32->float conversion. +(defconstant fp-s32conv fp30) + +(defconstant fname temp3) + +;;; Calling sequence may pass additional arguments in temp registers. +;;; "nfn" (new function) is always passed; it's the new value of "fn". +(defconstant nfn temp2) + +;;; CLOS may pass the context for, e.g.., CALL-NEXT-METHOD in +;;;; the "next-method-context" register. +(defconstant next-method-context temp1) + + +;;; It's handy to have 0.0 in an fpr. +(defconstant fp-zero fp31) + +; Also handy to have #x4330000080000000 in an fpr, for s32->float conversion. +(defconstant fp-s32conv fp30) + +(ccl::defenum (:prefix "FPSCR-" :suffix "-BIT") + fx + fex + vx + ox + ux + zx + xx + vxsnan + vxisi + vxidi + vxzdz + vximz + vxvc + fr + fi + fprfc + fl + fg + fe + fu + nil + vxsoft + vxsqrt + vxcvi + ve + oe + ue + ze + xe + ni + rn0 + rn1 +) + +(ccl::defenum (:prefix "PPC-" :suffix "-BIT") + lt + gt + eq + so +) + +;;; 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 *ppc-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. + tcr-lock + 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 + bad-current-ts ; current temp-stack area + bad-cs-overflow-limit ; limit for control-stack overflow check + 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 + doh-head ; creole + 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 + BAD-fpscr-save ; lisp's fpscr when in FFI-land + BAD-fpscr-save-high ; high word of FP reg used to save FPSCR + image-name ; current image name + initial-tcr ; initial thread's context record + )) + +;;; The order here matches "ccl:lisp-kernel;lisp_globals.h" and the nrs record +;;; in "ccl:lisp-kernel;constants.s". +(defparameter *ppc-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 *ppc-nilreg-relative-symbols* *ppc-nil-relative-symbols*) + + + + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defparameter *ppc-subprims-shift* 2) +(defparameter *ppc-subprims-base* (ash 5 12) ) +) + +;;; For now, nothing's nailed down and we don't say anything about +;;; registers clobbered. +;;; These are shared between ppc32 and ppc64. +(let* ((origin *ppc-subprims-base*) + (step (ash 1 *ppc-subprims-shift*))) + (flet ((define-ppc-subprim (name) + (ccl::make-subprimitive-info :name (string name) + :offset (prog1 origin + (incf origin step))))) + (macrolet ((defppcsubprim (name) + `(define-ppc-subprim ',name))) + (defparameter *ppc-subprims* + (vector + (defppcsubprim .SPjmpsym) + (defppcsubprim .SPjmpnfn) + (defppcsubprim .SPfuncall) + (defppcsubprim .SPmkcatch1v) + (defppcsubprim .SPmkunwind) + (defppcsubprim .SPmkcatchmv) + (defppcsubprim .SPthrow) + (defppcsubprim .SPnthrowvalues) + (defppcsubprim .SPnthrow1value) + (defppcsubprim .SPbind) + (defppcsubprim .SPbind-self) + (defppcsubprim .SPbind-nil) + (defppcsubprim .SPbind-self-boundp-check) + (defppcsubprim .SPrplaca) + (defppcsubprim .SPrplacd) + (defppcsubprim .SPconslist) + (defppcsubprim .SPconslist-star) + (defppcsubprim .SPstkconslist) + (defppcsubprim .SPstkconslist-star) + (defppcsubprim .SPmkstackv) + (defppcsubprim .SPsubtag-misc-ref) + (defppcsubprim .SPsetqsym) + (defppcsubprim .SPprogvsave) + (defppcsubprim .SPstack-misc-alloc) + (defppcsubprim .SPgvector) + (defppcsubprim .SPnvalret) + (defppcsubprim .SPmvpass) + (defppcsubprim .SPfitvals) + (defppcsubprim .SPnthvalue) + (defppcsubprim .SPvalues) + (defppcsubprim .SPdefault-optional-args) + (defppcsubprim .SPopt-supplied-p) + (defppcsubprim .SPheap-rest-arg) + (defppcsubprim .SPreq-heap-rest-arg) + (defppcsubprim .SPheap-cons-rest-arg) + (defppcsubprim .SPsimple-keywords) + (defppcsubprim .SPkeyword-args) + (defppcsubprim .SPkeyword-bind) + (defppcsubprim .SPpoweropen-ffcall) + (defppcsubprim .SParef2) + (defppcsubprim .SPksignalerr) + (defppcsubprim .SPstack-rest-arg) + (defppcsubprim .SPreq-stack-rest-arg) + (defppcsubprim .SPstack-cons-rest-arg) + (defppcsubprim .SPpoweropen-callbackX) + (defppcsubprim .SPcall-closure) + (defppcsubprim .SPgetXlong) + (defppcsubprim .SPspreadargz) + (defppcsubprim .SPtfuncallgen) + (defppcsubprim .SPtfuncallslide) + (defppcsubprim .SPtfuncallvsp) + (defppcsubprim .SPtcallsymgen) + (defppcsubprim .SPtcallsymslide) + (defppcsubprim .SPtcallsymvsp) + (defppcsubprim .SPtcallnfngen) + (defppcsubprim .SPtcallnfnslide) + (defppcsubprim .SPtcallnfnvsp) + (defppcsubprim .SPmisc-ref) + (defppcsubprim .SPmisc-set) + (defppcsubprim .SPstkconsyz) + (defppcsubprim .SPstkvcell0) + (defppcsubprim .SPstkvcellvsp) + (defppcsubprim .SPmakestackblock) + (defppcsubprim .SPmakestackblock0) + (defppcsubprim .SPmakestacklist) + (defppcsubprim .SPstkgvector) + (defppcsubprim .SPmisc-alloc) + (defppcsubprim .SPpoweropen-ffcallX) + (defppcsubprim .SPgvset) + (defppcsubprim .SPmacro-bind) + (defppcsubprim .SPdestructuring-bind) + (defppcsubprim .SPdestructuring-bind-inner) + (defppcsubprim .SPrecover-values) + (defppcsubprim .SPvpopargregs) + (defppcsubprim .SPinteger-sign) + (defppcsubprim .SPsubtag-misc-set) + (defppcsubprim .SPspread-lexpr-z) + (defppcsubprim .SPstore-node-conditional) + (defppcsubprim .SPreset) + (defppcsubprim .SPmvslide) + (defppcsubprim .SPsave-values) + (defppcsubprim .SPadd-values) + (defppcsubprim .SPpoweropen-callback) + (defppcsubprim .SPmisc-alloc-init) + (defppcsubprim .SPstack-misc-alloc-init) + (defppcsubprim .SPset-hash-key) + (defppcsubprim .SPaset2) + (defppcsubprim .SPcallbuiltin) + (defppcsubprim .SPcallbuiltin0) + (defppcsubprim .SPcallbuiltin1) + (defppcsubprim .SPcallbuiltin2) + (defppcsubprim .SPcallbuiltin3) + (defppcsubprim .SPpopj) + (defppcsubprim .SPrestorefullcontext) + (defppcsubprim .SPsavecontextvsp) + (defppcsubprim .SPsavecontext0) + (defppcsubprim .SPrestorecontext) + (defppcsubprim .SPlexpr-entry) + (defppcsubprim .SPpoweropen-syscall) + (defppcsubprim .SPbuiltin-plus) + (defppcsubprim .SPbuiltin-minus) + (defppcsubprim .SPbuiltin-times) + (defppcsubprim .SPbuiltin-div) + (defppcsubprim .SPbuiltin-eq) + (defppcsubprim .SPbuiltin-ne) + (defppcsubprim .SPbuiltin-gt) + (defppcsubprim .SPbuiltin-ge) + (defppcsubprim .SPbuiltin-lt) + (defppcsubprim .SPbuiltin-le) + (defppcsubprim .SPbuiltin-eql) + (defppcsubprim .SPbuiltin-length) + (defppcsubprim .SPbuiltin-seqtype) + (defppcsubprim .SPbuiltin-assq) + (defppcsubprim .SPbuiltin-memq) + (defppcsubprim .SPbuiltin-logbitp) + (defppcsubprim .SPbuiltin-logior) + (defppcsubprim .SPbuiltin-logand) + (defppcsubprim .SPbuiltin-ash) + (defppcsubprim .SPbuiltin-negate) + (defppcsubprim .SPbuiltin-logxor) + (defppcsubprim .SPbuiltin-aref1) + (defppcsubprim .SPbuiltin-aset1) + (defppcsubprim .SPbreakpoint) + (defppcsubprim .SPeabi-ff-call) + (defppcsubprim .SPeabi-callback) + (defppcsubprim .SPeabi-syscall) + (defppcsubprim .SPgetu64) + (defppcsubprim .SPgets64) + (defppcsubprim .SPmakeu64) + (defppcsubprim .SPmakes64) + (defppcsubprim .SPspecref) + (defppcsubprim .SPspecset) + (defppcsubprim .SPspecrefcheck) + (defppcsubprim .SPrestoreintlevel) + (defppcsubprim .SPmakes32) + (defppcsubprim .SPmakeu32) + (defppcsubprim .SPgets32) + (defppcsubprim .SPgetu32) + (defppcsubprim .SPfix-overflow) + (defppcsubprim .SPmvpasssym) + (defppcsubprim .SParef3) + (defppcsubprim .SPaset3) + (defppcsubprim .SPpoweropen-ffcall-return-registers) + (defppcsubprim .SPnmkunwind) + (defppcsubprim .SPunused-6) + (defppcsubprim .SPunbind-interrupt-level) + (defppcsubprim .SPunbind) + (defppcsubprim .SPunbind-n) + (defppcsubprim .SPunbind-to) + (defppcsubprim .SPbind-interrupt-level-m1) + (defppcsubprim .SPbind-interrupt-level) + (defppcsubprim .SPbind-interrupt-level-0) + (defppcsubprim .SPprogvrestore) + ))))) + + + +(provide "PPC-ARCH") Index: /branches/experimentation/later/source/compiler/PPC/ppc-asm.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc-asm.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc-asm.lisp (revision 8058) @@ -0,0 +1,2441 @@ +;;;-*- Mode: Lisp; Package: (PPC :use CL) -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 :execute) + (require "PPC-ARCH")) + +(in-package "PPC") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "RISC-LAP") +(ccl::defenum () + $ppc-operand-signed ; This operand takes signed values. + $ppc-operand-signopt ; This operand takes signed or positive values. + $ppc-operand-cr ; This operand uses symbolic names for CR fields + $ppc-operand-gpr ; This operand is a GPR. + $ppc-operand-fpr ; This operand is an FPR. + $ppc-operand-relative ; This operand is a relative branch offset. + $ppc-operand-absolute ; This operand is an absolute address. + $ppc-operand-optional ; This operand is optional, defaulting to 0. + $ppc-operand-next ; A brutal hack to make some rotate instructions work. + $ppc-operand-negative ; This operand should be treated as negative wrt overflow checking. + $ppc-operand-fake ; Used to signify operands whose value is that of another operand. + $ppc-operand-parens ; Operand should be enclosed in parens in traditional as syntax. + $ppc-operand-source ; Operand value is read by the instruction + $ppc-operand-dest ; Operand value is written by the instruction + $ppc-operand-vr ; Operand is an Altivec vector register + ) + +(ccl::defenum () + $ppc ; Opcode is defined for the PowerPC architecture. + $b32 ; Opcode is only defined on 32 bit architectures. + $b64 ; Opcode is only defined on 64 bit architectures. +) + + ;;; A macro to extract the major opcode from an instruction. +(defmacro major-opcode (i) `(ldb (byte 6 26) ,i)) + +;; Operand class indices. +(ccl::defenum () + $unused + $ba ; the BA field in an XL form instruction. + $bat ; The BA field in an XL form instruction when it + ; must be the same as the BT field in the same instruction. + $bb ; The BB field in an XL form instruction. + $bba ; The BB field in an XL form instruction when it must be + ; the same as the BA field in the same instruction. + $bd ; The BD field in a B form instruction. The lower two + ; bits are forced to zero. + $bda ; The BD field in a B form instruction when absolute + ; addressing is used. + $bdm ; The BD field in a B form instruction when the - modifier + ; is used. This sets the y bit of the BO field appropriately. + $bdma ; The BD field in a B form instruction when the - modifier is used + ; and absolute addressing is used. + $bdp ; The BD field in a B form instruction when the + modifier + ; is used. This sets the y bit of the BO field appropriately. + $bdpa ; The BD field in a B form instruction when the + modifier is used + ; and absolute addressing is used. + $bf ; The BF field in an X or XL form instruction. + $obf ; An optional BF field. This is used for comparison instructions, + ; in which an omitted BF field is taken as zero. + $bfa ; The BFA field in an X or XL form instruction. + $bi ; The BI field in a B form or XL form instruction. + $bo ; The BO field in a B form instruction. Certain values are illegal. + $boe ; The BO field in a B form instruction when the + or - modifier is + ; used. This is like the BO field, but it must be even. + $bt ; The BT field in an X or XL form instruction. + $cr ; The condition register number portion of the BI field in a B form + ; or XL form instruction. This is used for the extended + ; conditional branch mnemonics, which set the lower two bits of the + ; BI field. This field is optional. + $d ; The D field in a D form instruction. This is a displacement off + ; a register, and implies that the next operand is a register in + ; parentheses. + $ds ; The DS field in a DS form instruction. This is like D, but the + ; lower two bits are forced to zero. + $flm ; The FLM field in an XFL form instruction. + $fra ; The FRA field in an X or A form instruction. + $frb ; The FRB field in an X or A form instruction. + $frc ; The FRC field in an A form instruction. + $frs ; The FRS field in an X form instruction + $frt ; The FRT field in a D, X or A form instruction. + $fxm ; The FXM field in an XFX instruction. + $l ; The L field in a D or X form instruction. + $li ; The LI field in an I form instruction. The lower two bits are + ; forced to zero. + $lia ; The LI field in an I form instruction when used as an absolute + ; address. + $mb ; The MB field in an M form instruction. + $me ; The ME field in an M form instruction. + $mbe ; The MB and ME fields in an M form instruction expressed a single + ; operand which is a bitmask indicating which bits to select. This + ; is a two operand form using $PPC-OPERAND-NEXT. See the + ; description of $PPC-OPERAND-NEXT. for what this means. + $mbe-aux ; A placeholder for the second MBE operand. + $mb6 ; The MB or ME field in an MD or MDS form instruction. The high + ; bit is wrapped to the low end. + $nb ; The NB field in an X form instruction. The value 32 is stored as 0. + $nsi ; The NSI field in a D form instruction. This is the same as the + ; SI field, only negated. + $ra ; The RA field in an D, DS, X, XO, M, or MDS form instruction. + $ral ; The RA field in a D or X form instruction which is an updating + ; load, which means that the RA field may not be zero and may not + ; equal the RT field. + $ram ; The RA field in an lmw instruction, which has special value + ; restrictions. + $ras ; The RA field in a D or X form instruction which is an updating + ; store or an updating floating point load, which means that the RA + ; field may not be zero. + $rTa ; The RA field in an D, DS, X, XO, M, or MDS form instruction, when + ; used as a destination. + $rb ; The RB field in an X, XO, M, or MDS form instruction. + $rbs ; The RB field in an X form instruction when it must be the same as + ; the RS field in the instruction. This is used for extended + ; mnemonics like mr. + $rs ; The RS field in a D, DS, X, XFX, XS, M, MD or MDS form + ; instruction. + $rt ; The RT field in a D, DS, X, XFX or XO form instruction. + $sh ; The SH field in an X or M form instruction. + $sh6 ; The SH field in an MD form instruction. This is split. + $si ; The SI field in a D form instruction. + $sisignopt ; The SI field in a D form instruction when we accept a wide range + ; of positive values. + $spr ; The SPR or TBR field in an XFX form instruction. This is + ; flipped--the lower 5 bits are stored in the upper 5 and vice- + ; versa. + $sr ; The SR field in an X form instruction. + $to ; The TO field in a D or X form instruction. + $u ; The U field in an X form instruction. + $ui ; The UI field in a D form instruction. + $uuo-code ; UUO extended-operation code. + $uuo-errnum + $uuo-small-errnum + $va ; The vA field in a vector instruction + $vb ; The vB field in a vector instruction + $vc ; the vC field in a vector VA form instruction + $vd ; the vD field in a vector instruction + $vs ; the vS field in a vector instruction + $vsh ; the SH field in a vector instruction + $all/transient ; the all/transient bit in a vector data stream instruction + $strm ; the strm field in a vector data stream instruction + $vsimm ; a 5-bit signed immediate that goes in the vA field + $vuimm ; a 5-bit unsigned immediate that goes in the vA field + $ls ; The LS field in an X (sync) form instruction + + ) + +(defconstant $me6 $mb6) +(defconstant $tbr $spr) + +(defmacro defopmask (name width offset) + `(defconstant ,name (mask-field (byte ,width ,offset) -1))) + +(defopmask $ba-mask 5 16) +(defopmask $bb-mask 5 11) +(defopmask $bi-mask 5 16) +(defopmask $bo-mask 5 21) +(defopmask $fra-mask 5 16) +(defopmask $frb-mask 5 11) +(defopmask $frc-mask 5 6) +(defopmask $mb-mask 5 6) +(defopmask $me-mask 5 1) +(defopmask $mb6-mask 6 5) +(defopmask $ra-mask 5 16) +(defopmask $rb-mask 5 11) +(defopmask $rt-mask 5 21) +(defopmask $sh-mask 5 11) +(defconstant $sh6-mask (logior (mask-field (byte 1 1) -1) (mask-field (byte 5 11) -1))) +(defopmask $spr-mask 10 11) +(defopmask $to-mask 5 21) +(defopmask $uuo-code-mask 7 4) +(defopmask $uuo-interr-mask 10 16) +(defopmask $uuo-small-interr-mask 5 21) +(defopmask $vsimm-mask 5 16) +(defopmask $vuimm-mask 5 16) + +) + + + + +(eval-when (:compile-toplevel :execute) + (defmacro ppc-op (index width offset &optional insert-function extract-function &rest flags) + `(ccl::make-operand :index ,index + :width ,width + :offset ,offset + :insert-function ',insert-function + :extract-function ',extract-function + :flags (logior ,@(mapcar #'(lambda (f) `(ash 1 ,f)) flags))))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defparameter *ppc-operands* + (vector + (ppc-op $unused 0 0) + (ppc-op $ba 5 16 nil nil $ppc-operand-cr) + (ppc-op $bat 5 16 insert-bat extract-bat ccl::operand-fake) + (ppc-op $bb 5 11 nil nil $ppc-operand-cr) + (ppc-op $bba 5 11 insert-bba extract-bba ccl::operand-fake) + (ppc-op $bd 16 0 insert-bd extract-bd $ppc-operand-relative $ppc-operand-signed) + (ppc-op $bda 16 0 insert-bd extract-bd $ppc-operand-absolute $ppc-operand-signed) + (ppc-op $bdm 16 0 insert-bdm extract-bdm $ppc-operand-relative $ppc-operand-signed) + (ppc-op $bdma 16 0 insert-bdm extract-bdm $ppc-operand-absolute $ppc-operand-signed) + (ppc-op $bdp 16 0 insert-bdp extract-bdp $ppc-operand-relative $ppc-operand-signed) + (ppc-op $bdpa 16 0 insert-bdp extract-bdp $ppc-operand-absolute $ppc-operand-signed) + (ppc-op $bf 3 23 insert-bf extract-bf $ppc-operand-cr) + (ppc-op $obf 3 23 insert-bf extract-bf $ppc-operand-cr ccl::operand-optional) + (ppc-op $bfa 3 18 insert-cr extract-cr $ppc-operand-cr) + (ppc-op $bi 5 16 nil nil $ppc-operand-cr) + (ppc-op $bo 5 21 insert-bo extract-bo) + (ppc-op $boe 5 21 insert-boe extract-boe) + (ppc-op $bt 5 21 nil nil $ppc-operand-cr) + (ppc-op $cr 5 16 insert-cr extract-cr $ppc-operand-cr ccl::operand-optional) + (ppc-op $d 16 0 nil nil $ppc-operand-parens $ppc-operand-signed) + (ppc-op $ds 16 0 insert-ds extract-ds $ppc-operand-parens $ppc-operand-signed) + (ppc-op $flm 8 17) + (ppc-op $fra 5 16 nil nil $ppc-operand-fpr $ppc-operand-source) + (ppc-op $frb 5 11 nil nil $ppc-operand-fpr $ppc-operand-source) + (ppc-op $frc 5 6 nil nil $ppc-operand-fpr $ppc-operand-source) + (ppc-op $frs 5 21 nil nil $ppc-operand-fpr $ppc-operand-source) + (ppc-op $frt 5 21 nil nil $ppc-operand-fpr $ppc-operand-dest) + (ppc-op $fxm 8 12) + (ppc-op $l 1 21 nil nil ccl::operand-optional) + (ppc-op $li 26 0 insert-li extract-li $ppc-operand-relative $ppc-operand-signed) + (ppc-op $lia 26 0 insert-li extract-li $ppc-operand-absolute $ppc-operand-signed) + (ppc-op $mb 5 6) + (ppc-op $me 5 1 ) + (ppc-op $mbe 5 6 nil nil ccl::operand-optional $ppc-operand-next) + (ppc-op $mbe-aux 32 0 insert-mbe extract-mbe) + (ppc-op $mb6 6 5 insert-mb6 extract-mb6) + (ppc-op $nb 6 11 insert-nb extract-nb) + (ppc-op $nsi 16 0 insert-nsi extract-nsi $ppc-operand-negative $ppc-operand-signed) + (ppc-op $ra 5 16 nil nil $ppc-operand-gpr $ppc-operand-source) + (ppc-op $ral 5 16 insert-ral nil $ppc-operand-gpr $ppc-operand-source) + (ppc-op $ram 5 16 insert-ram nil $ppc-operand-gpr $ppc-operand-source) + (ppc-op $ras 5 16 insert-ras nil $ppc-operand-gpr $ppc-operand-source) + (ppc-op $rTa 5 16 nil nil $ppc-operand-gpr $ppc-operand-dest) + (ppc-op $rb 5 11 nil nil $ppc-operand-gpr $ppc-operand-source) + (ppc-op $rbs 5 11 insert-rbs extract-rbs ccl::operand-fake) + (ppc-op $rs 5 21 nil nil $ppc-operand-gpr $ppc-operand-source) + (ppc-op $rt 5 21 nil nil $ppc-operand-gpr $ppc-operand-dest) + (ppc-op $sh 5 11) + (ppc-op $sh6 6 1 insert-sh6 extract-sh6) + (ppc-op $si 16 0 nil nil $ppc-operand-signed) + (ppc-op $sisignopt 16 0 nil nil $ppc-operand-signed $ppc-operand-signopt) + (ppc-op $spr 10 11 insert-spr extract-spr) + (ppc-op $sr 4 16) + (ppc-op $to 5 21) + (ppc-op $u 4 12) + (ppc-op $ui 16 0) + (ppc-op $uuo-code 7 4) + (ppc-op $uuo-errnum 10 16) + (ppc-op $uuo-small-errnum 5 21) + (ppc-op $va 5 16 nil nil $ppc-operand-vr $ppc-operand-source) + (ppc-op $vb 5 11 nil nil $ppc-operand-vr $ppc-operand-source) + (ppc-op $vc 5 6 nil nil $ppc-operand-vr $ppc-operand-source) + (ppc-op $vd 5 21 nil nil $ppc-operand-vr $ppc-operand-dest) + (ppc-op $vs 5 21 nil nil $ppc-operand-vr $ppc-operand-source) + (ppc-op $vsh 4 6 nil nil) + (ppc-op $all/transient 1 25 nil nil) + (ppc-op $strm 2 21 nil nil) + (ppc-op $vsimm 5 16 nil nil $ppc-operand-signed) + (ppc-op $vuimm 5 16 nil nil) + (ppc-op $ls 21 2 nil nil ccl::operand-optional) + + )) + + +(eval-when (:load-toplevel :execute) + (dotimes (i (length *ppc-operands*)) + (unless (= i (ccl::operand-index (svref *ppc-operands* i))) + (break "Operand table out-of-synch at ~d : ~s. " i (svref *ppc-operands* i))))) + +) + +(eval-when (:compile-toplevel :execute) +;; The main opcode of an instruction. +(defmacro op (x &optional (base 0)) `(dpb ,x (byte 6 26) ,base)) +(defconstant $op-mask (mask-field (byte 6 26) -1)) + +;; The main opcode combined with a trap code in the TO field +;; of a D form instruction. Used for extended mnemonics for +;; the trap instructions. +(defmacro opto (x to) `(op ,x (dpb ,to (byte 5 21) 0))) +(defconstant $opto-mask (opto -1 -1)) + +;; The main opcode combined with a comparison size bit in the L field +;; of a D form or X form instruction. Used for extended mnemonics for +;; the comparison instructions. +(defmacro opl (x l) `(op ,x (dpb ,l (byte 1 21) 0))) +(defconstant $opl-mask (opl -1 -1)) + +;; An A form instruction. +(defmacro a (op xop rc) `(op ,op (dpb ,xop (byte 5 1) (logand ,rc 1)))) +(defconstant $a-mask (a -1 -1 -1)) + +;; An A-MASK with the FRB field fixed. +(defconstant $afrb-mask (logior $a-mask $frb-mask)) + +;; An A-MASK with the FRC field fixed. +(defconstant $afrc-mask (logior $a-mask $frc-mask)) + +;; An A-MASK with the FRA and FRC fields fixed. +(defconstant $afrafrc-mask (logior $a-mask $fra-mask $frc-mask)) + +;; A B form instruction. +(defmacro b (op aa lk) `(op ,op (dpb ,aa (byte 1 1) (logand ,lk 1)))) +(defconstant $b-mask (b -1 -1 -1)) + +;; A B form instruction setting the BO field. +(defmacro bbo (op bo aa lk) + `(op ,op (dpb ,bo (byte 5 21) (dpb ,aa (byte 1 1) (logand ,lk 1))))) +(defconstant $bbo-mask (bbo -1 -1 -1 -1)) + +;; A BBO-MASK with the y bit of the BO field removed. This permits +;; matching a conditional branch regardless of the setting of the y +;; bit. +(defconstant $y-mask (dpb 1 (byte 1 21) 0)) +(defconstant $bboy-mask (logandc2 $bbo-mask $y-mask)) + +;; A B form instruction setting the BO field and the condition bits of +;; the BI field. +(defmacro bbocb (op bo cb aa lk) + `(op ,op (dpb ,bo (byte 5 21) (dpb ,cb (byte 2 16) (dpb ,aa (byte 1 1) (logand ,lk 1)))))) +(defconstant $bbocb-mask (bbocb -1 -1 -1 -1 -1)) + +;; A BBOCB-MASK with the y bit of the BO field removed. +(defconstant $bboycb-mask (logandc2 $bbocb-mask $y-mask)) + +;; A BBOYCB-MASK in which the BI field is fixed. +(defconstant $bboybi-mask (logior $bboycb-mask $bi-mask)) + +;; The main opcode mask with the RA field clear. +(defconstant $DRA-MASK (logior $op-mask $ra-mask)) + +;; A DS form instruction. +(defmacro dso (op xop) `(op ,op (logand ,xop #x3))) +(defconstant $ds-mask (dso -1 -1)) + +;; An M form instruction. +(defmacro m (op &optional (rc 0)) `(op ,op (logand ,rc 1))) +(defconstant $m-mask (m -1 -1)) + +;; An M form instruction with the ME field specified. +(defmacro mme (op me &optional (rc 0)) `(op ,op (dpb ,me (byte 5 1) (logand ,rc 1)))) + +;; An M-MASK with the MB and ME fields fixed. +(defconstant $mmbme-mask (logior $m-mask $mb-mask $me-mask)) + +;; An M-MASK with the SH and ME fields fixed. +(defconstant $mshme-mask (logior $m-mask $sh-mask $me-mask)) + +;; An MD form instruction. +(defmacro md (op xop &optional (rc 0)) `(op ,op (dpb ,xop (byte 3 2) (logand ,rc 1)))) +(defconstant $md-mask (md -1 -1 -1)) + +;; An MD-MASK with the MB field fixed. +(defconstant $mdmb-mask (logior $md-mask $mb6-mask)) + +;; An MD-MASK with the SH field fixed. +(defconstant $mdsh-mask (logior $md-mask $sh6-mask)) + +;; An MDS form instruction. +(defmacro mds (op xop &optional (rc 0)) `(op ,op (dpb ,xop (byte 4 1) (logand ,rc 1)))) +(defconstant $mds-mask (mds -1 -1 -1)) + +;; An MDS-MASK with the MB field fixed. +(defconstant $mdsmb-mask (logior $mds-mask $mb6-mask)) + +;; An SC form instruction. +(defmacro sc (op sa lk) `(op ,op (dpb ,sa (byte 1 1) (logand ,lk 1)))) +(defconstant $sc-mask (sc -1 -1 -1)) + +;; A UUO is an unimplemented instruction that the exception handler +;; decodes and emulates. The major opcode and low three bits are clear; +;; bit 3 is set. + +(defmacro uuo (xop) `(op 0 (dpb ,xop (byte 7 4) (logior (ash 1 3) ppc32::fulltag-imm)))) +(defconstant $uuo-mask (logior $op-mask (uuo -1))) +(defconstant $uuorb-mask (logior $uuo-mask $rb-mask)) + +;; An X form instruction. +(defmacro x (op xop &optional (base 0)) `(op ,op (dpb ,xop (byte 10 1) ,base))) + +;; An X form instruction with the RC bit specified. +(defmacro xrc (op xop &optional (rc 0)) `(op ,op (dpb ,xop (byte 10 1) (logand ,rc 1)))) + +;; The mask for an X form instruction. +(defconstant $x-mask (xrc -1 -1 -1)) + +;; An X-MASK with the RA field fixed. +(defconstant $xra-mask (logior $x-mask $ra-mask)) + +;; An X-MASK with the RB field fixed. +(defconstant $xrb-mask (logior $x-mask $rb-mask)) + +;; An X-MASK with the RT field fixed. +(defconstant $xrt-mask (logior $x-mask $rt-mask)) + +;; An X-MASK with the RA and RB fields fixed. +(defconstant $xrarb-mask (logior $x-mask $ra-mask $rb-mask)) + +;; An X-MASK with the RT and RA fields fixed. +(defconstant $xrtra-mask (logior $x-mask $rt-mask $ra-mask)) + +;; An X form comparison instruction. +(defmacro xcmpl (op xop l) + `(x ,op ,xop (dpb ,l (byte 1 21) 0))) + +;; The mask for an X form comparison instruction. +(defconstant $xcmp-mask (logior $x-mask (ash 1 22))) + +;; The mask for an X form comparison instruction with the L field +;; fixed. +(defconstant $xcmpl-mask (logior $xcmp-mask (ash 1 21))) + +(defmacro xsync (op xop l) `(x ,op ,xop (dpb ,l (byte 3 21) 0))) +(defconstant $xsync-mask #xff9fffff) + +;; An X form trap instruction with the TO field specified. +(defmacro xto (op xop to) `(x ,op ,xop (dpb ,to (byte 5 21) 0))) +(defconstant $xto-mask (xto -1 -1 -1)) + +;; An XFL form instruction. +(defmacro xfl (op xop &optional (rc 0)) `(op ,op (dpb ,xop (byte 10 1) (logand ,rc 1)))) +(defconstant $xfl-mask (logior (xfl -1 -1 -1) (ash 1 25) (ash 1 16))) + +;; An XL form instruction with the LK field set to 0. +(defmacro xl (op xop &optional (base 0)) `(op ,op (dpb ,xop (byte 10 1) ,base))) + +;; An XL form instruction which uses the LK field. +(defmacro xllk (op xop &optional (lk 0)) `(xl ,op ,xop (logand ,lk 1))) + +;; The mask for an XL form instruction. +(defconstant $xl-mask (xllk -1 -1 -1)) + +;; An XL form instruction which explicitly sets the BO field. +(defmacro xlo (op bo xop &optional (lk 0)) + `(xl ,op ,xop (dpb ,bo (byte 5 21) (logand ,lk 1)))) +(defconstant $xlo-mask (logior $xl-mask $bo-mask)) + +;; An XL form instruction which explicitly sets the y bit of the BO +;; field. +(defmacro xlylk (op xop y &optional (lk 0)) `(xl ,op ,xop (dpb ,y (byte 1 21) (logand ,lk 1)))) +(defconstant $xlylk-mask (logior $xl-mask $y-mask)) + +;; An XL form instruction which sets the BO field and the condition +;; bits of the BI field. +(defmacro xlocb (op bo cb xop &optional (lk 0)) + `(x ,op ,xop (dpb ,bo (byte 5 21) (dpb ,cb (byte 2 16) (logand ,lk 1))))) +(defconstant $xlocb-mask (xlocb -1 -1 -1 -1 -1)) + +;; An XL-MASK or XLYLK-MASK or XLOCB-MASK with the BB field fixed. +(defconstant $xlbb-mask (logior $xl-mask $bb-mask)) +(defconstant $xlybb-mask (logior $xlylk-mask $bb-mask)) +(defconstant $xlbocbbb-mask (logior $xlocb-mask $bb-mask)) + +;; An XL-MASK with the BO and BB fields fixed. +(defconstant $xlbobb-mask (logior $xl-mask $bo-mask $bb-mask)) + +;; An XL-MASK with the BO, BI and BB fields fixed. +(defconstant $xlbobibb-mask (logior $xl-mask $bo-mask $bi-mask $bb-mask)) + +;; An XO form instruction. +(defmacro xo (op xop oe rc) + `(op ,op (dpb ,xop (byte 9 1) (dpb ,oe (byte 1 10) (logand ,rc 1))))) +(defconstant $xo-mask (xo -1 -1 -1 -1)) + +;; An XO-MASK with the RB field fixed. +(defconstant $xorb-mask (logior $xo-mask $rb-mask)) + +;; An XS form instruction. +(defmacro xs (op xop &optional (rc 0)) + `(op ,op (dpb ,xop (byte 9 2) (logand ,rc 1)))) +(defconstant $xs-mask (xs -1 -1 -1)) + +;; An XFX form instruction with the SPR field filled in. +(defmacro xspr (op xop spr) `(x ,op ,xop (dpb ,spr (byte 5 16) (ash (logand ,spr #x3e0) 6)))) +(defconstant $xspr-mask (logior $x-mask $spr-mask)) + +;; A VX form instruction. +(defmacro vx (op xop) `(op ,op (dpb ,xop (byte 11 0) 0))) +(defconstant $vx-mask (vx -1 -1)) + +;; A VXR form instruction. +(defmacro vxr (op xop rc) `(op ,op (dpb ,xop (byte 10 0) (ash (logand ,rc 1) 10)))) +(defconstant $vxr-mask (vxr -1 -1 1)) + +;; A VXA form instruction. +(defmacro vxa (op xop &optional (base 0)) `(op ,op (dpb ,xop (byte 6 0) ,base))) +(defconstant $vxa-mask (vxa -1 -1)) +(defconstant $vash-mask (logior $vxa-mask (ash 1 10))) + + + + + +;; The BO encodings used in extended conditional branch mnemonics. +(defconstant $bodnzf #x0) +(defconstant $bodnzfp #x1) +(defconstant $bodzf #x2) +(defconstant $bodzfp #x3) +(defconstant $bof #x4) +(defconstant $bofp #x5) +(defconstant $bodnzt #x8) +(defconstant $bodnztp #x9) +(defconstant $bodzt #xa) +(defconstant $bodztp #xb) +(defconstant $bot #xc) +(defconstant $botp #xd) +(defconstant $bodnz #x10) +(defconstant $bodnzp #x11) +(defconstant $bodz #x12) +(defconstant $bodzp #x13) +(defconstant $bou #x14) + +;; The BI condition bit encodings used in extended conditional branch +;; mnemonics. +(defconstant $cblt 0) +(defconstant $cbgt 1) +(defconstant $cbeq 2) +(defconstant $cbso 3) + +;; The TO encodings used in extended trap mnemonics. +(defconstant $tolgt #x1) +(defconstant $tollt #x2) +(defconstant $toeq #x4) +(defconstant $tolge #x5) +(defconstant $tolnl #x5) +(defconstant $tolle #x6) +(defconstant $tolng #x6) +(defconstant $togt #x8) +(defconstant $toge #xc) +(defconstant $tonl #xc) +(defconstant $tolt #x10) +(defconstant $tole #x14) +(defconstant $tong #x14) +(defconstant $tone #x18) +(defconstant $tou #x1f) + + +) + + + +(eval-when (:compile-toplevel :execute) +(defun max-operand-count (opnums) + (let* ((max 0)) + (declare (fixnum max)) + (dolist (i opnums max) + (unless + (logbitp ccl::operand-fake (ccl::operand-flags (svref *ppc-operands* i))) + (incf max))))) + +(defun min-operand-count (opnums) + (let* ((min 0)) + (declare (fixnum min)) + (dolist (i opnums min) + (let* ((flags (ccl::operand-flags (svref *ppc-operands* i)))) + (declare (fixnum flags)) + (unless (or (logbitp ccl::operand-fake flags) + (logbitp ccl::operand-optional flags)) + (incf min)))))) + +(defmacro ppc-opcode (name opcode mask (&rest flags) &rest operands) + `(ccl::make-opcode + :name (string ',name) + :opcode ,opcode + :majorop (major-opcode ,opcode) + :mask ,mask + :flags (logior ,@(mapcar #'(lambda (f) `(ash 1 ,f)) flags)) + :min-args (min-operand-count (list ,@operands)) + :max-args (max-operand-count (list ,@operands)) + :operands (mapcar #'(lambda (i) (svref *ppc-operands* i)) (list ,@operands)))) +) + + +; The #.s are a necesary evil here (to keep the function vector size < 32K) in MCL 3.0. + +; If you change this, you need to evaluate (initialize-ppc-opcode-numbers) +(defparameter *ppc-opcodes* + (vector + #.(ppc-opcode uuo_interr (uuo 11) $uuo-mask ($ppc) $uuo-errnum $rb) + #.(ppc-opcode uuo_intcerr (uuo 12) $uuo-mask ($ppc) $uuo-errnum $rb) + #.(ppc-opcode uuo_interr2 (uuo 13) $uuo-mask ($ppc) $uuo-small-errnum $ra $rb) + #.(ppc-opcode uuo_intcerr2 (uuo 14) $uuo-mask ($ppc) $uuo-small-errnum $ra $rb) + ;; We'll clearly need more; add a few "anonymous" ones for now so that + ;; other opcode's opcode numbers stay constant. + #.(ppc-opcode uuo_fpuXbinop (uuo 22) $uuo-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode tdlgti (opto 2 $tolgt) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdllti (opto 2 $tollt) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdeqi (opto 2 $toeq) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdlgei (opto 2 $tolge) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdlnli (opto 2 $tolnl) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdllei (opto 2 $tolle) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdlngi (opto 2 $tolng) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdgti (opto 2 $togt) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdgei (opto 2 $toge) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdnli (opto 2 $tonl) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdlti (opto 2 $tolt) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdlei (opto 2 $tole) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdngi (opto 2 $tong) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdnei (opto 2 $tone) $opto-mask ($ppc $b64) $ra $si) + #.(ppc-opcode tdi (op 2) $op-mask ($ppc $b64) $to $ra $si) + + #.(ppc-opcode twlgti (opto 3 $tolgt) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twllti (opto 3 $tollt) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode tweqi (opto 3 $toeq) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twlgei (opto 3 $tolge) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twlnli (opto 3 $tolnl) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twllei (opto 3 $tolle) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twlngi (opto 3 $tolng) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twgti (opto 3 $togt) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twgei (opto 3 $toge) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twnli (opto 3 $tonl) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twlti (opto 3 $tolt) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twlei (opto 3 $tole) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twngi (opto 3 $tong) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twnei (opto 3 $tone) $opto-mask ($ppc) $ra $si) + #.(ppc-opcode twi (op 3) $op-mask ($ppc) $to $ra $si) + + #.(ppc-opcode mfvscr (vx 4 1540) $vx-mask ($ppc) $vd ) + #.(ppc-opcode mtvscr (vx 4 1604) $vx-mask ($ppc) $vd ) + #.(ppc-opcode vaddcuw (vx 4 384) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vaddfp (vx 4 10) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vaddsbs (vx 4 768) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vaddshs (vx 4 832) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vaddsws (vx 4 896) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vaddubm (vx 4 0) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vaddubs (vx 4 512) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vadduhm (vx 4 64) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vadduhs (vx 4 576) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vadduwm (vx 4 128) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vadduws (vx 4 640) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vand (vx 4 1028) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vandc (vx 4 1092) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vavgsb (vx 4 1282) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vavgsh (vx 4 1346) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vavgsw (vx 4 1410) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vavgub (vx 4 1026) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vavguh (vx 4 1090) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vavguw (vx 4 1154) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcfsx (vx 4 842) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vcfux (vx 4 778) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vcmpbfp (vxr 4 966 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpbfp. (vxr 4 966 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpeqfp (vxr 4 198 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpeqfp. (vxr 4 198 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpequb (vxr 4 6 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpequb. (vxr 4 6 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpequh (vxr 4 70 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpequh. (vxr 4 70 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpequw (vxr 4 134 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpequw. (vxr 4 134 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgefp (vxr 4 454 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgefp. (vxr 4 454 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtfp (vxr 4 710 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtfp. (vxr 4 710 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtsb (vxr 4 774 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtsb. (vxr 4 774 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtsh (vxr 4 838 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtsh. (vxr 4 838 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtsw (vxr 4 902 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtsw. (vxr 4 902 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtub (vxr 4 518 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtub. (vxr 4 518 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtuh (vxr 4 582 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtuh. (vxr 4 582 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtuw (vxr 4 646 0) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vcmpgtuw. (vxr 4 646 1) $vxr-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vctsxs (vx 4 970) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vctuxs (vx 4 906) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vexptefp (vx 4 394) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vlogefp (vx 4 458) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vmaddfp (vxa 4 46) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmaxfp (vx 4 1034) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmaxsb (vx 4 258) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmaxsh (vx 4 322) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmaxsw (vx 4 386) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmaxub (vx 4 2) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmaxuh (vx 4 66) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmaxuw (vx 4 130) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmhaddshs (vxa 4 32) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmhraddshs (vxa 4 33) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vminfp (vx 4 1098) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vminsb (vx 4 770) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vminsh (vx 4 834) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vminsw (vx 4 898) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vminub (vx 4 514) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vminuh (vx 4 578) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vminuw (vx 4 642) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmladduhm (vxa 4 34) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmrghb (vx 4 12) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmrghh (vx 4 76) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmrghw (vx 4 140) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmrglb (vx 4 268) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmrglh (vx 4 332) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmrglw (vx 4 396) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmsummbm (vxa 4 37) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmsumshm (vxa 4 40) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmsumshs (vxa 4 41) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmsumubm (vxa 4 36) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmsumuhm (vxa 4 38) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmsumuhs (vxa 4 39) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vmulesb (vx 4 776) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmulesh (vx 4 840) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmuleub (vx 4 520) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmuleuh (vx 4 584) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmulosb (vx 4 264) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmulosh (vx 4 328) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmuloub (vx 4 8) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vmulouh (vx 4 72) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vnmsubfp (vxa 4 47) $vxa-mask ($ppc) $vd $va $vc $vb ) + #.(ppc-opcode vnor (vx 4 1284) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vor (vx 4 1156) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vperm (vxa 4 43) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vpkpx (vx 4 782) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkshss (vx 4 398) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkshus (vx 4 270) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkswss (vx 4 462) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkswus (vx 4 334) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkuhum (vx 4 14) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkuhus (vx 4 142) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkuwum (vx 4 78) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vpkuwus (vx 4 206) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vrefp (vx 4 266) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vrfim (vx 4 714) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vrfin (vx 4 522) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vrfip (vx 4 650) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vrfiz (vx 4 586) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vrlb (vx 4 4) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vrlh (vx 4 68) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vrlw (vx 4 132) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vrsqrtefp (vx 4 330) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vsel (vxa 4 42) $vxa-mask ($ppc) $vd $va $vb $vc ) + #.(ppc-opcode vsl (vx 4 452) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vslb (vx 4 260) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsldoi (vxa 4 44) $vxa-mask ($ppc) $vd $va $vb $vsh) + #.(ppc-opcode vslh (vx 4 324) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vslo (vx 4 1036) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vslw (vx 4 388) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vspltb (vx 4 524) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vsplth (vx 4 588) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vspltisb (vx 4 780) $vx-mask ($ppc) $vd $vsimm ) + #.(ppc-opcode vspltish (vx 4 844) $vx-mask ($ppc) $vd $vsimm ) + #.(ppc-opcode vspltisw (vx 4 908) $vx-mask ($ppc) $vd $vsimm ) + #.(ppc-opcode vspltw (vx 4 652) $vx-mask ($ppc) $vd $vb $vuimm ) + #.(ppc-opcode vsr (vx 4 708) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsrab (vx 4 772) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsrah (vx 4 836) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsraw (vx 4 900) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsrb (vx 4 516) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsrh (vx 4 580) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsro (vx 4 1100) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsrw (vx 4 644) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubcuw (vx 4 1408) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubfp (vx 4 74) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubsbs (vx 4 1792) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubshs (vx 4 1856) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubsws (vx 4 1920) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsububm (vx 4 1024) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsububs (vx 4 1536) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubuhm (vx 4 1088) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubuhs (vx 4 1600) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubuwm (vx 4 1152) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsubuws (vx 4 1664) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsumsws (vx 4 1928) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsum2sws (vx 4 1672) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsum4sbs (vx 4 1800) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsum4shs (vx 4 1608) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vsum4ubs (vx 4 1544) $vx-mask ($ppc) $vd $va $vb ) + #.(ppc-opcode vupkhpx (vx 4 846) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vupkhsb (vx 4 526) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vupkhsh (vx 4 590) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vupklpx (vx 4 974) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vupklsb (vx 4 654) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vupklsh (vx 4 718) $vx-mask ($ppc) $vd $vb ) + #.(ppc-opcode vxor (vx 4 1220) $vx-mask ($ppc) $vd $va $vb ) + + #.(ppc-opcode mulli (op 7) $op-mask ($ppc) $rt $ra $si) + + #.(ppc-opcode subfic (op 8) $op-mask ($ppc) $rt $ra $si) + + #.(ppc-opcode cmplwi (opl 10 0) $opl-mask ($ppc) $obf $ra $ui) + + #.(ppc-opcode cmpldi (opl 10 1) $opl-mask ($ppc $b64) $obf $ra $ui) + + #.(ppc-opcode cmpli (op 10) $op-mask ($ppc) $bf $l $ra $ui) + + #.(ppc-opcode cmpwi (opl 11 0) $opl-mask ($ppc) $obf $ra $si) + + #.(ppc-opcode cmpdi (opl 11 1) $opl-mask ($ppc $b64) $obf $ra $si) + + #.(ppc-opcode cmpi (op 11) $op-mask ($ppc) $bf $l $ra $si) + + #.(ppc-opcode addic (op 12) $op-mask ($ppc) $rt $ra $si) + #.(ppc-opcode subic (op 12) $op-mask ($ppc) $rt $ra $nsi) + + #.(ppc-opcode addic. (op 13) $op-mask ($ppc) $rt $ra $si) + #.(ppc-opcode subic. (op 13) $op-mask ($ppc) $rt $ra $nsi) + + #.(ppc-opcode li (op 14) $dra-mask ($ppc) $rt $si) + #.(ppc-opcode addi (op 14) $op-mask ($ppc) $rt $ra $si) + #.(ppc-opcode subi (op 14) $op-mask ($ppc) $rt $ra $nsi) + #.(ppc-opcode la (op 14) $op-mask ($ppc) $rt $d $ra) + + #.(ppc-opcode lis (op 15) $dra-mask ($ppc) $rt $sisignopt) + #.(ppc-opcode addis (op 15) $op-mask ($ppc) $rt $ra $sisignopt) + #.(ppc-opcode subis (op 15) $op-mask ($ppc) $rt $ra $nsi) + + #.(ppc-opcode bdnz- (bbo 16 $bodnz 0 0) $bboybi-mask ($ppc) $bdm) + #.(ppc-opcode bdnz+ (bbo 16 $bodnz 0 0) $bboybi-mask ($ppc) $bdp) + #.(ppc-opcode bdnz (bbo 16 $bodnz 0 0) $bboybi-mask ($ppc) $bd) + #.(ppc-opcode bdnzl- (bbo 16 $bodnz 0 1) $bboybi-mask ($ppc) $bdm) + #.(ppc-opcode bdnzl+ (bbo 16 $bodnz 0 1) $bboybi-mask ($ppc) $bdp) + #.(ppc-opcode bdnzl (bbo 16 $bodnz 0 1) $bboybi-mask ($ppc) $bd) + #.(ppc-opcode bdnza- (bbo 16 $bodnz 1 0) $bboybi-mask ($ppc) $bdma) + #.(ppc-opcode bdnza+ (bbo 16 $bodnz 1 0) $bboybi-mask ($ppc) $bdpa) + #.(ppc-opcode bdnza (bbo 16 $bodnz 1 0) $bboybi-mask ($ppc) $bda) + #.(ppc-opcode bdnzla- (bbo 16 $bodnz 1 1) $bboybi-mask ($ppc) $bdma) + #.(ppc-opcode bdnzla+ (bbo 16 $bodnz 1 1) $bboybi-mask ($ppc) $bdpa) + #.(ppc-opcode bdnzla (bbo 16 $bodnz 1 1) $bboybi-mask ($ppc) $bda) + #.(ppc-opcode bdz- (bbo 16 $bodz 0 0) $bboybi-mask ($ppc) $bdm) + #.(ppc-opcode bdz+ (bbo 16 $bodz 0 0) $bboybi-mask ($ppc) $bdp) + #.(ppc-opcode bdz (bbo 16 $bodz 0 0) $bboybi-mask ($ppc) $bd) + #.(ppc-opcode bdzl- (bbo 16 $bodz 0 1) $bboybi-mask ($ppc) $bdm) + #.(ppc-opcode bdzl+ (bbo 16 $bodz 0 1) $bboybi-mask ($ppc) $bdp) + #.(ppc-opcode bdzl (bbo 16 $bodz 0 1) $bboybi-mask ($ppc) $bd) + #.(ppc-opcode bdza- (bbo 16 $bodz 1 0) $bboybi-mask ($ppc) $bdma) + #.(ppc-opcode bdza+ (bbo 16 $bodz 1 0) $bboybi-mask ($ppc) $bdpa) + #.(ppc-opcode bdza (bbo 16 $bodz 1 0) $bboybi-mask ($ppc) $bda) + #.(ppc-opcode bdzla- (bbo 16 $bodz 1 1) $bboybi-mask ($ppc) $bdma) + #.(ppc-opcode bdzla+ (bbo 16 $bodz 1 1) $bboybi-mask ($ppc) $bdpa) + #.(ppc-opcode bdzla (bbo 16 $bodz 1 1) $bboybi-mask ($ppc) $bda) + #.(ppc-opcode blt- (bbocb 16 $bot $cblt 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode blt+ (bbocb 16 $bot $cblt 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode blt (bbocb 16 $bot $cblt 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bltl- (bbocb 16 $bot $cblt 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bltl+ (bbocb 16 $bot $cblt 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bltl (bbocb 16 $bot $cblt 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode blta- (bbocb 16 $bot $cblt 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode blta+ (bbocb 16 $bot $cblt 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode blta (bbocb 16 $bot $cblt 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bltla- (bbocb 16 $bot $cblt 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bltla+ (bbocb 16 $bot $cblt 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bltla (bbocb 16 $bot $cblt 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bgt- (bbocb 16 $bot $cbgt 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bgt+ (bbocb 16 $bot $cbgt 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bgt (bbocb 16 $bot $cbgt 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bgtl- (bbocb 16 $bot $cbgt 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bgtl+ (bbocb 16 $bot $cbgt 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bgtl (bbocb 16 $bot $cbgt 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bgta- (bbocb 16 $bot $cbgt 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bgta+ (bbocb 16 $bot $cbgt 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bgta (bbocb 16 $bot $cbgt 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bgtla- (bbocb 16 $bot $cbgt 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bgtla+ (bbocb 16 $bot $cbgt 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bgtla (bbocb 16 $bot $cbgt 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode beq- (bbocb 16 $bot $cbeq 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode beq+ (bbocb 16 $bot $cbeq 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode beq (bbocb 16 $bot $cbeq 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode beql- (bbocb 16 $bot $cbeq 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode beql+ (bbocb 16 $bot $cbeq 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode beql (bbocb 16 $bot $cbeq 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode beqa- (bbocb 16 $bot $cbeq 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode beqa+ (bbocb 16 $bot $cbeq 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode beqa (bbocb 16 $bot $cbeq 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode beqla- (bbocb 16 $bot $cbeq 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode beqla+ (bbocb 16 $bot $cbeq 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode beqla (bbocb 16 $bot $cbeq 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bso- (bbocb 16 $bot $cbso 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bso+ (bbocb 16 $bot $cbso 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bso (bbocb 16 $bot $cbso 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bsol- (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bsol+ (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bsol (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bsoa- (bbocb 16 $bot $cbso 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bsoa+ (bbocb 16 $bot $cbso 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bsoa (bbocb 16 $bot $cbso 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bsola- (bbocb 16 $bot $cbso 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bsola+ (bbocb 16 $bot $cbso 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bsola (bbocb 16 $bot $cbso 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bun- (bbocb 16 $bot $cbso 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bun+ (bbocb 16 $bot $cbso 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bun (bbocb 16 $bot $cbso 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bunl- (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bunl+ (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bunl (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode buna- (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode buna+ (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode buna (bbocb 16 $bot $cbso 0 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bunla- (bbocb 16 $bot $cbso 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bunla+ (bbocb 16 $bot $cbso 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bunla (bbocb 16 $bot $cbso 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bge- (bbocb 16 $bof $cblt 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bge+ (bbocb 16 $bof $cblt 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bge (bbocb 16 $bof $cblt 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bgel- (bbocb 16 $bof $cblt 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bgel+ (bbocb 16 $bof $cblt 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bgel (bbocb 16 $bof $cblt 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bgea- (bbocb 16 $bof $cblt 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bgea+ (bbocb 16 $bof $cblt 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bgea (bbocb 16 $bof $cblt 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bgela- (bbocb 16 $bof $cblt 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bgela+ (bbocb 16 $bof $cblt 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bgela (bbocb 16 $bof $cblt 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bnl- (bbocb 16 $bof $cblt 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bnl+ (bbocb 16 $bof $cblt 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bnl (bbocb 16 $bof $cblt 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnll- (bbocb 16 $bof $cblt 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bnll+ (bbocb 16 $bof $cblt 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bnll (bbocb 16 $bof $cblt 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnla- (bbocb 16 $bof $cblt 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnla+ (bbocb 16 $bof $cblt 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnla (bbocb 16 $bof $cblt 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bnlla- (bbocb 16 $bof $cblt 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnlla+ (bbocb 16 $bof $cblt 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnlla (bbocb 16 $bof $cblt 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode ble- (bbocb 16 $bof $cbgt 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode ble+ (bbocb 16 $bof $cbgt 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode ble (bbocb 16 $bof $cbgt 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode blel- (bbocb 16 $bof $cbgt 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode blel+ (bbocb 16 $bof $cbgt 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode blel (bbocb 16 $bof $cbgt 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode blea- (bbocb 16 $bof $cbgt 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode blea+ (bbocb 16 $bof $cbgt 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode blea (bbocb 16 $bof $cbgt 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode blela- (bbocb 16 $bof $cbgt 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode blela+ (bbocb 16 $bof $cbgt 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode blela (bbocb 16 $bof $cbgt 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bng- (bbocb 16 $bof $cbgt 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bng+ (bbocb 16 $bof $cbgt 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bng (bbocb 16 $bof $cbgt 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bngl- (bbocb 16 $bof $cbgt 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bngl+ (bbocb 16 $bof $cbgt 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bngl (bbocb 16 $bof $cbgt 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnga- (bbocb 16 $bof $cbgt 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnga+ (bbocb 16 $bof $cbgt 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnga (bbocb 16 $bof $cbgt 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bngla- (bbocb 16 $bof $cbgt 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bngla+ (bbocb 16 $bof $cbgt 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bngla (bbocb 16 $bof $cbgt 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bne- (bbocb 16 $bof $cbeq 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bne+ (bbocb 16 $bof $cbeq 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bne (bbocb 16 $bof $cbeq 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnel- (bbocb 16 $bof $cbeq 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bnel+ (bbocb 16 $bof $cbeq 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bnel (bbocb 16 $bof $cbeq 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnea- (bbocb 16 $bof $cbeq 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnea+ (bbocb 16 $bof $cbeq 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnea (bbocb 16 $bof $cbeq 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bnela- (bbocb 16 $bof $cbeq 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnela+ (bbocb 16 $bof $cbeq 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnela (bbocb 16 $bof $cbeq 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bns- (bbocb 16 $bof $cbso 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bns+ (bbocb 16 $bof $cbso 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bns (bbocb 16 $bof $cbso 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnsl- (bbocb 16 $bof $cbso 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bnsl+ (bbocb 16 $bof $cbso 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bnsl (bbocb 16 $bof $cbso 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnsa- (bbocb 16 $bof $cbso 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnsa+ (bbocb 16 $bof $cbso 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnsa (bbocb 16 $bof $cbso 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bnsla- (bbocb 16 $bof $cbso 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnsla+ (bbocb 16 $bof $cbso 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnsla (bbocb 16 $bof $cbso 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bnu- (bbocb 16 $bof $cbso 0 0) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bnu+ (bbocb 16 $bof $cbso 0 0) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bnu (bbocb 16 $bof $cbso 0 0) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnul- (bbocb 16 $bof $cbso 0 1) $bboycb-mask ($ppc) $cr $bdm) + #.(ppc-opcode bnul+ (bbocb 16 $bof $cbso 0 1) $bboycb-mask ($ppc) $cr $bdp) + #.(ppc-opcode bnul (bbocb 16 $bof $cbso 0 1) $bboycb-mask ($ppc) $cr $bd) + #.(ppc-opcode bnua- (bbocb 16 $bof $cbso 1 0) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnua+ (bbocb 16 $bof $cbso 1 0) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnua (bbocb 16 $bof $cbso 1 0) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bnula- (bbocb 16 $bof $cbso 1 1) $bboycb-mask ($ppc) $cr $bdma) + #.(ppc-opcode bnula+ (bbocb 16 $bof $cbso 1 1) $bboycb-mask ($ppc) $cr $bdpa) + #.(ppc-opcode bnula (bbocb 16 $bof $cbso 1 1) $bboycb-mask ($ppc) $cr $bda) + #.(ppc-opcode bdnzt- (bbo 16 $bodnzt 0 0) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdnzt+ (bbo 16 $bodnzt 0 0) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdnzt (bbo 16 $bodnzt 0 0) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdnztl- (bbo 16 $bodnzt 0 1) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdnztl+ (bbo 16 $bodnzt 0 1) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdnztl (bbo 16 $bodnzt 0 1) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdnzta- (bbo 16 $bodnzt 1 0) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdnzta+ (bbo 16 $bodnzt 1 0) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdnzta (bbo 16 $bodnzt 1 0) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdnztla- (bbo 16 $bodnzt 1 1) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdnztla+ (bbo 16 $bodnzt 1 1) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdnztla (bbo 16 $bodnzt 1 1) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdnzf- (bbo 16 $bodnzf 0 0) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdnzf+ (bbo 16 $bodnzf 0 0) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdnzf (bbo 16 $bodnzf 0 0) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdnzfl- (bbo 16 $bodnzf 0 1) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdnzfl+ (bbo 16 $bodnzf 0 1) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdnzfl (bbo 16 $bodnzf 0 1) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdnzfa- (bbo 16 $bodnzf 1 0) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdnzfa+ (bbo 16 $bodnzf 1 0) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdnzfa (bbo 16 $bodnzf 1 0) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdnzfla- (bbo 16 $bodnzf 1 1) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdnzfla+ (bbo 16 $bodnzf 1 1) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdnzfla (bbo 16 $bodnzf 1 1) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bt- (bbo 16 $bot 0 0) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bt+ (bbo 16 $bot 0 0) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bt (bbo 16 $bot 0 0) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode btl- (bbo 16 $bot 0 1) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode btl+ (bbo 16 $bot 0 1) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode btl (bbo 16 $bot 0 1) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bta- (bbo 16 $bot 1 0) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bta+ (bbo 16 $bot 1 0) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bta (bbo 16 $bot 1 0) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode btla- (bbo 16 $bot 1 1) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode btla+ (bbo 16 $bot 1 1) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode btla (bbo 16 $bot 1 1) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bf- (bbo 16 $bof 0 0) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bf+ (bbo 16 $bof 0 0) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bf (bbo 16 $bof 0 0) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bfl- (bbo 16 $bof 0 1) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bfl+ (bbo 16 $bof 0 1) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bfl (bbo 16 $bof 0 1) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bfa- (bbo 16 $bof 1 0) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bfa+ (bbo 16 $bof 1 0) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bfa (bbo 16 $bof 1 0) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bfla- (bbo 16 $bof 1 1) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bfla+ (bbo 16 $bof 1 1) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bfla (bbo 16 $bof 1 1) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdzt- (bbo 16 $bodzt 0 0) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdzt+ (bbo 16 $bodzt 0 0) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdzt (bbo 16 $bodzt 0 0) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdztl- (bbo 16 $bodzt 0 1) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdztl+ (bbo 16 $bodzt 0 1) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdztl (bbo 16 $bodzt 0 1) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdzta- (bbo 16 $bodzt 1 0) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdzta+ (bbo 16 $bodzt 1 0) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdzta (bbo 16 $bodzt 1 0) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdztla- (bbo 16 $bodzt 1 1) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdztla+ (bbo 16 $bodzt 1 1) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdztla (bbo 16 $bodzt 1 1) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdzf- (bbo 16 $bodzf 0 0) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdzf+ (bbo 16 $bodzf 0 0) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdzf (bbo 16 $bodzf 0 0) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdzfl- (bbo 16 $bodzf 0 1) $bboy-mask ($ppc) $bi $bdm) + #.(ppc-opcode bdzfl+ (bbo 16 $bodzf 0 1) $bboy-mask ($ppc) $bi $bdp) + #.(ppc-opcode bdzfl (bbo 16 $bodzf 0 1) $bboy-mask ($ppc) $bi $bd) + #.(ppc-opcode bdzfa- (bbo 16 $bodzf 1 0) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdzfa+ (bbo 16 $bodzf 1 0) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdzfa (bbo 16 $bodzf 1 0) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bdzfla- (bbo 16 $bodzf 1 1) $bboy-mask ($ppc) $bi $bdma) + #.(ppc-opcode bdzfla+ (bbo 16 $bodzf 1 1) $bboy-mask ($ppc) $bi $bdpa) + #.(ppc-opcode bdzfla (bbo 16 $bodzf 1 1) $bboy-mask ($ppc) $bi $bda) + #.(ppc-opcode bc- (b 16 0 0) $b-mask ($ppc) $boe $bi $bdm) + #.(ppc-opcode bc+ (b 16 0 0) $b-mask ($ppc) $boe $bi $bdp) + #.(ppc-opcode bc (b 16 0 0) $b-mask ($ppc) $bo $bi $bd) + #.(ppc-opcode bcl- (b 16 0 1) $b-mask ($ppc) $boe $bi $bdm) + #.(ppc-opcode bcl+ (b 16 0 1) $b-mask ($ppc) $boe $bi $bdp) + #.(ppc-opcode bcl (b 16 0 1) $b-mask ($ppc) $bo $bi $bd) + #.(ppc-opcode bca- (b 16 1 0) $b-mask ($ppc) $boe $bi $bdma) + #.(ppc-opcode bca+ (b 16 1 0) $b-mask ($ppc) $boe $bi $bdpa) + #.(ppc-opcode bca (b 16 1 0) $b-mask ($ppc) $bo $bi $bda) + #.(ppc-opcode bcla- (b 16 1 1) $b-mask ($ppc) $boe $bi $bdma) + #.(ppc-opcode bcla+ (b 16 1 1) $b-mask ($ppc) $boe $bi $bdpa) + #.(ppc-opcode bcla (b 16 1 1) $b-mask ($ppc) $bo $bi $bda) + + #.(ppc-opcode sc (sc 17 1 0) #xffffffff ($ppc)) + + #.(ppc-opcode b (b 18 0 0) $b-mask ($ppc) $li) + #.(ppc-opcode bl (b 18 0 1) $b-mask ($ppc) $li) + #.(ppc-opcode ba (b 18 1 0) $b-mask ($ppc) $lia) + #.(ppc-opcode bla (b 18 1 1) $b-mask ($ppc) $lia) + + #.(ppc-opcode mcrf (xl 19 0) (logior $xlbb-mask (ash 3 21) (ash 3 16)) ($ppc) $bf $bfa) + + #.(ppc-opcode blr (xlo 19 $bou 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode blrl (xlo 19 $bou 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdnzlr (xlo 19 $bodnz 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdnzlr- (xlo 19 $bodnz 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdnzlr+ (xlo 19 $bodnzp 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdnzlrl (xlo 19 $bodnz 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdnzlrl- (xlo 19 $bodnz 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdnzlrl+ (xlo 19 $bodnzp 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdzlr (xlo 19 $bodz 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdzlr- (xlo 19 $bodz 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdzlr+ (xlo 19 $bodzp 16 0) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdzlrl (xlo 19 $bodz 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdzlrl- (xlo 19 $bodz 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bdzlrl+ (xlo 19 $bodzp 16 1) $xlbobibb-mask ($ppc)) + #.(ppc-opcode bltlr (xlocb 19 $bot $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltlr- (xlocb 19 $bot $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltlr+ (xlocb 19 $botp $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltlrl (xlocb 19 $bot $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltlrl- (xlocb 19 $bot $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltlrl+ (xlocb 19 $botp $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtlr (xlocb 19 $bot $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtlr- (xlocb 19 $bot $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtlr+ (xlocb 19 $botp $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtlrl (xlocb 19 $bot $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtlrl- (xlocb 19 $bot $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtlrl+ (xlocb 19 $botp $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqlr (xlocb 19 $bot $cbeq 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqlr- (xlocb 19 $bot $cbeq 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqlr+ (xlocb 19 $botp $cbeq 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqlrl (xlocb 19 $bot $cbeq 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqlrl- (xlocb 19 $bot $cbeq 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqlrl+ (xlocb 19 $botp $cbeq 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsolr (xlocb 19 $bot $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsolr- (xlocb 19 $bot $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsolr+ (xlocb 19 $botp $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsolrl (xlocb 19 $bot $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsolrl- (xlocb 19 $bot $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsolrl+ (xlocb 19 $botp $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunlr (xlocb 19 $bot $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunlr- (xlocb 19 $bot $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunlr+ (xlocb 19 $botp $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunlrl (xlocb 19 $bot $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunlrl- (xlocb 19 $bot $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunlrl+ (xlocb 19 $botp $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgelr (xlocb 19 $bof $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgelr- (xlocb 19 $bof $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgelr+ (xlocb 19 $bofp $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgelrl (xlocb 19 $bof $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgelrl- (xlocb 19 $bof $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgelrl+ (xlocb 19 $bofp $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnllr (xlocb 19 $bof $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnllr- (xlocb 19 $bof $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnllr+ (xlocb 19 $bofp $cblt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnllrl (xlocb 19 $bof $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnllrl- (xlocb 19 $bof $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnllrl+ (xlocb 19 $bofp $cblt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blelr (xlocb 19 $bof $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blelr- (xlocb 19 $bof $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blelr+ (xlocb 19 $bofp $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blelrl (xlocb 19 $bof $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blelrl- (xlocb 19 $bof $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blelrl+ (xlocb 19 $bofp $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnglr (xlocb 19 $bof $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnglr- (xlocb 19 $bof $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnglr+ (xlocb 19 $bofp $cbgt 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnglrl (xlocb 19 $bof $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnglrl- (xlocb 19 $bof $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnglrl+ (xlocb 19 $bofp $cbgt 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnelr (xlocb 19 $bof $cbeq 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnelr- (xlocb 19 $bof $cbeq 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnelr+ (xlocb 19 $bofp $cbeq 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnelrl (xlocb 19 $bof $cbeq 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnelrl- (xlocb 19 $bof $cbeq 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnelrl+ (xlocb 19 $bofp $cbeq 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnslr (xlocb 19 $bof $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnslr- (xlocb 19 $bof $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnslr+ (xlocb 19 $bofp $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnslrl (xlocb 19 $bof $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnslrl- (xlocb 19 $bof $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnslrl+ (xlocb 19 $bofp $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnulr (xlocb 19 $bof $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnulr- (xlocb 19 $bof $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnulr+ (xlocb 19 $bofp $cbso 16) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnulrl (xlocb 19 $bof $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnulrl- (xlocb 19 $bof $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnulrl+ (xlocb 19 $bofp $cbso 16 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode btlr (xlo 19 $bot 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btlr- (xlo 19 $bot 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btlr+ (xlo 19 $botp 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btlrl (xlo 19 $bot 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btlrl- (xlo 19 $bot 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btlrl+ (xlo 19 $botp 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bflr (xlo 19 $bof 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bflr- (xlo 19 $bof 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bflr+ (xlo 19 $bofp 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bflrl (xlo 19 $bof 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bflrl- (xlo 19 $bof 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bflrl+ (xlo 19 $bofp 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnztlr (xlo 19 $bodnzt 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnztlr- (xlo 19 $bodnzt 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnztlr+ (xlo 19 $bodnztp 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnztlrl (xlo 19 $bodnzt 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnztlrl- (xlo 19 $bodnzt 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnztlrl+ (xlo 19 $bodnztp 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnzflr (xlo 19 $bodnzf 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnzflr- (xlo 19 $bodnzf 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnzflr+ (xlo 19 $bodnzfp 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnzflrl (xlo 19 $bodnzf 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnzflrl- (xlo 19 $bodnzf 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdnzflrl+ (xlo 19 $bodnzfp 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdztlr (xlo 19 $bodzt 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdztlr- (xlo 19 $bodzt 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdztlr+ (xlo 19 $bodztp 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdztlrl (xlo 19 $bodzt 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdztlrl- (xlo 19 $bodzt 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdztlrl+ (xlo 19 $bodztp 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdzflr (xlo 19 $bodzf 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdzflr- (xlo 19 $bodzf 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdzflr+ (xlo 19 $bodzfp 16) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdzflrl (xlo 19 $bodzf 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdzflrl- (xlo 19 $bodzf 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bdzflrl+ (xlo 19 $bodzfp 16 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bclr (xllk 19 16) $xlybb-mask ($ppc) $bo $bi) + #.(ppc-opcode bclrl (xllk 19 16 1) $xlybb-mask ($ppc) $bo $bi) + #.(ppc-opcode bclr+ (xlylk 19 16 1) $xlybb-mask ($ppc) $boe $bi) + #.(ppc-opcode bclrl+ (xlylk 19 16 1 1) $xlybb-mask ($ppc) $boe $bi) + #.(ppc-opcode bclr- (xlylk 19 16 0) $xlybb-mask ($ppc) $boe $bi) + #.(ppc-opcode bclrl- (xlylk 19 16 1) $xlybb-mask ($ppc) $boe $bi) + + #.(ppc-opcode crnot (xl 19 33) $xl-mask ($ppc) $bt $ba $bba) + #.(ppc-opcode crnor (xl 19 33) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode rfi (xl 19 50) #xffffffff ($ppc) ) + + + #.(ppc-opcode crandc (xl 19 129) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode isync (xl 19 150) #xffffffff ($ppc)) + + #.(ppc-opcode crclr (xl 19 193) $xl-mask ($ppc) $bt $bat $bba) + #.(ppc-opcode crxor (xl 19 193) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode crnand (xl 19 225) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode crand (xl 19 257) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode crset (xl 19 289) $xl-mask ($ppc) $bt $bat $bba) + #.(ppc-opcode creqv (xl 19 289) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode crorc (xl 19 417) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode crmove (xl 19 449) $xl-mask ($ppc) $bt $ba $bba) + #.(ppc-opcode cror (xl 19 449) $xl-mask ($ppc) $bt $ba $bb) + + #.(ppc-opcode bctr (xlo 19 $bou 528) $xlbobibb-mask ($ppc) ) + #.(ppc-opcode bctrl (xlo 19 $bou 528 1) $xlbobibb-mask ($ppc) ) + #.(ppc-opcode bltctr (xlocb 19 $bot $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltctr- (xlocb 19 $bot $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltctr+ (xlocb 19 $botp $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltctrl (xlocb 19 $bot $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltctrl- (xlocb 19 $bot $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bltctrl+ (xlocb 19 $botp $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtctr (xlocb 19 $bot $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtctr- (xlocb 19 $bot $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtctr+ (xlocb 19 $botp $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtctrl (xlocb 19 $bot $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtctrl- (xlocb 19 $bot $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgtctrl+ (xlocb 19 $botp $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqctr (xlocb 19 $bot $cbeq 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqctr- (xlocb 19 $bot $cbeq 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqctr+ (xlocb 19 $botp $cbeq 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqctrl (xlocb 19 $bot $cbeq 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqctrl- (xlocb 19 $bot $cbeq 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode beqctrl+ (xlocb 19 $botp $cbeq 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsoctr (xlocb 19 $bot $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsoctr- (xlocb 19 $bot $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsoctr+ (xlocb 19 $botp $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsoctrl (xlocb 19 $bot $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsoctrl- (xlocb 19 $bot $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bsoctrl+ (xlocb 19 $botp $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunctr (xlocb 19 $bot $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunctr- (xlocb 19 $bot $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunctr+ (xlocb 19 $botp $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunctrl (xlocb 19 $bot $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunctrl- (xlocb 19 $bot $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bunctrl+ (xlocb 19 $botp $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgectr (xlocb 19 $bof $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgectr- (xlocb 19 $bof $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgectr+ (xlocb 19 $bofp $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgectrl (xlocb 19 $bof $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgectrl- (xlocb 19 $bof $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bgectrl+ (xlocb 19 $bofp $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnlctr (xlocb 19 $bof $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnlctr- (xlocb 19 $bof $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnlctr+ (xlocb 19 $bofp $cblt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnlctrl (xlocb 19 $bof $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnlctrl- (xlocb 19 $bof $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnlctrl+ (xlocb 19 $bofp $cblt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blectr (xlocb 19 $bof $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blectr- (xlocb 19 $bof $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blectr+ (xlocb 19 $bofp $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blectrl (xlocb 19 $bof $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blectrl- (xlocb 19 $bof $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode blectrl+ (xlocb 19 $bofp $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bngctr (xlocb 19 $bof $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bngctr- (xlocb 19 $bof $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bngctr+ (xlocb 19 $bofp $cbgt 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bngctrl (xlocb 19 $bof $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bngctrl- (xlocb 19 $bof $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bngctrl+ (xlocb 19 $bofp $cbgt 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnectr (xlocb 19 $bof $cbeq 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnectr- (xlocb 19 $bof $cbeq 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnectr+ (xlocb 19 $bofp $cbeq 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnectrl (xlocb 19 $bof $cbeq 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnectrl- (xlocb 19 $bof $cbeq 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnectrl+ (xlocb 19 $bofp $cbeq 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnsctr (xlocb 19 $bof $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnsctr- (xlocb 19 $bof $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnsctr+ (xlocb 19 $bofp $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnsctrl (xlocb 19 $bof $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnsctrl- (xlocb 19 $bof $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnsctrl+ (xlocb 19 $bofp $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnuctr (xlocb 19 $bof $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnuctr- (xlocb 19 $bof $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnuctr+ (xlocb 19 $bofp $cbso 528) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnuctrl (xlocb 19 $bof $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnuctrl- (xlocb 19 $bof $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode bnuctrl+ (xlocb 19 $bofp $cbso 528 1) $xlbocbbb-mask ($ppc) $cr) + #.(ppc-opcode btctr (xlo 19 $bot 528) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btctr- (xlo 19 $bot 528) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btctr+ (xlo 19 $botp 528) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btctrl (xlo 19 $bot 528 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btctrl- (xlo 19 $bot 528 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode btctrl+ (xlo 19 $botp 528 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bfctr (xlo 19 $bof 528) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bfctr- (xlo 19 $bof 528) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bfctr+ (xlo 19 $bofp 528) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bfctrl (xlo 19 $bof 528 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bfctrl- (xlo 19 $bof 528 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bfctrl+ (xlo 19 $bofp 528 1) $xlbobb-mask ($ppc) $bi) + #.(ppc-opcode bcctr (xllk 19 528) $xlybb-mask ($ppc) $bo $bi) + #.(ppc-opcode bcctr- (xlylk 19 528 0) $xlybb-mask ($ppc) $boe $bi) + #.(ppc-opcode bcctr+ (xlylk 19 528 1) $xlybb-mask ($ppc) $boe $bi) + #.(ppc-opcode bcctrl (xllk 19 528 1) $xlybb-mask ($ppc) $bo $bi) + #.(ppc-opcode bcctrl- (xlylk 19 528 1) $xlybb-mask ($ppc) $boe $bi) + #.(ppc-opcode bcctrl+ (xlylk 19 528 1 1) $xlybb-mask ($ppc) $boe $bi) + + #.(ppc-opcode rlwimi (m 20) $m-mask ($ppc) $rta $rs $sh $mb $me) + + #.(ppc-opcode rlwimi. (m 20 1) $m-mask ($ppc) $rta $rs $sh $mb $me) + + #.(ppc-opcode rotlwi (mme 21 31) $mmbme-mask ($ppc) $rta $rs $sh) + #.(ppc-opcode clrlwi (mme 21 31) $mshme-mask ($ppc) $rta $rs $mb) + #.(ppc-opcode rlwinm (m 21) $m-mask ($ppc) $rta $rs $sh $mb $me) + #.(ppc-opcode rotlwi. (mme 21 31 1) $mmbme-mask ($ppc) $rta $rs $sh) + #.(ppc-opcode clrlwi. (mme 21 31 1) $mshme-mask ($ppc) $rta $rs $mb) + #.(ppc-opcode rlwinm. (m 21 1) $m-mask ($ppc) $rta $rs $sh $mb $me) + + #.(ppc-opcode rotlw (mme 23 31) $mmbme-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode rlwnm (m 23) $m-mask ($ppc) $rta $rs $rb $mb $me) + #.(ppc-opcode rotlw. (mme 23 31 1) $mmbme-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode rlwnm. (m 23 1) $m-mask ($ppc) $rta $rs $rb $mb $me) + + #.(ppc-opcode nop (op 24) #xffffffff ($ppc)) + #.(ppc-opcode ori (op 24) $op-mask ($ppc) $rta $rs $ui) + + #.(ppc-opcode oris (op 25) $op-mask ($ppc) $rta $rs $ui) + + #.(ppc-opcode xori (op 26) $op-mask ($ppc) $rta $rs $ui) + + #.(ppc-opcode xoris (op 27) $op-mask ($ppc) $rta $rs $ui) + + #.(ppc-opcode andi. (op 28) $op-mask ($ppc) $rta $rs $ui) + + #.(ppc-opcode andis. (op 29) $op-mask ($ppc) $rta $rs $ui) + + #.(ppc-opcode rotldi (md 30 0 0) $mdmb-mask ($ppc $b64) $rta $rs $sh6) + #.(ppc-opcode clrldi (md 30 0 0) $mdsh-mask ($ppc $b64) $rta $rs $mb6) + #.(ppc-opcode rldicl (md 30 0 0) $md-mask ($ppc $b64) $rta $rs $sh6 $mb6) + #.(ppc-opcode rotldi. (md 30 0 1) $mdmb-mask ($ppc $b64) $rta $rs $sh6) + #.(ppc-opcode clrldi. (md 30 0 1) $mdsh-mask ($ppc $b64) $rta $rs $mb6) + #.(ppc-opcode rldicl. (md 30 0 1) $md-mask ($ppc $b64) $rta $rs $sh6 $mb6) + + #.(ppc-opcode rldicr (md 30 1 0) $md-mask ($ppc $b64) $rta $rs $sh6 $me6) + #.(ppc-opcode rldicr. (md 30 1 1) $md-mask ($ppc $b64) $rta $rs $sh6 $me6) + + #.(ppc-opcode rldic (md 30 2 0) $md-mask ($ppc $b64) $rta $rs $sh6 $mb6) + #.(ppc-opcode rldic. (md 30 2 1) $md-mask ($ppc $b64) $rta $rs $sh6 $mb6) + + #.(ppc-opcode rldimi (md 30 3 0) $md-mask ($ppc $b64) $rta $rs $sh6 $mb6) + #.(ppc-opcode rldimi. (md 30 3 1) $md-mask ($ppc $b64) $rta $rs $sh6 $mb6) + + #.(ppc-opcode rotld (mds 30 8 0) $mdsmb-mask ($ppc $b64) $rta $rs $rb) + #.(ppc-opcode rldcl (mds 30 8 0) $mds-mask ($ppc $b64) $rta $rs $rb $mb6) + #.(ppc-opcode rotld. (mds 30 8 1) $mdsmb-mask ($ppc $b64) $rta $rs $rb) + #.(ppc-opcode rldcl. (mds 30 8 1) $mds-mask ($ppc $b64) $rta $rs $rb $mb6) + + #.(ppc-opcode rldcr (mds 30 9 0) $mds-mask ($ppc $b64) $rta $rs $rb $me6) + #.(ppc-opcode rldcr. (mds 30 9 1) $mds-mask ($ppc $b64) $rta $rs $rb $me6) + + #.(ppc-opcode cmpw (xcmpl 31 0 0) $xcmpl-mask ($ppc) $obf $ra $rb) + + #.(ppc-opcode cmpd (xcmpl 31 0 1) $xcmpl-mask ($ppc $b64) $obf $ra $rb) + + + #.(ppc-opcode cmp (x 31 0) $xcmp-mask ($ppc) $bf $l $ra $rb) + + #.(ppc-opcode twlgt (xto 31 4 $tolgt) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twllt (xto 31 4 $tollt) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode tweq (xto 31 4 $toeq) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twlge (xto 31 4 $tolge) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twlnl (xto 31 4 $tolnl) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twlle (xto 31 4 $tolle) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twlng (xto 31 4 $tolng) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twgt (xto 31 4 $togt) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twge (xto 31 4 $toge) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twnl (xto 31 4 $tonl) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twlt (xto 31 4 $tolt) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twle (xto 31 4 $tole) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twng (xto 31 4 $tong) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode twne (xto 31 4 $tone) $xto-mask ($ppc) $ra $rb) + #.(ppc-opcode trap (xto 31 4 $tou) #xffffffff ($ppc)) + #.(ppc-opcode tw (x 31 4) $x-mask ($ppc) $to $ra $rb) + + #.(ppc-opcode subfc (xo 31 8 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subc (xo 31 8 0 0) $xo-mask ($ppc) $rt $rb $ra) + #.(ppc-opcode subfc. (xo 31 8 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subc. (xo 31 8 0 1) $xo-mask ($ppc) $rt $rb $ra) + #.(ppc-opcode subfco (xo 31 8 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subco (xo 31 8 1 0) $xo-mask ($ppc) $rt $rb $ra) + #.(ppc-opcode subfco. (xo 31 8 1 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subco. (xo 31 8 1 1) $xo-mask ($ppc) $rt $rb $ra) + + + #.(ppc-opcode mulhdu (xo 31 9 0 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode mulhdu. (xo 31 9 0 1) $xo-mask ($ppc $b64) $rt $ra $rb) + + + #.(ppc-opcode addc (xo 31 10 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addc. (xo 31 10 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addco (xo 31 10 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addco. (xo 31 10 1 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode mulhwu (xo 31 11 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode mulhwu. (xo 31 11 0 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode mfcr (x 31 19) $xrarb-mask ($ppc) $rt) + + #.(ppc-opcode lwarx (x 31 20) $x-mask ($ppc) $rt $ra $rb) + + + #.(ppc-opcode ldx (x 31 21) $x-mask ($ppc $b64) $rt $ra $rb) + + + #.(ppc-opcode lwzx (x 31 23) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode slw (xrc 31 24) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode slw. (xrc 31 24 1) $x-mask ($ppc) $rta $rs $rb) + + #.(ppc-opcode cntlzw (xrc 31 26) $xrb-mask ($ppc) $rta $rs) + #.(ppc-opcode cntlzw. (xrc 31 26 1) $xrb-mask ($ppc) $rta $rs) + + + #.(ppc-opcode sld (xrc 31 27) $x-mask ($ppc $b64) $rta $rs $rb) + #.(ppc-opcode sld. (xrc 31 27 1) $x-mask ($ppc $b64) $rta $rs $rb) + + + #.(ppc-opcode and (xrc 31 28) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode and. (xrc 31 28 1) $x-mask ($ppc) $rta $rs $rb) + + #.(ppc-opcode cmplw (xcmpl 31 32 0) $xcmpl-mask ($ppc) $obf $ra $rb) + + #.(ppc-opcode cmpld (xcmpl 31 32 1) $xcmpl-mask ($ppc $b64) $obf $ra $rb) + + #.(ppc-opcode cmpl (x 31 32) $xcmp-mask ($ppc) $bf $l $ra $rb) + + #.(ppc-opcode subf (xo 31 40 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode sub (xo 31 40 0 0) $xo-mask ($ppc) $rt $rb $ra) + #.(ppc-opcode subf. (xo 31 40 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode sub. (xo 31 40 0 1) $xo-mask ($ppc) $rt $rb $ra) + #.(ppc-opcode subfo (xo 31 40 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subo (xo 31 40 1 0) $xo-mask ($ppc) $rt $rb $ra) + #.(ppc-opcode subfo. (xo 31 40 1 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subo. (xo 31 40 1 1) $xo-mask ($ppc) $rt $rb $ra) + + + #.(ppc-opcode ldux (x 31 53) $x-mask ($ppc $b64) $rt $ral $rb) + + + #.(ppc-opcode dcbst (x 31 54) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode lwzux (x 31 55) $x-mask ($ppc) $rt $ral $rb) + + + #.(ppc-opcode cntlzd (xrc 31 58) $xrb-mask ($ppc $b64) $rta $rs) + #.(ppc-opcode cntlzd. (xrc 31 58 1) $xrb-mask ($ppc $b64) $rta $rs) + + + #.(ppc-opcode andc (xrc 31 60) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode andc. (xrc 31 60 1) $x-mask ($ppc) $rta $rs $rb) + + + #.(ppc-opcode tdlgt (xto 31 68 $tolgt) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdllt (xto 31 68 $tollt) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdeq (xto 31 68 $toeq) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdlge (xto 31 68 $tolge) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdlnl (xto 31 68 $tolnl) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdlle (xto 31 68 $tolle) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdlng (xto 31 68 $tolng) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdgt (xto 31 68 $togt) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdge (xto 31 68 $toge) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdnl (xto 31 68 $tonl) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdlt (xto 31 68 $tolt) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdle (xto 31 68 $tole) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdng (xto 31 68 $tong) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode tdne (xto 31 68 $tone) $xto-mask ($ppc $b64) $ra $rb) + #.(ppc-opcode td (x 31 68) $x-mask ($ppc $b64) $to $ra $rb) + + #.(ppc-opcode mulhd (xo 31 73 0 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode mulhd. (xo 31 73 0 1) $xo-mask ($ppc $b64) $rt $ra $rb) + + + #.(ppc-opcode mulhw (xo 31 75 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode mulhw. (xo 31 75 0 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode mfmsr (x 31 83) $xrarb-mask ($ppc) $rt) + + + #.(ppc-opcode ldarx (x 31 84) $x-mask ($ppc $b64) $rt $ra $rb) + + + #.(ppc-opcode dcbf (x 31 86) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode lbzx (x 31 87) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode neg (xo 31 104 0 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode neg. (xo 31 104 0 1) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode nego (xo 31 104 1 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode nego. (xo 31 104 1 1) $xorb-mask ($ppc) $rt $ra) + + #.(ppc-opcode lbzux (x 31 119) $x-mask ($ppc) $rt $ral $rb) + + #.(ppc-opcode not (xrc 31 124) $x-mask ($ppc) $rta $rs $rbs) + #.(ppc-opcode nor (xrc 31 124) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode not. (xrc 31 124 1) $x-mask ($ppc) $rta $rs $rbs) + #.(ppc-opcode nor. (xrc 31 124 1) $x-mask ($ppc) $rta $rs $rb) + + #.(ppc-opcode subfe (xo 31 136 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subfe. (xo 31 136 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subfeo (xo 31 136 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode subfeo. (xo 31 136 1 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode adde (xo 31 138 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode adde. (xo 31 138 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addeo (xo 31 138 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addeo. (xo 31 138 1 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode mtcrf (x 31 144) (logior $x-mask (ash 1 20) (ash 1 11)) ($ppc) $fxm $rs) + + #.(ppc-opcode mtmsr (x 31 146) $xrarb-mask ($ppc) $rs) + + + #.(ppc-opcode stdx (x 31 149) $x-mask ($ppc $b64) $rs $ra $rb) + + + #.(ppc-opcode stwcx. (xrc 31 150 1) $x-mask ($ppc) $rs $ra $rb) + + #.(ppc-opcode stwx (x 31 151) $x-mask ($ppc) $rs $ra $rb) + + #.(ppc-opcode stdux (x 31 181) $x-mask ($ppc $b64) $rs $ras $rb) + + #.(ppc-opcode stwux (x 31 183) $x-mask ($ppc) $rs $ras $rb) + + #.(ppc-opcode subfze (xo 31 200 0 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode subfze. (xo 31 200 0 1) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode subfzeo (xo 31 200 1 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode subfzeo. (xo 31 200 1 1) $xorb-mask ($ppc) $rt $ra) + + #.(ppc-opcode addze (xo 31 202 0 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode addze. (xo 31 202 0 1) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode addzeo (xo 31 202 1 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode addzeo. (xo 31 202 1 1) $xorb-mask ($ppc) $rt $ra) + + #.(ppc-opcode mtsr (x 31 210) (logior $xrb-mask (ash 1 20)) ($ppc $b32) $sr $rs) + + #.(ppc-opcode stdcx. (xrc 31 214 1) $x-mask ($ppc $b64) $rs $ra $rb) + + #.(ppc-opcode stbx (x 31 215) $x-mask ($ppc) $rs $ra $rb) + + #.(ppc-opcode subfme (xo 31 232 0 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode subfme. (xo 31 232 0 1) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode subfmeo (xo 31 232 1 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode subfmeo. (xo 31 232 1 1) $xorb-mask ($ppc) $rt $ra) + + + #.(ppc-opcode mulld (xo 31 233 0 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode mulld. (xo 31 233 0 1) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode mulldo (xo 31 233 1 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode mulldo. (xo 31 233 1 1) $xo-mask ($ppc $b64) $rt $ra $rb) + + + #.(ppc-opcode addme (xo 31 234 0 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode addme. (xo 31 234 0 1) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode addmeo (xo 31 234 1 0) $xorb-mask ($ppc) $rt $ra) + #.(ppc-opcode addmeo. (xo 31 234 1 1) $xorb-mask ($ppc) $rt $ra) + + #.(ppc-opcode mullw (xo 31 235 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode mullw. (xo 31 235 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode mullwo (xo 31 235 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode mullwo. (xo 31 235 1 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode mtsrin (x 31 242) $xra-mask ($ppc $b32) $rs $rb) + + #.(ppc-opcode dcbtst (x 31 246) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode stbux (x 31 247) $x-mask ($ppc) $rs $ras $rb) + + #.(ppc-opcode add (xo 31 266 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode add. (xo 31 266 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addo (xo 31 266 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode addo. (xo 31 266 1 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode dcbt (x 31 278) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode lhzx (x 31 279) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode eqv (xrc 31 284) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode eqv. (xrc 31 284 1) $x-mask ($ppc) $rta $rs $rb) + + #.(ppc-opcode tlbie (x 31 306) $xrtra-mask ($ppc) $rb) + + #.(ppc-opcode eciwx (x 31 310) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode lhzux (x 31 311) $x-mask ($ppc) $rt $ral $rb) + + #.(ppc-opcode xor (xrc 31 316) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode xor. (xrc 31 316 1) $x-mask ($ppc) $rta $rs $rb) + + #.(ppc-opcode mfxer (xspr 31 339 1) $xspr-mask ($ppc) $rt) + #.(ppc-opcode mflr (xspr 31 339 8) $xspr-mask ($ppc) $rt) + #.(ppc-opcode mfctr (xspr 31 339 9) $xspr-mask ($ppc) $rt) + #.(ppc-opcode mfspr (x 31 339) $x-mask ($ppc) $rt $spr) + + + #.(ppc-opcode lwax (x 31 341) $x-mask ($ppc $b64) $rt $ra $rb) + + #.(ppc-opcode lhax (x 31 343) $x-mask ($ppc) $rt $ra $rb) + + + #.(ppc-opcode tlbia (x 31 370) #xffffffff ($ppc)) + + #.(ppc-opcode mftb (x 31 371) $x-mask ($ppc) $rt $tbr) + + + #.(ppc-opcode lwaux (x 31 373) $x-mask ($ppc $b64) $rt $ral $rb) + + #.(ppc-opcode lhaux (x 31 375) $x-mask ($ppc) $rt $ral $rb) + + #.(ppc-opcode sthx (x 31 407) $x-mask ($ppc) $rs $ra $rb) + #.(ppc-opcode orc (xrc 31 412) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode orc. (xrc 31 412 1) $x-mask ($ppc) $rta $rs $rb) + + #.(ppc-opcode sradi (xs 31 413) $xs-mask ($ppc $b64) $rta $rs $sh6) + #.(ppc-opcode sradi. (xs 31 413 1) $xs-mask ($ppc $b64) $rta $rs $sh6) + + #.(ppc-opcode slbie (x 31 434) $xrtra-mask ($ppc $b64) $rb) + + + #.(ppc-opcode ecowx (x 31 438) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode sthux (x 31 439) $x-mask ($ppc) $rs $ras $rb) + + #.(ppc-opcode mr (xrc 31 444) $x-mask ($ppc) $rta $rs $rbs) + #.(ppc-opcode or (xrc 31 444) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode mr. (xrc 31 444 1) $x-mask ($ppc) $rta $rs $rbs) + #.(ppc-opcode or. (xrc 31 444 1) $x-mask ($ppc) $rta $rs $rb) + + + #.(ppc-opcode divdu (xo 31 457 0 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode divdu. (xo 31 457 0 1) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode divduo (xo 31 457 1 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode divduo. (xo 31 457 1 1) $xo-mask ($ppc $b64) $rt $ra $rb) + + + #.(ppc-opcode divwu (xo 31 459 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode divwu. (xo 31 459 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode divwuo (xo 31 459 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode divwuo. (xo 31 459 1 1) $xo-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode mtxer (xspr 31 467 1) $xspr-mask ($ppc) $rs) + #.(ppc-opcode mtlr (xspr 31 467 8) $xspr-mask ($ppc) $rs) + #.(ppc-opcode mtctr (xspr 31 467 9) $xspr-mask ($ppc) $rs) + #.(ppc-opcode mtspr (x 31 467) $x-mask ($ppc) $spr $rs) + + #.(ppc-opcode dcbi (x 31 470) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode nand (xrc 31 476) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode nand. (xrc 31 476 1) $x-mask ($ppc) $rta $rs $rb) + + + #.(ppc-opcode divd (xo 31 489 0 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode divd. (xo 31 489 0 1) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode divdo (xo 31 489 1 0) $xo-mask ($ppc $b64) $rt $ra $rb) + #.(ppc-opcode divdo. (xo 31 489 1 1) $xo-mask ($ppc $b64) $rt $ra $rb) + + #.(ppc-opcode divw (xo 31 491 0 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode divw. (xo 31 491 0 1) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode divwo (xo 31 491 1 0) $xo-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode divwo. (xo 31 491 1 1) $xo-mask ($ppc) $rt $ra $rb) + + + #.(ppc-opcode slbia (x 31 498) #xffffffff ($ppc $b64)) + + + + #.(ppc-opcode mcrxr (x 31 512) (logior $xrarb-mask (ash 3 21)) ($ppc) $bf) + + #.(ppc-opcode lswx (x 31 533) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode lwbrx (x 31 534) $x-mask ($ppc) $rt $ra $rb) + + #.(ppc-opcode lfsx (x 31 535) $x-mask ($ppc) $frt $ra $rb) + + #.(ppc-opcode srw (xrc 31 536) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode srw. (xrc 31 536 1) $x-mask ($ppc) $rta $rs $rb) + + + + #.(ppc-opcode srd (xrc 31 539) $x-mask ($ppc $b64) $rta $rs $rb) + #.(ppc-opcode srd. (xrc 31 539 1) $x-mask ($ppc $b64) $rta $rs $rb) + + + #.(ppc-opcode tlbsync (x 31 566) #xffffffff ($ppc)) + + #.(ppc-opcode lfsux (x 31 567) $x-mask ($ppc) $frt $ras $rb) + + #.(ppc-opcode mfsr (x 31 595) (logior $xrb-mask (ash 1 20)) ($ppc $b32) $rt $sr) + + #.(ppc-opcode lswi (x 31 597) $x-mask ($ppc) $rt $ra $nb) + + #.(ppc-opcode lwsync (xsync 31 598 1) #xffffffff ($ppc)) + #.(ppc-opcode sync (x 31 598) $xsync-mask ($ppc)) + + #.(ppc-opcode lfdx (x 31 599) $x-mask ($ppc) $frt $ra $rb) + #.(ppc-opcode lfdux (x 31 631) $x-mask ($ppc) $frt $ras $rb) + + #.(ppc-opcode mfsrin (x 31 659) $xra-mask ($ppc $b32) $rt $rb) + + #.(ppc-opcode stswx (x 31 661) $x-mask ($ppc) $rs $ra $rb) + + #.(ppc-opcode stwbrx (x 31 662) $x-mask ($ppc) $rs $ra $rb) + + #.(ppc-opcode stfsx (x 31 663) $x-mask ($ppc) $frs $ra $rb) + #.(ppc-opcode stfsux (x 31 695) $x-mask ($ppc) $frs $ras $rb) + #.(ppc-opcode stswi (x 31 725) $x-mask ($ppc) $rs $ra $nb) + #.(ppc-opcode stfdx (x 31 727) $x-mask ($ppc) $frs $ra $rb) + #.(ppc-opcode stfdux (x 31 759) $x-mask ($ppc) $frs $ras $rb) + #.(ppc-opcode lhbrx (x 31 790) $x-mask ($ppc) $rt $ra $rb) + #.(ppc-opcode sraw (xrc 31 792) $x-mask ($ppc) $rta $rs $rb) + #.(ppc-opcode sraw. (xrc 31 792 1) $x-mask ($ppc) $rta $rs $rb) + + + #.(ppc-opcode srad (xrc 31 794) $x-mask ($ppc $b64) $rta $rs $rb) + #.(ppc-opcode srad. (xrc 31 794 1) $x-mask ($ppc $b64) $rta $rs $rb) + + + #.(ppc-opcode srawi (xrc 31 824) $x-mask ($ppc) $rta $rs $sh) + #.(ppc-opcode srawi. (xrc 31 824 1) $x-mask ($ppc) $rta $rs $sh) + + #.(ppc-opcode eieio (x 31 854) #xffffffff ($ppc)) + + #.(ppc-opcode sthbrx (x 31 918) $x-mask ($ppc) $rs $ra $rb) + + #.(ppc-opcode extsh (xrc 31 922) $xrb-mask ($ppc) $rta $rs) + #.(ppc-opcode extsh. (xrc 31 922 1) $xrb-mask ($ppc) $rta $rs) + + #.(ppc-opcode extsb (xrc 31 954) $xrb-mask ($ppc) $rta $rs) + #.(ppc-opcode extsb. (xrc 31 954 1) $xrb-mask ($ppc) $rta $rs) + + #.(ppc-opcode icbi (x 31 982) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode stfiwx (x 31 983) $x-mask ($ppc) $frs $ra $rb) + + #.(ppc-opcode extsw (xrc 31 986) $xrb-mask ($ppc) $rta $rs) + #.(ppc-opcode extsw. (xrc 31 986 1) $xrb-mask ($ppc) $rta $rs) + + #.(ppc-opcode dcbz (x 31 1014) $xrt-mask ($ppc) $ra $rb) + #.(ppc-opcode dclz (x 31 1014) $xrt-mask ($ppc) $ra $rb) + + #.(ppc-opcode lvebx (x 31 7) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode lvehx (x 31 39) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode lvewx (x 31 71) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode lvsl (x 31 6) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode lvsr (x 31 38) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode lvx (x 31 103) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode lvxl (x 31 359) $x-mask ($ppc) $vd $ra $rb) + #.(ppc-opcode stvebx (x 31 135) $x-mask ($ppc) $vs $ra $rb) + #.(ppc-opcode stvehx (x 31 167) $x-mask ($ppc) $vs $ra $rb) + #.(ppc-opcode stvewx (x 31 199) $x-mask ($ppc) $vs $ra $rb) + #.(ppc-opcode stvx (x 31 231) $x-mask ($ppc) $vs $ra $rb) + #.(ppc-opcode stvxl (x 31 487) $x-mask ($ppc) $vs $ra $rb) + + #.(ppc-opcode dss (x 31 822) $x-mask ($ppc) $strm $all/transient) + #.(ppc-opcode dst (x 31 342) $x-mask ($ppc) $ra $rb $strm $all/transient) + #.(ppc-opcode dstst (x 31 374) $x-mask ($ppc) $ra $rb $strm $all/transient) + + #.(ppc-opcode lwz (op 32) $op-mask ($ppc) $rt $d $ra) + + #.(ppc-opcode lwzu (op 33) $op-mask ($ppc) $rt $d $ral) + + #.(ppc-opcode lbz (op 34) $op-mask ($ppc) $rt $d $ra) + + #.(ppc-opcode lbzu (op 35) $op-mask ($ppc) $rt $d $ral) + + #.(ppc-opcode stw (op 36) $op-mask ($ppc) $rs $d $ra) + + #.(ppc-opcode stwu (op 37) $op-mask ($ppc) $rs $d $ras) + + #.(ppc-opcode stb (op 38) $op-mask ($ppc) $rs $d $ra) + + #.(ppc-opcode stbu (op 39) $op-mask ($ppc) $rs $d $ras) + + #.(ppc-opcode lhz (op 40) $op-mask ($ppc) $rt $d $ra) + + #.(ppc-opcode lhzu (op 41) $op-mask ($ppc) $rt $d $ral) + + #.(ppc-opcode lha (op 42) $op-mask ($ppc) $rt $d $ra) + + #.(ppc-opcode lhau (op 43) $op-mask ($ppc) $rt $d $ral) + + #.(ppc-opcode sth (op 44) $op-mask ($ppc) $rs $d $ra) + + #.(ppc-opcode sthu (op 45) $op-mask ($ppc) $rs $d $ras) + + #.(ppc-opcode lmw (op 46) $op-mask ($ppc) $rt $d $ram) + + #.(ppc-opcode stmw (op 47) $op-mask ($ppc) $rs $d $ra) + + #.(ppc-opcode lfs (op 48) $op-mask ($ppc) $frt $d $ra) + + #.(ppc-opcode lfsu (op 49) $op-mask ($ppc) $frt $d $ras) + + #.(ppc-opcode lfd (op 50) $op-mask ($ppc) $frt $d $ra) + + #.(ppc-opcode lfdu (op 51) $op-mask ($ppc) $frt $d $ras) + + #.(ppc-opcode stfs (op 52) $op-mask ($ppc) $frs $d $ra) + + #.(ppc-opcode stfsu (op 53) $op-mask ($ppc) $frs $d $ras) + + #.(ppc-opcode stfd (op 54) $op-mask ($ppc) $frs $d $ra) + + #.(ppc-opcode stfdu (op 55) $op-mask ($ppc) $frs $d $ras) + + + + + #.(ppc-opcode ld (dso 58 0) $ds-mask ($ppc $b64) $rt $ds $ra) + + #.(ppc-opcode ldu (dso 58 1) $ds-mask ($ppc $b64) $rt $ds $ral) + + #.(ppc-opcode lwa (dso 58 2) $ds-mask ($ppc $b64) $rt $ds $ra) + + + #.(ppc-opcode fdivs (a 59 18 0) $afrc-mask ($ppc) $frt $fra $frb) + #.(ppc-opcode fdivs. (a 59 18 1) $afrc-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode fsubs (a 59 20 0) $afrc-mask ($ppc) $frt $fra $frb) + #.(ppc-opcode fsubs. (a 59 20 1) $afrc-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode fadds (a 59 21 0) $afrc-mask ($ppc) $frt $fra $frb) + #.(ppc-opcode fadds. (a 59 21 1) $afrc-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode fsqrts (a 59 22 0) $afrafrc-mask ($ppc) $frt $frb) + #.(ppc-opcode fsqrts. (a 59 22 1) $afrafrc-mask ($ppc) $frt $frb) + + #.(ppc-opcode fres (a 59 24 0) $afrafrc-mask ($ppc) $frt $frb) + #.(ppc-opcode fres. (a 59 24 1) $afrafrc-mask ($ppc) $frt $frb) + + #.(ppc-opcode fmuls (a 59 25 0) $afrb-mask ($ppc) $frt $fra $frc) + #.(ppc-opcode fmuls. (a 59 25 1) $afrb-mask ($ppc) $frt $fra $frc) + + #.(ppc-opcode fmsubs (a 59 28 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fmsubs. (a 59 28 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fmadds (a 59 29 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fmadds. (a 59 29 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fnmsubs (a 59 30 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fnmsubs. (a 59 30 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fnmadds (a 59 31 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fnmadds. (a 59 31 1) $a-mask ($ppc) $frt $fra $frc $frb) + + + + + #.(ppc-opcode std (dso 62 0) $ds-mask ($ppc $b64) $rs $ds $ra) + + #.(ppc-opcode stdu (dso 62 1) $ds-mask ($ppc $b64) $rs $ds $ras) + + + #.(ppc-opcode fcmpu (x 63 0) (logior $x-mask (ash 3 21)) ($ppc) $bf $fra $frb) + + #.(ppc-opcode frsp (xrc 63 12) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode frsp. (xrc 63 12 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode fctiw (xrc 63 14) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode fctiw. (xrc 63 14 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode fctiwz (xrc 63 15) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode fctiwz. (xrc 63 15 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode fdiv (a 63 18 0) $afrc-mask ($ppc) $frt $fra $frb) + #.(ppc-opcode fdiv. (a 63 18 1) $afrc-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode fsub (a 63 20 0) $afrc-mask ($ppc) $frt $fra $frb) + #.(ppc-opcode fsub. (a 63 20 1) $afrc-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode fadd (a 63 21 0) $afrc-mask ($ppc) $frt $fra $frb) + #.(ppc-opcode fadd. (a 63 21 1) $afrc-mask ($ppc) $frt $fra $frb) + + #.(ppc-opcode fsqrt (a 63 22 0) $afrafrc-mask ($ppc) $frt $frb) + #.(ppc-opcode fsqrt. (a 63 22 1) $afrafrc-mask ($ppc) $frt $frb) + + #.(ppc-opcode fsel (a 63 23 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fsel. (a 63 23 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fmul (a 63 25 0) $afrb-mask ($ppc) $frt $fra $frc) + #.(ppc-opcode fmul. (a 63 25 1) $afrb-mask ($ppc) $frt $fra $frc) + + #.(ppc-opcode fmsub (a 63 28 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fmsub. (a 63 28 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fmadd (a 63 29 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fmadd. (a 63 29 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fnmsub (a 63 30 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fnmsub. (a 63 30 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fnmadd (a 63 31 0) $a-mask ($ppc) $frt $fra $frc $frb) + #.(ppc-opcode fnmadd. (a 63 31 1) $a-mask ($ppc) $frt $fra $frc $frb) + + #.(ppc-opcode fcmpo (x 63 32) (logior $x-mask (ash 3 21)) ($ppc) $bf $fra $frb) + + #.(ppc-opcode mtfsb1 (xrc 63 38) $xrarb-mask ($ppc) $bt) + #.(ppc-opcode mtfsb1. (xrc 63 38 1) $xrarb-mask ($ppc) $bt) + + #.(ppc-opcode fneg (xrc 63 40) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode fneg. (xrc 63 40 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode mcrfs (x 63 64) (logior $xrb-mask (ash 3 21) (ash 3 16)) ($ppc) $bf $bfa) + + #.(ppc-opcode mtfsb0 (xrc 63 70) $xrarb-mask ($ppc) $bt) + #.(ppc-opcode mtfsb0. (xrc 63 70 1) $xrarb-mask ($ppc) $bt) + + #.(ppc-opcode fmr (xrc 63 72) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode fmr. (xrc 63 72 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode mtfsfi (xrc 63 134) (logior $xra-mask (ash 3 21) (ash 1 11)) ($ppc) $bf $u) + #.(ppc-opcode mtfsfi. (xrc 63 134 1) (logior $xra-mask (ash 3 21) (ash 1 11)) ($ppc) $bf $u) + + #.(ppc-opcode fnabs (xrc 63 136) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode fnabs. (xrc 63 136 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode fabs (xrc 63 264) $xra-mask ($ppc) $frt $frb) + #.(ppc-opcode fabs. (xrc 63 264 1) $xra-mask ($ppc) $frt $frb) + + #.(ppc-opcode mffs (xrc 63 583) $xrarb-mask ($ppc) $frt) + #.(ppc-opcode mffs. (xrc 63 583 1) $xrarb-mask ($ppc) $frt) + + #.(ppc-opcode mtfsf (xfl 63 711) $xfl-mask ($ppc) $flm $frb) + #.(ppc-opcode mtfsf. (xfl 63 711 1) $xfl-mask ($ppc) $flm $frb) + + #.(ppc-opcode fctid (xrc 63 814) $xra-mask ($ppc $b64) $frt $frb) + #.(ppc-opcode fctid. (xrc 63 814 1) $xra-mask ($ppc $b64) $frt $frb) + + #.(ppc-opcode fctidz (xrc 63 815) $xra-mask ($ppc $b64) $frt $frb) + #.(ppc-opcode fctidz. (xrc 63 815 1) $xra-mask ($ppc $b64) $frt $frb) + + #.(ppc-opcode fcfid (xrc 63 846) $xra-mask ($ppc $b64) $frt $frb) + #.(ppc-opcode fcfid. (xrc 63 846 1) $xra-mask ($ppc $b64) $frt $frb) + +)) + +(defvar *ppc-opcode-indices* (make-array 64 :initial-element -1)) +(defvar *ppc-opcode-counts* (make-array 64 :initial-element 0)) +(defvar *ppc-opcode-numbers* (make-hash-table :test #'equalp)) +(defvar *ppc-instruction-macros* (make-hash-table :test #'equalp)) + +(defun initialize-ppc-opcode-numbers () + (clrhash *ppc-opcode-numbers*) + (dotimes (i 64) + (setf (svref *ppc-opcode-indices* i) -1 + (svref *ppc-opcode-counts* i) 0)) + (dotimes (i (length *ppc-opcodes*)) + (let* ((code (svref *ppc-opcodes* i)) + (opcode (ccl::opcode-opcode code)) + (mask (ccl::opcode-mask code))) + (setf (gethash (string (ccl::opcode-name code)) *ppc-opcode-numbers*) i) + (setf (ccl::opcode-op-high code) (ldb (byte 16 16) opcode) + (ccl::opcode-op-low code) (ldb (byte 16 0) opcode) + (ccl::opcode-mask-high code) (ldb (byte 16 16) mask) + (ccl::opcode-mask-low code) (ldb (byte 16 0) mask)) + (setf (ccl::opcode-vinsn-operands code) (ccl::opcode-operands code) + (ccl::opcode-min-vinsn-args code) (ccl::opcode-min-args code) + (ccl::opcode-max-vinsn-args code) (ccl::opcode-max-args code)) + (let* ((op (ccl::opcode-majorop code))) + (if (= -1 (svref *ppc-opcode-indices* op)) + (setf (svref *ppc-opcode-indices* op) i + (svref *ppc-opcode-counts* op) 1) + (incf (svref *ppc-opcode-counts* op)))))) + (when (fboundp 'ccl::fixup-vinsn-templates) ; not defined yet at bootstrap time + (ccl::fixup-vinsn-templates (ccl::backend-p2-vinsn-templates ccl::*target-backend*) *ppc-opcode-numbers* )) + (when (fboundp 'ccl::fixup-ppc-backend) + (ccl::fixup-ppc-backend))) + +(initialize-ppc-opcode-numbers) + + +(defmacro defppcmacro (name arglist &body body) + `(setf (ppc-macro-function ',(string name)) + #',(ccl:parse-macro name arglist body))) + +(defun ppc-macro-function (name) + (gethash (string name) *ppc-instruction-macros*)) + +(defun (setf ppc-macro-function) (new-function name) + (if (gethash name *ppc-opcode-numbers*) + (error "~s is already defined as an assembler instruction" name)) + (setf (gethash name *ppc-instruction-macros*) new-function)) + +(defppcmacro extlwi (ra rs n b) + `(rlwinm ,ra ,rs ,b 0 (1- ,n))) + +(defppcmacro extlwi. (ra rs n b) + `(rlwinm. ,ra ,rs ,b 0 (1- ,n))) + +(defppcmacro extrwi (ra rs n b) + `(rlwinm ,ra ,rs (+ ,b ,n) (- 32 ,n) 31)) + +(defppcmacro extrwi. (ra rs n b) + `(rlwinm. ,ra ,rs (+ ,b ,n) (- 32 ,n) 31)) + +(defppcmacro inslwi (ra rs n b) + `(rlwimi ,ra ,rs (- 32 ,b) ,b (1- (+ ,b ,n)))) + +(defppcmacro inslwi. (ra rs n b) + `(rlwimi. ,ra ,rs (- 32 ,b) ,b (1- (+ ,b ,n)))) + +(defppcmacro insrwi (ra rs n b) + `(rlwimi ,ra ,rs (- 32 (+ ,b ,n)) ,b (1- (+ ,b ,n)))) + +(defppcmacro insrwi. (ra rs n b) + `(rlwimi. ,ra ,rs (- 32 (+ ,b ,n)) ,b (1- (+ ,b ,n)))) + +(defppcmacro rotrwi (ra rs n) + `(rlwinm ,ra ,rs (- 32 ,n) 0 31)) + +(defppcmacro rotrwi. (ra rs n) + `(rlwinm. ,ra ,rs (- 32 ,n) 0 31)) + +(defppcmacro slwi (ra rs n) + `(rlwinm ,ra ,rs ,n 0 (- 31 ,n))) + +(defppcmacro slwi. (ra rs n) + `(rlwinm. ,ra ,rs ,n 0 (- 31 ,n))) + +(defppcmacro srwi (ra rs n) + `(rlwinm ,ra ,rs (- 32 ,n) ,n 31)) + +(defppcmacro srwi. (ra rs n) + `(rlwinm. ,ra ,rs (- 32 ,n) ,n 31)) + +(defppcmacro clrrwi (ra rs n) + `(rlwinm ,ra ,rs 0 0 (- 31 ,n))) + +(defppcmacro clrrwi. (ra rs n) + `(rlwinm. ,ra ,rs 0 0 (- 31 ,n))) + +(defppcmacro clrlslwi (ra rs b n) + `(rlwinm ,ra ,rs ,n (- ,b ,n) (- 31 ,n))) + +(defppcmacro clrlslwi. (ra rs b n) + `(rlwinm. ,ra ,rs ,n (- ,b ,n) (- 31 ,n))) + +(defppcmacro extldi (ra rs n b) + `(rldicr ,ra ,rs ,b ,n)) + +(defppcmacro extldi. (ra rs n b) + `(rldicr. ,ra ,rs ,b ,n)) + +(defppcmacro extrdi (ra rs n b) + `(rldicl ,ra ,rs (+ ,b ,n) (- 64 ,n))) + +(defppcmacro extrdi. (ra rs n b) + `(rldicl. ,ra ,rs (+ ,b ,n) (- 64 ,n))) + +(defppcmacro insrdi (ra rs n b) + `(rldimi ,ra ,rs (- 64 (+ ,b ,n)) ,b)) + +(defppcmacro insrdi. (ra rs n b) + `(rldimi. ,ra ,rs (- 64 (+ ,b ,n)) ,b)) + +(defppcmacro rotrdi (ra rs n) + `(rldicl ,ra ,rs (- 64 ,n) 0)) + +(defppcmacro rotrdi. (ra rs n) + `(rldicl. ,ra ,rs (- 64 ,n) 0)) + +(defppcmacro sldi (ra rs n) + `(rldicr ,ra ,rs ,n (- 63 ,n))) + +(defppcmacro sldi. (ra rs n) + `(rldicr. ,ra ,rs ,n (- 63 ,n))) + +(defppcmacro srdi (ra rs n) + `(rldicl ,ra ,rs (- 64 ,n) ,n)) + +(defppcmacro srdi. (ra rs n) + `(rldicl. ,ra ,rs (- 64 ,n) ,n)) + +(defppcmacro clrrdi (ra rs n) + `(rldicr ,ra ,rs 0 (- 63 ,n))) + +(defppcmacro clrrdi. (ra rs n) + `(rldicr. ,ra ,rs 0 (- 63 ,n))) + +(defppcmacro clrlsldi (ra rs b sh) + `(rldic ,ra ,rs ,sh (- ,b ,sh))) + +(defppcmacro clrlsldi. (ra rs b sh) + `(rldic. ,ra ,rs ,sh (- ,b ,sh))) + + +;; Vector unit macros +(defppcmacro dssall () + ;;Data stream stop all + `(dss 0 1)) + +(defppcmacro dstt (a b strm) + `(dst ,a ,b ,strm 1)) + +(defppcmacro dststt (a b strm) + `(dstst ,a ,b ,strm 1)) + +(defppcmacro vmr (vd vs) + ;;Analogous to mr for GP registers. Moves contents of vs to vd + `(vor ,vd ,vs ,vs)) + + + + +;; The BA field in an XL form instruction when it must be the same as +;; the BT field in the same instruction. This operand is marked FAKE. +;; The insertion function just copies the BT field into the BA field, +;; and the extraction function just checks that the fields are the +;; same. + +(defun insert-bat (high low val) + (declare (ignore val)) + (values (dpb (ldb (byte 5 (- 21 16)) high) (byte 5 (- 16 16)) high) low)) + +(defun extract-bat (instr) + (if (= (ldb (byte 5 21) instr) (ldb (byte 5 16) instr)) + 0)) + +;; The BB field in an XL form instruction when it must be the same as +;; the BA field in the same instruction. This operand is marked FAKE. +;; The insertion function just copies the BA field into the BB field, +;; and the extraction function just checks that the fields are the +;; same. + +(defun insert-bba (high low val) + (declare (ignore val)) + (values high (dpb (ldb (byte 5 (- 21 16)) high) (byte 5 11) low))) + +(defun extract-bba (instr) + (if (= (ldb (byte 5 16) instr) (ldb (byte 5 11) instr)) + 0)) + +;; The BD field in a B form instruction. The lower two bits are +;; forced to zero. + +(defun insert-bd (high low val) + (values high (logior (logand val #xfffc) (logand low 3)))) + +(defun extract-bd (instr) + (- (logand instr #xfffc) + (if (logbitp 15 instr) ; negative branch displacement + #x10000 + 0))) + +;; The BD field in a B form instruction when the - modifier is used. +;; This modifier means that the branch is not expected to be taken. +;; We must set the y bit of the BO field to 1 if the offset is +;; negative. When extracting, we require that the y bit be 1 and that +;; the offset be positive, since if the y bit is 0 we just want to +;; print the normal form of the instruction. + +(defun insert-bdm (high low val) + (values + (if (logbitp 15 val) (logior high (ash 1 (- 21 16))) high) + (logior (logand val #xfffc) (logand low 3)))) + +(defun extract-bdm (instr) + ;; Recognize this if both the "y" (branch predict false) bit + ;; is set and the displacement is negative. + (if (and (logbitp 15 instr) ; branch disp is negative + (logbitp 21 instr)) ; prediction inverted + (extract-bd instr))) ; return the displacement + +;; The BD field in a B form instruction when the + modifier is used. +;; This is like BDM, above, except that the branch is expected to be +;; taken. + +(defun insert-bdp (high low val) + (values + (if (logbitp 15 val) high (logior high (ash 1 (- 21 16)))) + (logior (logand val #xfffc) (logand low 3)))) + +(defun extract-bdp (instr) + ;; Recognize this if both the "y" (branch predict false) bit + ;; is set and the displacement is non-negative. + (if (and (not (logbitp 15 instr)) ; branch disp is non-negative + (logbitp 21 instr)) ; prediction inverted + (extract-bd instr))) ; return the displacement + +;; return nil if val isn't a valid bo field i.e. if it has any reserved bits set. +(defun valid-bo (val) + (and (= val (ldb (byte 5 0) val)) + (case (logand val #x14) + (4 (not (logbitp 1 val))) + (#x10 (not (logbitp 3 val))) + (#x14 (= val #x14)) + (t t)))) + +;; The BO field in a B form instruction. Fail on attempts to set +;; the field to an illegal value. +(defun insert-bo (high low val) + (if (valid-bo val) + (values (dpb val (byte 5 (- 21 16)) high) low))) + +(defun extract-bo (instr) + (let* ((val (ldb (byte 5 21) instr))) + (and (valid-bo val) val))) + +;; The BO field in a B form instruction when the + or - modifier is +;; used. This is like the BO field, but it must be even. When +;; extracting it, we force it to be even. + +(defun insert-boe (high low val) + (unless (logbitp 0 val) (insert-bo high low val))) + +(defun extract-boe (instr) + (let* ((val (extract-bo instr))) + (if val (logandc2 val 1)))) + +;; The condition register number portion of the BI field in a B form +;; or XL form instruction. This is used for the extended conditional +;; branch mnemonics, which set the lower two bits of the BI field. It +;; is the BI field with the lower two bits ignored. + +(defun insert-cr (high low val) + (values (dpb (ash val -2) (byte 3 (- 18 16)) high) low)) + +(defun extract-cr (instr) + (logandc2 (ldb (byte 5 16) instr) 3)) + +(defun insert-bf (high low val) + (values (dpb (ash val -2) (byte 3 (- 23 16)) high) low)) + +(defun extract-bf (instr) + (logandc2 (ldb (byte 5 21) instr) 3)) + + +;; The DS field in a DS form instruction. This is like D, but the +;; lower two bits are forced to zero. +(defun insert-ds (high low val) + (when (logtest #b11 val) + (warn "low two bits of operand #x~8,'0x must be zero - clearing." + val)) + (values high (logior low (logand val #xfffc)))) + +(defun extract-ds (instr) + (- (logand instr #xfffc) (if (logbitp 15 instr) #x10000 0))) + +;; The LI field in an I form instruction. The lower two bits are +;; forced to zero. + +(defun insert-li (high low val) + (values (dpb (ash val -16) (byte 10 (- 16 16)) high) (logior (logand val #xfffc) (logand low 3)))) + +(defun extract-li (instr) + (- (logand instr #x3fffffc) (if (logbitp 25 instr) #x4000000 0))) + +;; The MB and ME fields in an M form instruction expressed as a single +;; operand which is itself a bitmask. The extraction function always +;; marks it as invalid, since we never want to recognize an +;; instruction which uses a field of this type. + +#| +(defun insert-mbe (instr val) + (let* ((uval val) + (me 31)) + (declare (integer uval) + (fixnum me)) + (when (/= uval 0) + (do () + ((logbitp 0 uval)) + (setq uval (ash uval -1)) + (decf me)) + (let* ((nbits (logcount uval)) + (mb (- (1+ me) nbits))) + (declare (fixnum nbits mb)) + (when (= nbits (integer-length uval)) + (dpb me (byte 5 1) (dpb mb (byte 5 6) instr))))))) + + +(defun extract-mbe (instr) + (declare (ignore instr))) + +;; The MB or ME field in an MD or MDS form instruction. The high bit +;; is wrapped to the low end. + + +|# + +;; The NB field in an X form instruction. The value 32 is stored as +;; 0. + +(defun insert-nb (high low val) + (if (<= 0 val 32) + (values high (dpb val (byte 5 11) low)))) + +(defun extract-nb (instr) + (let* ((val (ldb (byte 5 11) instr))) + (declare (fixnum val)) + (if (= val 0) 32 val))) + +;; The NSI field in a D form instruction. This is the same as the SI +;; field, only negated. The extraction function always marks it as +;; invalid, since we never want to recognize an instruction which uses +;; a field of this type. +(defun insert-nsi (high low val) + (declare (ignore low)) + (values high (logand (- val) #xffff))) + +(defun extract-nsi (instr) + (declare (ignore instr))) + +;; The RA field in a D or X form instruction which is an updating +;; load, which means that the RA field may not be zero and may not +;; equal the RT field. + +(defun insert-ral (high low val) + (and (/= val 0) + (/= val (ldb (byte 5 (- 21 16)) high)) + (values (dpb val (byte 5 (- 16 16)) high) low))) + +;; The RA field in an lmw instruction, which has special value +;; restrictions. +(defun insert-ram (high low val) + (if (< val (ldb (byte 5 (- 21 16)) high)) + (values (dpb val (byte 5 (- 16 16)) high) low))) + +;; The RA field in a D or X form instruction which is an updating +;; store or an updating floating point load, which means that the RA +;; field may not be zero. + +(defun insert-ras (high low val) + (unless (= val 0) + (values (dpb val (byte 5 (- 16 16)) high) low))) + +;; The RB field in an X form instruction when it must be the same as +;; the RS field in the instruction. This is used for extended +;; mnemonics like mr. This operand is marked FAKE. The insertion +;; function just copies the BT field into the BA field, and the +;; extraction function just checks that the fields are the same. + +(defun insert-rbs (high low val) + (declare (ignore val)) + (values high (dpb (ldb (byte 5 (- 21 16)) high) (byte 5 11) low))) + +(defun extract-rbs (instr) + (if (= (ldb (byte 5 21) instr) (ldb (byte 5 11) instr)) + 0)) + +;; The SH field in an MD form instruction. This is split. +(defun insert-sh6 (high low val) + (values high + (dpb (ldb (byte 5 0) val) (byte 5 11) + (dpb (ldb (byte 1 5) val) (byte 1 1) low)))) + +(defun extract-sh6 (instr) + (logior (ldb (byte 5 11) instr) (ash (ldb (byte 1 1) instr) 5))) + + +(defun insert-mb6 (high low val) + (values high + (dpb (ldb (byte 1 5) val) + (byte 1 5) + (dpb val (byte 5 6) low)))) + +(defun extract-mb6 (instr) + (dpb (ldb (byte 1 5) instr) + (byte 1 5) + (ldb (byte 5 6) instr))) + + +;; The SPR or TBR field in an XFX form instruction. This is +;; flipped--the lower 5 bits are stored in the upper 5 and vice- +;; versa. +(defun insert-spr (high low val) + (values (dpb val (byte 5 (- 16 16)) high) + (logior low (ash (logand val #x3e0) 6)))) + + +(defun extract-spr (instr) + (logior (ldb (byte 5 16) instr) (logand #x3e0 (ash instr -6)))) + +(defun insert-default (operand high low val) + (let* ((width (ccl::operand-width operand)) + (offset (ccl::operand-offset operand)) + (msbit (1- (+ width offset)))) + (declare (fixnum width offset msbit)) + (if (>= offset 16) + (values (dpb val (byte width (- offset 16)) high) low) + (if (< msbit 16) + (values high (dpb val (byte width offset) low)) + (let* ((lowbits (- 16 offset))) + (values + (dpb (the fixnum (ash val (the fixnum (- lowbits)))) + (byte (the fixnum (- width lowbits)) 0) + high) + (dpb val (byte lowbits offset) low))))))) + + +(defun extract-default (operand instr) + (let* ((width (ccl::operand-width operand)) + (op (ldb (byte width (ccl::operand-offset operand)) instr))) + (if (and (logbitp $ppc-operand-signed (ccl::operand-flags operand)) + (logbitp (1- width) op)) + (- op (ash 1 width)) + op))) + + + + + +(defun ccl::lookup-ppc-opcode (name) + (gethash (string name) ppc::*ppc-opcode-numbers*)) + +(provide "PPC-ASM") Index: /branches/experimentation/later/source/compiler/PPC/ppc-backend.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc-backend.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc-backend.lisp (revision 8058) @@ -0,0 +1,238 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 *ppc2-specials* nil) +(let* ((newsize (%i+ (next-nx-num-ops) 10)) + (old *ppc2-specials*) + (oldsize (length old))) + (declare (fixnum newsize oldsize)) + (unless (>= oldsize newsize) + (let* ((v (make-array newsize :initial-element nil))) + (dotimes (i oldsize (setq *ppc2-specials* v)) + (setf (svref v i) (svref old i)))))) + +;;; This defines a template. All expressions in the body must be +;;; evaluable at macroexpansion time. +(defun define-ppc-vinsn (backend vinsn-name results args temps body) + (let* ((opcode-vector (backend-lap-opcodes backend)) + (opcode-lookup (backend-lookup-opcode backend)) + (opcode-expander (backend-lookup-macro 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)) + (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-operand (op) + (if (atom op) + (if (typep op 'fixnum) + op + (if (constantp op) + (progn + (if (keywordp op) + (pushnew op referenced-labels)) + (eval op)) + (find-name op))) + (if (eq (car op) :apply) + `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) + (simplify-operand (eval op)))))) ; Handler-case this? + (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) + form + (let* ((name (string opname)) + (opnum (funcall opcode-lookup name))) + (if (and (not opnum) opcode-expander) + (let* ((expander (funcall opcode-expander name))) + (if expander + (simplify-form (funcall expander form nil)) + (error "Unknown ~A instruction in ~s" backend-name form))) + (let* ((opcode (if (< -1 opnum (length opcode-vector)) + (svref opcode-vector opnum) + (error "~& Invalid ~A opcode: ~s" backend-name name))) + (opvals (mapcar #'simplify-operand opvals))) + (setf (assq opnum opcode-alist) name) + (let* ((operands (opcode-vinsn-operands opcode)) + (nmin (opcode-min-vinsn-args opcode)) + (nmax (opcode-max-vinsn-args opcode)) + (nhave (length opvals))) + (declare (fixnum nreq nhave)) + (if (= nhave nmax) + `(,opnum ,@opvals) + (if (> nhave nmax) + (error "Too many operands in ~s (~a accepts at most ~d)" + (cdr w) name nmax) + (if (= nhave nmin) + (let* ((newops ())) + (dolist (op operands `(,opnum ,@(nreverse newops))) + (let* ((flags (operand-flags op))) + (unless (logbitp operand-fake flags) + (push (if (logbitp operand-optional flags) + 0 + (pop opvals)) + newops))))) + (error "Too few operands in ~s : (~a requires at least ~d)" + (cdr w) name nmin)))))))))))))) + (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)))))))))) + +#+ppc32-target +(require "PPC32-BACKEND") +#+ppc64-target +(require "PPC64-BACKEND") + +(defparameter *ppc-backend* + #+ppc32-target *ppc32-backend* + #+ppc64-target *ppc64-backend* + #-(or ppc32-target ppc64-target) + nil) + + + +(defun fixup-ppc-backend (&rest args) + #+ppc32-target (apply #'fixup-ppc32-backend args) + #+ppc64-target (apply #'fixup-ppc64-backend args)) + + Index: /branches/experimentation/later/source/compiler/PPC/ppc-disassemble.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc-disassemble.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc-disassemble.lisp (revision 8058) @@ -0,0 +1,430 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "NXENV") + (require "DLL-NODE") + (require "PPC-ASM") + (require "PPC-LAP")) + +(defparameter *ppc-disassembly-backend* *host-backend*) +(defparameter *ppc-disassemble-raw-instructions* nil) + +(eval-when (:compile-toplevel :execute) + (require "PPCENV")) + +(defun ppc-gpr (r) + (or + (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc32 (and (eql r ppc32::rcontext) 'ppc32::rcontext)) + (:ppc64 (and (eql r ppc64::rcontext) 'ppc64::rcontext))) + (svref ppc::*gpr-register-names* r))) + +(defun ppc-fpr (r) + (svref ppc::*fpr-register-names* r)) + +(defun ppc-vr (r) + (svref ppc::*vector-register-names* r)) + +;;; To "unmacroexpand" something is to undo the effects of +;;; some sort of macroexpansion, returning some presumably +;;; more meaningful equivalent form. Some cases of this +;;; are trivial (e.g., turning (stwu rX -4 vsp) into (vpush rX); +;;; some would depend on surrounding context and are still +;;; heuristic. A few cases can probably benefit from state +;;; maintained by preceding instructions, e.g., (twnei rX 1) +;;; is presumably looking at the low 2 or three bits of rX; we +;;; have to know what set rX to know which. + +;;; For now, just try to handle a few simple cases. +;;; Return a new form (new-opcode-name &rest new-operands) or NIL. +;;; + +(defparameter *ppc-unmacroexpanders* (make-hash-table :test #'equalp)) + +(defun ppc-unmacroexpand-function (name) + (let* ((pname (string name)) + (opnum (gethash pname ppc::*ppc-opcode-numbers*))) + (unless opnum (error "Unknown ppc opcode name ~s." name)) + (values (gethash pname *ppc-unmacroexpanders*)))) + +(defun (setf ppc-unmacroexpand-function) (def name) + (let* ((pname (string name)) + (opnum (gethash pname ppc::*ppc-opcode-numbers*))) + (unless opnum (error "Unknown ppc opcode name ~s." name)) + (setf (gethash pname *ppc-unmacroexpanders*) def))) + +(defmacro def-ppc-unmacroexpand (name insn-var lambda-list &body body) + `(setf (ppc-unmacroexpand-function ',name) + #'(lambda (,insn-var) + (destructuring-bind ,lambda-list (lap-instruction-parsed-operands ,insn-var) + ,@body)))) + +(def-ppc-unmacroexpand stwu insn (rs d ra) + (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc32 + (if (and (= ra ppc::vsp) (= d -4)) + `(vpush ,(ppc-gpr rs)))))) + +(def-ppc-unmacroexpand stdu insn (rs d ra) + (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc64 + (if (and (= ra ppc::vsp) (= d -8)) + `(vpush ,(ppc-gpr rs)))))) + +(def-ppc-unmacroexpand rlwinm insn (rt ra b mb &optional (me mb me-p)) + (if (not me-p) + (setq mb 0)) ; That's what's happening now to fake operands. + (if (and (= me 31) (= (+ b mb) 32)) + `(srwi ,(ppc-gpr rt) ,(ppc-gpr ra) ,mb) + (if (and (= mb 0) (= (+ b me) 31)) + (if (and (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc32 t)) + (logbitp rt ppc-node-regs) + (not (logbitp ra ppc-node-regs)) + (= b (arch::target-fixnum-shift (backend-target-arch + *ppc-disassembly-backend*)))) + `(box-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra)) + `(slwi ,(ppc-gpr rt) ,(ppc-gpr ra) ,b))))) + +(def-ppc-unmacroexpand rldicr insn (rt ra sh me) + (if (= (+ sh me) 63) + (if (and (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc64 t)) + (logbitp rt ppc-node-regs) + (not (logbitp ra ppc-node-regs)) + (= sh (arch::target-fixnum-shift (backend-target-arch + *ppc-disassembly-backend*)))) + `(box-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra)) + `(sldi ,(ppc-gpr rt) ,(ppc-gpr ra) ,sh)))) + +(def-ppc-unmacroexpand rldicl insn (rt ra sh mb) + (if (= (+ sh mb) 64) + `(srdi ,(ppc-gpr rt) ,(ppc-gpr ra) ,mb))) + +(def-ppc-unmacroexpand srawi insn (rt ra sh) + (if (and (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc32 t)) + (not (logbitp rt ppc-node-regs)) + (logbitp ra ppc-node-regs) + (= sh (arch::target-fixnum-shift (backend-target-arch + *ppc-disassembly-backend*)))) + `(unbox-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra)))) + +(def-ppc-unmacroexpand sradi insn (rt ra sh) + (if (and (case (backend-target-arch-name *ppc-disassembly-backend*) + (:ppc64 t)) + (not (logbitp rt ppc-node-regs)) + (logbitp ra ppc-node-regs) + (= sh (arch::target-fixnum-shift (backend-target-arch + *ppc-disassembly-backend*)))) + `(unbox-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra)))) + +(def-ppc-unmacroexpand li insn (rt imm) + (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*)))) + (if (not (logtest (1- (ash 1 fixnumshift)) imm)) + (if (logbitp rt ppc-node-regs) + `(li ,(ppc-gpr rt) ',(ash imm (- fixnumshift))) + (if (eql rt ppc::nargs) + `(set-nargs ,(ash imm (- fixnumshift)))))))) + + + +(def-ppc-unmacroexpand cmpwi insn (crf ra simm) + (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*)))) + (if (and (not (logtest (1- (ash 1 fixnumshift)) simm)) + (logbitp ra ppc-node-regs)) + `(cmpwi ,@(unless (eql 0 crf) `(,(aref *ppc-cr-names* (ash crf -2)))) + ,(ppc-gpr ra) + ',(ash simm (- fixnumshift)))))) + +(def-ppc-unmacroexpand cmpdi insn (crf ra simm) + (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*)))) + (if (and (not (logtest (1- (ash 1 fixnumshift)) simm)) + (logbitp ra ppc-node-regs)) + `(cmpdi ,@(unless (eql 0 crf) `(,(aref *ppc-cr-names* (ash crf -2)))) + ,(ppc-gpr ra) + ',(ash simm (- fixnumshift)))))) + +(def-ppc-unmacroexpand addi insn (rd ra simm) + (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*))) + (disp-d (ppc-gpr rd)) + (disp-a (ppc-gpr ra))) + (if (or (eql ra ppc::sp) + (eql ra ppc::tsp) + (eql ra ppc::vsp)) + `(la ,disp-d ,simm ,disp-a) + (let* ((opcode 'addi) + (val (abs simm))) + (if (< simm 0) + (setq opcode 'subi)) + (if (and (not (logtest (1- (ash 1 fixnumshift)) simm)) + (logbitp rd ppc-node-regs) + (logbitp ra ppc-node-regs)) + `(,opcode ,disp-d ,disp-a ',(ash val (- fixnumshift))) + `(,opcode ,disp-d ,disp-a ,(if (eq val + (arch::target-nil-value (backend-target-arch *ppc-disassembly-backend*))) nil val))))))) + +(defun ppc-unmacroexpand (insn) + (unless *ppc-disassemble-raw-instructions* + (let* ((expander (ppc-unmacroexpand-function (opcode-name (lap-instruction-opcode insn)))) + (expansion (if expander (funcall expander insn)))) + (when expansion + (setf (lap-instruction-opcode insn) (car expansion) + (lap-instruction-parsed-operands insn) (cdr expansion)) + expansion)))) + + +(defun find-ppc-opcode (i) + (let* ((op (ldb (byte 6 26) i)) + (k (svref ppc::*ppc-opcode-indices* op))) + (declare (type (unsigned-byte 12) k) + (type (unsigned-byte 6) op)) + (unless (= k -1) + (dotimes (j (svref ppc::*ppc-opcode-counts* op)) + (declare (type (unsigned-byte 10) j)) + (let* ((code (svref ppc::*ppc-opcodes* (+ k j)))) + (if (= (logand (opcode-mask code) i) + (opcode-opcode code)) + (if (dolist (op (opcode-operands code) t) + (let* ((xfun (operand-extract-function op))) + (unless (or (null xfun) + (funcall xfun i)) + (return nil)))) + (return code)))))))) + +(defun ppc-disasm-1 (i pc header) + (let* ((opcode (find-ppc-opcode i))) + (if (null opcode) + (error "Unknown PPC instruction : #x~8,'0x" i) ; should handle somehow + (let* ((vals ())) + (dolist (operand (opcode-operands opcode)) + (unless (logbitp operand-fake (operand-flags operand)) + (let* ((extract-fn (operand-extract-function operand))) + (push (if extract-fn + (funcall extract-fn i) + (ppc::extract-default operand i)) + vals)))) + (let* ((insn (%make-lap-instruction opcode))) + (setf (lap-instruction-parsed-operands insn) + (nreverse vals)) + (setf (lap-instruction-address insn) + pc) + (append-dll-node insn header)))))) + + +(defvar *disassembled-ppc-instructions* ()) +(defvar *disassembled-ppc-labels* ()) + + + +(defun ppc-label-at-address (address) + (dolist (l *disassembled-ppc-labels* + (let* ((label (%make-lap-label (intern (format nil "L~d" address))))) + (setf (lap-label-address label) address) + (push label *disassembled-ppc-labels*) + label)) + (when (= address (lap-label-address l)) + (return l)))) + +(defun insert-ppc-label (l instructions) + (let* ((labaddr (lap-label-address l))) + (do-dll-nodes (insn instructions (append-dll-node l instructions)) + (when (>= (lap-instruction-address insn) labaddr) + (return (insert-dll-node-after l (lap-instruction-pred insn))))))) + +(defun ppc-disassemble-cr (val operand-spec) + (declare (type (mod 32) val)) + (let* ((width (operand-width operand-spec)) + (crnum (ash val -2)) + (ccnum (logand val 3))) + (declare (fixnum width crnum ccnum)) + (if (= width 3) + (unless (= crnum 0) (aref *ppc-cr-names* crnum)) + (if (= ccnum 0) + (unless (= crnum 0) (aref *ppc-cr-names* crnum)) + (list (aref *ppc-cr-field-names* crnum) (aref *ppc-cc-bit-names* ccnum)))))) + +(defun ppc-analyze-operands (instructions constants) + (let* ((pc 0) + (regsave-pseudo nil) + (arch (backend-target-arch *ppc-disassembly-backend*)) + (nil-value (arch::target-nil-value arch)) + (misc-data-offset (arch::target-misc-data-offset arch)) + (word-shift (arch::target-word-shift arch)) + (align-mask (1- (ash 1 word-shift)))) + (declare (fixnum pc)) + (let* ((last (dll-header-last instructions))) + (when (eq (lap-instruction-opcode last) *ppc-lwz-instruction*) + (remove-dll-node last) + (setq regsave-pseudo last))) + (do-dll-nodes (insn instructions) + (unless (ppc-unmacroexpand insn) + (let* ((opcode (lap-instruction-opcode insn)) + (opvalues (lap-instruction-parsed-operands insn))) + (do* ((operands (opcode-operands opcode) (cdr operands)) + (operand (car operands) (car operands)) + (header (cons nil opvalues)) + (tail header)) + ((null operands) (setf (lap-instruction-parsed-operands insn) (cdr header))) + (declare (dynamic-extent header)) + (let* ((flags (operand-flags operand)) + (opidx (operand-index operand)) + (val (cadr tail))) + (declare (fixnum flags)) + (if (and (logbitp operand-optional flags) + (eql 0 val)) + (rplacd tail (cddr tail)) + (progn + (if (and (or (eq opidx ppc::$si) + (eq opidx ppc::$nsi) + (eq opidx ppc::$ui)) + (eql val nil-value)) + (setf (cadr tail) nil) + (if (logbitp ppc::$ppc-operand-relative flags) + (let* ((label (ppc-label-at-address (+ pc val)))) + (setf (cadr tail) (lap-label-name label))) + (if (logbitp ppc::$ppc-operand-cr flags) + (let* ((cr (ppc-disassemble-cr val operand))) + (when cr (setf (cadr tail) cr))) + (if (logbitp ppc::$ppc-operand-absolute flags) + (let* ((info (find val ppc::*ppc-subprims* :key #'subprimitive-info-offset))) + (when info (setf (cadr tail) (subprimitive-info-name info)))) + (if (logbitp ppc::$ppc-operand-fpr flags) + (setf (cadr tail) (ppc-fpr val)) + (if (logbitp ppc::$ppc-operand-vr flags) ; SVS + (setf (cadr tail) (ppc-vr val)) + (when (logbitp ppc::$ppc-operand-gpr flags) + (setf (cadr tail) (ppc-gpr val)) + (when (eq val ppc::fn) + (let* ((disp (car tail))) + (when (and disp (typep disp 'fixnum)) + (let* ((unscaled (+ (- misc-data-offset) disp))) + (unless (logtest align-mask unscaled) + (let* ((idx (ash unscaled (- word-shift)))) + (if (< idx (uvsize constants)) + (rplaca tail (list 'quote (uvref constants idx))))))))))))))))) + (setq tail (cdr tail)))))))) + (incf pc 4)) + (dolist (l *disassembled-ppc-labels*) (insert-ppc-label l instructions)) + (when regsave-pseudo + (destructuring-bind (reg offset pc) (lap-instruction-parsed-operands regsave-pseudo) + (declare (fixnum reg offset pc)) + (let* ((nregs (- 32 reg))) + (declare (fixnum nregs)) + (setq pc (ash (the fixnum (dpb (ldb (byte 2 0) offset) (byte 2 5) pc)) 2) + offset (- (logand (lognot 3) (- offset)) (ash nregs target::word-shift)))) + (setf (lap-instruction-opcode regsave-pseudo) :regsave + (lap-instruction-parsed-operands regsave-pseudo) + (list (ppc-gpr reg) offset) + (lap-instruction-address regsave-pseudo) pc) + (do-dll-nodes (node instructions) + (when (>= (lap-instruction-address node) pc) + (insert-dll-node-after regsave-pseudo (dll-node-pred node)) + (return))))))) + + +; This returns a doubly-linked list of INSTRUCTION-ELEMENTs; the caller (disassemble, INSPECT) +; can format the contents however it wants. +(defun disassemble-ppc-function (code-vector constants-vector &optional (start-word 0)) + (let* ((*disassembled-ppc-labels* nil) + (header (make-dll-header))) + (let* ((n (uvsize code-vector))) + (declare (fixnum n)) + (do* ((i start-word (1+ i)) + (pc 0 (+ pc 4))) + ((= i n)) + (declare (fixnum i)) + (let* ((opcode (uvref code-vector i))) + (declare (integer opcode)) + (if (= opcode 0) + (return) + (ppc-disasm-1 opcode pc header)))) + (ppc-analyze-operands header constants-vector)) + header)) + +(defun print-ppc-instruction (stream tabcount opcode parsed-operands) + (let* ((name (if (symbolp opcode) opcode (opcode-name opcode)))) + (if (keywordp name) + (format stream "~&~V,t(~s" tabcount name) + (format stream "~&~V,t(~a" tabcount name)) + (dolist (op parsed-operands (format stream ")")) + (format stream (if (and (consp op) (eq (car op) 'quote)) " ~s" " ~a") op)))) + +(defun print-ppc-instructions (stream instructions &optional for-lap backend) + (declare (ignorable backend)) + (let* ((tab (if for-lap 6 2))) + (when for-lap + (let* ((lap-function-name (car for-lap))) + (format stream "~&(~S ~S ~& (~S (~s) ~& (~s ~s ()" + 'nfunction lap-function-name 'lambda '&lap 'ppc-lap-function lap-function-name))) + (do-dll-nodes (i instructions) + (etypecase i + (lap-label (format stream "~&~a " (lap-label-name i))) + (lap-instruction + (print-ppc-instruction stream tab (lap-instruction-opcode i) (lap-instruction-parsed-operands i))))) + (when for-lap (format stream ")))~&")))) + + +(defun ppc-Xdisassemble (fn-vector &key (for-lap nil) (stream *standard-output*) target ((:raw *ppc-disassemble-raw-instructions*) nil)) + (let* ((backend (if target (find-backend target) *host-backend*)) + (prefix-length (length (arch::target-code-vector-prefix (backend-target-arch backend)))) + (*ppc-disassembly-backend* backend)) + (print-ppc-instructions stream (function-to-dll-header fn-vector prefix-length) + (if for-lap (list (uvref fn-vector (- (uvsize fn-vector) 2))))) + (values))) + +(defun function-to-dll-header (fn-vector &optional (prefix #+ppc32-target 0 #+ppc64-target 1)) + (let* ((codev (uvref fn-vector 0))) + (disassemble-ppc-function codev fn-vector prefix))) + + +(defun disassemble-list (thing) + (let ((dll (function-to-dll-header (function-for-disassembly thing))) + (address 0) + (label-p nil) + (res nil)) + (do-dll-nodes (i dll) + (setq address (instruction-element-address i)) + (etypecase i + (lap-label + (setq label-p (lap-label-name i))) + (lap-instruction + (let ((opcode (lap-instruction-opcode i)) + (operands (lap-instruction-parsed-operands i))) + (push (list* (if label-p `(label ,address) address) + (if (symbolp opcode) opcode (opcode-name opcode)) + operands) + res) + (setq label-p nil))))) + (nreverse res))) + +#+ppc-target +(defun disasm-prin1 (thing stream) + (if (and (consp thing) (consp (cdr thing)) (null (cddr thing))) + (cond ((eq (%car thing) 'quote) + (prin1 thing stream)) + ((eq (%car thing) 'function) + (format stream "#'~S" (cadr thing))) + ((eq (%car thing) 16) + (format stream "#x~X" (cadr thing))) + ((eq (%car thing) 'label) + (let ((*print-radix* nil)) + (princ (cadr thing) stream))) + (t (princ thing stream))) + (princ thing stream))) + + Index: /branches/experimentation/later/source/compiler/PPC/ppc-lap.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc-lap.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc-lap.lisp (revision 8058) @@ -0,0 +1,683 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPC32-ARCH") + (require "PPC64-ARCH") + (require "RISC-LAP") + (require "DLL-NODE") + (require "PPC-ASM") + (require "SUBPRIMS")) + + +(defun ppc-lap-macro-function (name) + (gethash (string name) (backend-lap-macros *ppc-backend*))) + +(defun (setf ppc-lap-macro-function) (def name) + (let* ((s (string name))) + (when (gethash s ppc::*ppc-opcode-numbers*) + (error "~s already defines a PowerPC instruction . " name)) + (when (ppc::ppc-macro-function s) + (error "~s already defines a PowerPC macro instruction . " name)) + (setf (gethash s (backend-lap-macros *ppc-backend*)) def))) + +(defmacro defppclapmacro (name arglist &body body) + `(progn + (setf (ppc-lap-macro-function ',name) + (nfunction (ppc-lap-macro ,name) ,(parse-macro name arglist body))) + (record-source-file ',name 'ppc-lap) + ',name)) + +(defvar *ppc-lap-constants* ()) +(defvar *ppc-lap-regsave-reg* ()) +(defvar *ppc-lap-regsave-addr* ()) +(defvar *ppc-lap-regsave-label* ()) +(defparameter *ppc-lwz-instruction* (svref ppc::*ppc-opcodes* (gethash "LWZ" ppc::*ppc-opcode-numbers*))) +(defvar *ppc-lap-lfun-bits* 0) + + + + + +(defun ppc-lap-macroexpand-1 (form) + (unless (and (consp form) (atom (car form))) + (values form nil)) + (let* ((expander (ppc-lap-macro-function (car form)))) + (if expander + (values (funcall expander form nil) t) + (values form nil)))) + + + +(defun ppc-lap-encode-regsave-info (maxpc) + (declare (fixnum maxpc)) + (if *ppc-lap-regsave-label* + (let* ((regsave-pc (ash (the fixnum (lap-label-address *ppc-lap-regsave-label*)) -2))) + (declare (fixnum regsave-pc)) + (if (< regsave-pc #x80) + (let* ((instr (ppc-emit-lap-instruction *ppc-lwz-instruction* + (list *ppc-lap-regsave-reg* + (dpb (ldb (byte 2 5) regsave-pc) + (byte 2 0) + *ppc-lap-regsave-addr*) + (ldb (byte 5 0) regsave-pc))))) + (setf (lap-instruction-address instr) maxpc) + (incf maxpc 4)) + (warn "Can't encode register save information.")))) + maxpc) + +(defun %define-ppc-lap-function (name body &optional (bits 0)) + (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*) + (let* ((*lap-labels* ()) + (*ppc-lap-regsave-label* ()) + (*ppc-lap-regsave-reg* ()) + (*ppc-lap-regsave-addr* ()) + (*ppc-lap-constants* ()) + (*ppc-lap-lfun-bits* bits)) + (dolist (form body) + (ppc-lap-form form)) + #+ppc-lap-scheduler (ppc-schedule-instuctions) ; before resolving branch targets + (ppc-lap-generate-code name (ppc-lap-encode-regsave-info (ppc-lap-do-labels)) *ppc-lap-lfun-bits*)))) + +;;; Any conditional branch that the compiler generates is currently just of the form +;;; BT or BF, but it'd be nice to recognize all of the other extended branch mnemonics +;;; as well. +;;; A conditional branch is "conditional" if bit 2 of the BO field is set. +(defun ppc-lap-conditional-branch-p (insn) + (let* ((opcode (lap-instruction-opcode insn))) + (if (= (the fixnum (opcode-majorop opcode)) 16) ; it's a BC instruction ... + (unless (logbitp 1 (the fixnum (opcode-op-low opcode))) ; not absolute + (let* ((bo-field (if (= #xf (ldb (byte 4 6) (the fixnum (opcode-mask-high opcode)))) + (ldb (byte 5 5) (the fixnum (opcode-op-high opcode))) + (svref (lap-instruction-parsed-operands insn) 0)))) + (declare (fixnum bo-field)) + (if (logbitp 2 bo-field) + bo-field)))))) + +;;; Turn an instruction that's of the form +;;; (bc[l] bo bi label) +;;; into the sequence +;;; (bc (invert bo) bi @new) +;;; (b[l] label) +;;; @new +;;; Do so only if the instruction's a conditional branch +;;; and the label is more than 16 bits away from the instruction. +;;; Return true if we do this, false otherwise. +(defun ppc-lap-invert-conditional-branch (insn label) + (if (ppc-lap-conditional-branch-p insn) + (let* ((diff (- (lap-label-address label) (lap-instruction-address insn)))) + (declare (fixnum diff)) + (if (or (< diff #x-8000) (> diff #x7ffc)) + ; Too far away, will have to invert. + ; It's necessary to "partially assemble" the BC instruction in order to + ; get explicit values for the BO and BI fields of the instruction. + (let* ((original-opcode (lap-instruction-opcode insn)) + (vals (lap-instruction-parsed-operands insn)) + (high (opcode-op-high original-opcode)) + (low (opcode-op-low original-opcode)) + (link-p (logbitp 0 low)) + (new-label (make-lap-label (gensym))) + (idx -1)) + (declare (fixnum high low)) + ; Assemble all operands but the last + (do* ((ops (opcode-operands original-opcode) next) + (next (cdr ops) (cdr next))) + ((null next)) + (declare (list ops next)) + (let* ((operand (car ops)) + (val (if (logbitp operand-fake (operand-flags operand)) + 0 + (svref vals (incf idx)))) + (insert-function (operand-insert-function operand))) + (setq high (if insert-function + (funcall insert-function high low val) + (ppc::insert-default operand high low val))))) + ;; "high" now contains the major opcode, BO, and BI fields + ;; of the original branch instruction. Generate a (BC + ;; (invert BO) BI new-label) instruction, and insert it + ;; before the original instruction. + (let* ((bc-opcode (svref ppc::*ppc-opcodes* (gethash "BC" ppc::*ppc-opcode-numbers*))) + (bo (logxor #b1000 (the fixnum (ldb (byte 5 5) high)))) + (bi (ldb (byte 5 0) high)) + (new-instruction (make-lap-instruction bc-opcode)) + (opvect (alloc-lap-operand-vector))) + (setf (lap-instruction-parsed-operands new-instruction) opvect + (svref opvect 0) bo + (svref opvect 1) bi + (svref opvect 2) new-label) + (push new-instruction (lap-label-refs new-label)) + (insert-dll-node-after new-instruction (dll-node-pred insn)) + (insert-dll-node-after new-label insn)) + ;; Now, change INSN's opcode to B or BL, and make sure that + ;; it references nothing but the old label. + (let* ((long-branch (svref ppc::*ppc-opcodes* (gethash (if link-p "BL" "B") ppc::*ppc-opcode-numbers*))) + (opvect (alloc-lap-operand-vector))) + (setf (svref opvect 0) label + (lap-instruction-opcode insn) long-branch + (lap-instruction-parsed-operands insn) opvect) + ;; We're finally done. Return t. + t)))))) + + +; Build & return list of all labels that are targets of conditional branches. +(defun ppc-lap-conditional-branch-targets () + (let* ((branch-target-labels ())) + (do-lap-labels (lab branch-target-labels) + (dolist (insn (lap-label-refs lab)) + (when (ppc-lap-conditional-branch-p insn) + (push lab branch-target-labels)))))) + +(defun ppc-lap-assign-addresses (delete-labels-p) + (let* ((pc 0)) + (declare (fixnum pc)) + (do-dll-nodes (node *lap-instructions*) + (setf (instruction-element-address node) pc) + (if (typep node 'lap-label) + (if delete-labels-p (remove-dll-node node)) + (incf pc 4))) + ;; Don't bother checking code-vector size yet. + pc)) + +;;; The function's big enough that we might have generated conditional +;;; branches that are too far away from their targets. Find the set +;;; of all labels that are the target of conditional branches, then +;;; repeatedly assign (tentative) addresses to all instructions and +;;; labels and iterate over the set of conditional branch targets, +;;; "lengthening" any condtional branches that are too far away from +;;; the target label. Since lengthening a branch instruction can +;;; cause a spanning branch to become a candidate for lengthening, we +;;; have to repeat the process until all labels are the targets of +;;; valid (short enough or unconditional) branch instructions. +(defun ppc-lap-remove-long-branches () + (let* ((branch-target-labels (ppc-lap-conditional-branch-targets))) + (do* ((done nil)) + (done (ppc-lap-assign-addresses t)) + (setq done t) + (ppc-lap-assign-addresses nil) + (dolist (lab branch-target-labels) + (dolist (insn (lap-label-refs lab)) + (when (ppc-lap-invert-conditional-branch insn lab) + (setq done nil))))))) + +(defun ppc-lap-do-labels () + (do-lap-labels (lab) + (if (and (lap-label-refs lab) (not (lap-label-emitted-p lab))) + (error "Label ~S was referenced but never defined. " + (lap-label-name lab))) + ;; Repeatedly iterate through label's refs, until none of them is + ;; the preceding instruction. This eliminates + ;; (b @next) + ;;@next + ;; + ;; but can probably be fooled by hairier nonsense. + (loop + (when (dolist (ref (lap-label-refs lab) t) + (when (eq lab (lap-instruction-succ ref)) + (remove-dll-node ref) + (setf (lap-label-refs lab) (delete ref (lap-label-refs lab))) + (return))) + (return)))) + ;; Assign pc to emitted labels, splice them out of the list. + + (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191) + ;; -Might- have some conditional branches that are too long. + ;; Definitely don't otherwise, so only bother to check in this case + (ppc-lap-remove-long-branches) + (ppc-lap-assign-addresses t))) + +;;; Replace each label with the difference between the label's address +;;; and the referencing instruction's address. +(defun ppc-lap-resolve-labels () + (do-lap-labels (label) + (let* ((label-address (lap-label-address label))) + (declare (fixnum label-address)) ; had BETTER be ... + (dolist (insn (lap-label-refs label)) + (let* ((diff (- label-address (lap-instruction-address insn)))) + (declare (fixnum diff)) + (let* ((opvals (lap-instruction-parsed-operands insn)) + (pos (position label opvals))) + (unless pos + (error "Bug: label ~s should be referenced by instruction ~s, but isn't.")) + (setf (svref opvals pos) diff))))))) + +(defun ppc-lap-generate-instruction (code-vector index insn) + (let* ((op (lap-instruction-opcode insn)) + (vals (lap-instruction-parsed-operands insn)) + (high (opcode-op-high op)) + (low (opcode-op-low op)) + (idx -1)) + (dolist (operand (opcode-operands op)) + (let* ((val (if (logbitp operand-fake (operand-flags operand)) + 0 + (svref vals (incf idx)))) + (insert-function (operand-insert-function operand))) + (multiple-value-setq (high low) + (if insert-function + (funcall insert-function high low val) + (ppc::insert-default operand high low val))) + (if (null high) + (error "Invalid operand for ~s instruction: ~d" (opcode-name op) val)))) + (setf (lap-instruction-parsed-operands insn) nil) + (free-lap-operand-vector vals) + (locally (declare (type (simple-array (unsigned-byte 16) (*)) code-vector) + (optimize (speed 3) (safety 0))) + (setf (aref code-vector (+ index index)) high + (aref code-vector (+ index index 1)) low) + nil))) + +(defparameter *use-traceback-tables* nil) + +(defun traceback-fullwords (pname) + (if (and *use-traceback-tables* pname (typep pname 'simple-base-string)) + (ceiling (+ 22 (length pname)) 4) + 0)) + +(defun add-traceback-table (code-vector start pname) + (flet ((out-byte (v i8 b) + (declare (type (simple-array (unsigned-byte 8) (*)) v) + (optimize (speed 3) (safety 0)) + (fixnum i8)) + (setf (aref v i8) b))) + (flet ((out-bytes (v i32 b0 b1 b2 b3) + (declare (type (simple-array (unsigned-byte 8) (*)) v) + (optimize (speed 3) (safety 0)) + (fixnum i32)) + (let* ((i8 (ash i32 2))) + (declare (fixnum i8)) + (setf (aref v i8) b0 + (aref v (%i+ i8 1)) b1 + (aref v (%i+ i8 2)) b2 + (aref v (%i+ i8 3)) b3)))) + (setf (uvref code-vector start) 0) + (out-bytes code-vector (1+ start) + 0 ; traceback table version + 0 ; language id 7 - try 0 instead (means C) or 9 means C++ + #x20 ; ??? + #x41) ; ??? + (out-bytes code-vector (+ start 2) + #x80 #x06 #x01 #x00) ; ??? ??? ??? ??? + (setf (uvref code-vector (+ start 3)) #x0) + (setf (uvref code-vector (+ start 4)) (ash start 2)) + (let* ((namelen (length pname)) + (pos (ash (the fixnum (+ start 5)) 2))) + (declare (fixnum namelen nwords pos)) + (out-byte code-vector pos (ldb (byte 8 8) namelen)) + (incf pos) + (out-byte code-vector pos (ldb (byte 8 0) namelen)) + (incf pos) + (dotimes (i namelen) + (out-byte code-vector pos (char-code (schar pname i))) + (incf pos)))))) + +(defun ppc-lap-generate-code (name maxpc bits &optional (traceback nil)) + (declare (fixnum maxpc)) + (let* ((target-backend *target-backend*) + (cross-compiling (not (eq *host-backend* target-backend))) + (traceback-size + (traceback-fullwords (and traceback + name + (setq traceback (symbol-name name))))) + (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*))) + (prefix-size (length prefix)) + (code-vector-size (+ (ash maxpc -2) traceback-size prefix-size)) + + (constants-size (+ 3 (length *ppc-lap-constants*))) + (constants-vector (%alloc-misc + constants-size + (if cross-compiling + target::subtag-xfunction + target::subtag-function))) + (i prefix-size)) + (declare (fixnum i constants-size)) + #+ppc32-target + (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow)) + (let* ((code-vector (%alloc-misc + code-vector-size + (if cross-compiling + target::subtag-xcode-vector + target::subtag-code-vector)))) + (dotimes (j prefix-size) + (setf (uvref code-vector j) (pop prefix))) + (ppc-lap-resolve-labels) ; all operands fully evaluated now. + (do-dll-nodes (insn *lap-instructions*) + (ppc-lap-generate-instruction code-vector i insn) + (incf i)) + (unless (eql 0 traceback-size) + (add-traceback-table code-vector i traceback)) + (dolist (immpair *ppc-lap-constants*) + (let* ((imm (car immpair)) + (k (cdr immpair))) + (declare (fixnum k)) + (setf (uvref constants-vector + (ash + (- k (arch::target-misc-data-offset (backend-target-arch target-backend))) + (- (arch::target-word-shift (backend-target-arch target-backend))))) + imm))) + (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits + (uvref constants-vector (- constants-size 2)) name + (uvref constants-vector 0) code-vector) + #+ppc-target (%make-code-executable code-vector) + constants-vector))) + +(defun ppc-lap-pseudo-op (form) + (case (car form) + (:regsave + (if *ppc-lap-regsave-label* + (warn "Duplicate :regsave form not handled (yet ?) : ~s" form) + (destructuring-bind (reg addr) (cdr form) + (let* ((regno (ppc-register-name-or-expression reg))) + (if (not (<= ppc::save7 regno ppc::save0)) + (warn "Not a save register: ~s. ~s ignored." reg form) + (let* ((addrexp (ppc-register-name-or-expression addr))) ; parses 'fixnum + (if (not (and (typep addrexp 'fixnum) + (<= 0 addrexp #x7ffc) ; not really right + (not (logtest 3 addrexp)))) + (warn "Invalid logical VSP: ~s. ~s ignored." addr form) + (setq *ppc-lap-regsave-label* (emit-lap-label (gensym)) + *ppc-lap-regsave-reg* regno + *ppc-lap-regsave-addr* (- (+ addrexp) + (* 4 (1+ (- ppc::save0 regno)))))))))))) + (:arglist (setq *ppc-lap-lfun-bits* (encode-lambda-list (cadr form)))))) + + +(defun ppc-lap-form (form) + (if (and form (symbolp form)) + (emit-lap-label form) + (if (or (atom form) (not (symbolp (car form)))) + (error "~& unknown PPC-LAP form: ~S ." form) + (multiple-value-bind (expansion expanded) + (ppc-lap-macroexpand-1 form) + (if expanded + (ppc-lap-form expansion) + (let* ((name (car form))) + (if (keywordp name) + (ppc-lap-pseudo-op form) + (case name + ((progn) (dolist (f (cdr form)) (ppc-lap-form f))) + ((let) (ppc-lap-equate-form (cadr form) (cddr form))) + (t + ; instruction macros expand into instruction forms + ; (with some operands reordered/defaulted.) + (let* ((expander (ppc::ppc-macro-function name))) + (if expander + (ppc-lap-form (funcall expander form nil)) + (ppc-lap-instruction name (cdr form))))))))))))) + +;;; (let ((name val) ...) &body body) +;;; each "val" gets a chance to be treated as a PPC register name +;;; before being evaluated. +(defun ppc-lap-equate-form (eqlist body) + (let* ((symbols (mapcar #'(lambda (x) + (let* ((name (car x))) + (or + (and name + (symbolp name) + (not (constant-symbol-p name)) + name) + (error + "~S is not a bindable symbol name ." name)))) + eqlist)) + (values (mapcar #'(lambda (x) (or (ppc-vr-name-p (cadr x)) + (ppc-fpr-name-p (cadr x)) + (ppc-register-name-or-expression + (cadr x)))) + eqlist))) + (progv symbols values + (dolist (form body) + (ppc-lap-form form))))) + +(defun ppc-lap-constant-offset (x) + (or (cdr (assoc x *ppc-lap-constants* :test #'equal)) + (let* ((target-backend *target-backend*) + (n (+ (arch::target-misc-data-offset (backend-target-arch target-backend)) + (ash (1+ (length *ppc-lap-constants*)) + (arch::target-word-shift (backend-target-arch target-backend)))))) + (push (cons x n) *ppc-lap-constants*) + n))) + +; Evaluate an arbitrary expression; warn if the result isn't a fixnum. +(defun ppc-lap-evaluated-expression (x) + (if (typep x 'fixnum) + x + (if (null x) + (arch::target-nil-value (backend-target-arch *target-backend*)) + (if (eq x t) + (+ (arch::target-nil-value (backend-target-arch *target-backend*)) + (arch::target-t-offset (backend-target-arch *target-backend*))) + (let* ((val (handler-case (eval x) ; Look! Expression evaluation! + (error (condition) (error "~&Evaluation of ~S signalled assembly-time error ~& ~A ." + x condition))))) + (unless (typep val 'fixnum) + (warn "assembly-time evaluation of ~S returned ~S, which may not have been intended ." + x val)) + val))))) + +(defparameter *ppc-lap-register-aliases* + `((nfn . ,ppc::nfn) + (fname . ,ppc::fname))) + +(defparameter *ppc-lap-fp-register-aliases* + ()) + +(defparameter *ppc-lap-vector-register-aliases* + ()) + +(defun ppc-gpr-name-p (x) + (and (or (symbolp x) (stringp x)) + (or + (position (string x) ppc::*gpr-register-names* :test #'string-equal) + (cdr (assoc x *ppc-lap-register-aliases* :test #'string-equal))))) + +(defun ppc-register-name-or-expression (x) + (if x + (or (ppc-gpr-name-p x) + (if (and (consp x) (eq (car x) 'quote)) + (let* ((quoted-form (cadr x))) + (if (null quoted-form) + (arch::target-nil-value (backend-target-arch *target-backend*)) + (if (eq quoted-form t) + (+ (arch::target-nil-value (backend-target-arch *target-backend*)) + (arch::target-t-offset (backend-target-arch *target-backend*))) + (if (typep quoted-form 'fixnum) + (ash quoted-form (arch::target-fixnum-shift (backend-target-arch *target-backend*))) + (ppc-lap-constant-offset quoted-form))))) + (ppc-lap-evaluated-expression x))) + (arch::target-nil-value (backend-target-arch *target-backend*)))) + +(defun ppc-fpr-name-p (x) + (and (or (symbolp x) (stringp x)) + (or + (position (string x) ppc::*fpr-register-names* :test #'string-equal) + (cdr (assoc x *ppc-lap-fp-register-aliases* :test #'string-equal))))) + +(defun ppc-fp-register-name-or-expression (x) + (or (ppc-fpr-name-p x) + (ppc-lap-evaluated-expression x))) + +(defun ppc-vr-name-p (x) + (and (or (symbolp x) (stringp x)) + (or + (position (string x) ppc::*vector-register-names* :test #'string-equal) + (cdr (assoc x *ppc-lap-vector-register-aliases* :test #'string-equal))))) + +(defun ppc-vector-register-name-or-expression (x) + (or (ppc-vr-name-p x) + (ppc-lap-evaluated-expression x))) + +(defun ppc-vr (r) + (svref ppc::*vector-register-names* r)) + + +(defparameter *ppc-cr-field-names* #(:crf0 :crf1 :crf2 :crf3 :crf4 :crf5 :crf6 :crf7)) +(defparameter *ppc-cr-names* #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)) +(defparameter *ppc-cc-bit-names* #(:lt :gt :eq :so :un)) +(defparameter *ppc-cc-bit-inverse-names* #(:ge :le :ne :ns :nu)) + +; This wants a :CC, a negated :CC, or either (:CRn :CC) or (:CRn :~CC). +; Returns the fully-qualified CR bit and an indication of whether or not the CC was +; negated. +(defun ppc-lap-parse-test (x) + (if (or (symbolp x) (stringp x)) + (let* ((pos (position x *ppc-cc-bit-names* :test #'string-equal))) + (if pos + (values (min pos 3) nil) + (if (setq pos (position x *ppc-cc-bit-inverse-names* :test #'string-equal)) + (values (min pos 3) t) + (error "Unknown PPC lap condition form : ~s" x)))) + (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x))) + (let* ((field (position (car x) *ppc-cr-names*))) + (unless field (error "Unknown CR field name : ~s" (car x))) + (let* ((bit (position (cadr x) *ppc-cc-bit-names*))) + (if bit + (values (logior (ash field 2) (min bit 3)) nil) + (if (setq bit (position (cadr x) *ppc-cc-bit-inverse-names*)) + (values (logior (ash field 2) (min bit 3)) t) + (error "Unknown condition name : ~s" (cadr x)))))) + (error "Unknown PPC lap condition form : ~s" x)))) + +; Accept either :CRn, :CC, or (:CRFn :CC), or evaluate an expression. +(defun ppc-lap-cr-field-expression (x) + (if (or (symbolp x) (stringp x)) + (let* ((pos (position x *ppc-cr-names* :test #'string-equal))) + (if pos + (ash pos 2) + (let* ((cc-pos (position x *ppc-cc-bit-names* :test #'string-equal))) + (if cc-pos + (min cc-pos 3) + (ppc-lap-evaluated-expression x))))) + (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x))) + (let* ((field (position (car x) *ppc-cr-field-names*)) + (bit (position (cadr x) *ppc-cc-bit-names*))) + (if (and field bit) + (logior (min bit 3) (ash field 2)) + (error "Bad ppc-cr-field-expression: ~s" x))) + (ppc-lap-evaluated-expression x)))) + +(defun ppc-lap-instruction (name opvals) + (let* ((opnum (gethash (string name) ppc::*ppc-opcode-numbers*)) + (opcode (and opnum + (< -1 opnum (length ppc::*ppc-opcodes*)) + (svref ppc::*ppc-opcodes* opnum)))) + (unless opcode + (error "Unknown PPC opcode: ~a" name)) + ;; Unless either + ;; a) The number of operand values in the macro call exactly + ;; matches the number of operands accepted by the instruction or + ;; b) The number of operand values is one less, and the instuction + ;; takes an optional operand + ;; we've got a wrong-number-of-args error. + ;; In case (b), there's at most one optional argument per instruction; + ;; provide 0 for the missing value. + (let* ((operands (opcode-operands opcode)) + (nmin (opcode-min-args opcode)) + (nmax (opcode-max-args opcode)) + (nhave (length opvals))) + (declare (fixnum nmin nmax nhave)) + (if (= nhave nmax) + (ppc-emit-lap-instruction opcode opvals) + (if (> nhave nmax) + (error "Too many operands in ~s (~a accepts at most ~d)" + opvals name nmax) + (if (= nhave nmin) + (let* ((newops ())) + (dolist (op operands (ppc-emit-lap-instruction opcode (nreverse newops))) + (let* ((flags (operand-flags op))) + (unless (logbitp operand-fake flags) + (push (if (logbitp operand-optional flags) + 0 + (pop opvals)) + newops))))) + (error "Too few operands in ~s : (~a requires at least ~d)" + opvals name nmin))))))) + +; This is pretty rudimentary: if the operand has the "ppc::$ppc-operand-relative" bit +; set, we demand a label name and note the fact that we reference the label in question. +; Otherwise, we use the "register-name-or-expression" thing. +; Like most PPC assemblers, this lets you treat everything as an expression, even if +; you've got the order of some arguments wrong ... + +(defun ppc-parse-lap-operand (opvalx operand insn) + (let* ((flags (operand-flags operand))) + (declare (fixnum flags)) + (if (logbitp ppc::$ppc-operand-relative flags) + (lap-note-label-reference opvalx insn) + (if (logbitp ppc::$ppc-operand-cr flags) + (ppc-lap-cr-field-expression opvalx) + (if (logbitp ppc::$ppc-operand-absolute flags) + (ppc-subprimitive-address opvalx) + (if (logbitp ppc::$ppc-operand-fpr flags) + (ppc-fp-register-name-or-expression opvalx) + (if (logbitp ppc::$ppc-operand-vr flags) ; SVS + (ppc-vector-register-name-or-expression opvalx) + (ppc-register-name-or-expression opvalx)))))))) + +(defun ppc-subprimitive-address (x) + (if (and x (or (symbolp x) (stringp x))) + (let* ((info (find x ppc::*ppc-subprims* :test #'string-equal :key #'subprimitive-info-name))) + (when info (return-from ppc-subprimitive-address + (subprimitive-info-offset info))))) + (ppc-lap-evaluated-expression x)) + + +;;; We've checked that the number of operand values match the number +;;; expected (and have set "fake" operand values to 0.) Labels - and +;;; some constructs that might someday do arithmetic on them - are +;;; about the only class of forward references we need to deal with. +;;; This whole two-pass scheme seems overly general, but if/when we +;;; ever do instruction scheduling it'll probably make it simpler. +(defun ppc-emit-lap-instruction (opcode opvals) + (let* ((operands (opcode-operands opcode)) + (parsed-values (alloc-lap-operand-vector)) + (insn (make-lap-instruction opcode)) + (idx -1)) + (declare (fixnum idx)) + (dolist (op operands) + (let* ((flags (operand-flags op)) + (val (if (logbitp operand-fake flags) + 0 + (ppc-parse-lap-operand (pop opvals) op insn)))) + (declare (fixnum flags)) + (setf (svref parsed-values (incf idx)) val))) + (setf (lap-instruction-parsed-operands insn) parsed-values) + (append-dll-node insn *lap-instructions*))) + + + +(defmacro defppclapfunction (&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)) + #-ppc-target + (progn + (eval-when (:load-toplevel) + (%defun (nfunction ,name (lambda (&lap 0) (ppc-lap-function ,name ,arglist ,@body))) ,doc)) + (eval-when (:execute) + (%define-ppc-lap-function ',name '((let ,arglist ,@body))))) + #+ppc-target ; just shorthand for defun + (%defun (nfunction ,name (lambda (&lap 0) (ppc-lap-function ,name ,arglist ,@body))) ,doc))) + + + +(provide "PPC-LAP") Index: /branches/experimentation/later/source/compiler/PPC/ppc-lapmacros.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc-lapmacros.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc-lapmacros.lisp (revision 8058) @@ -0,0 +1,1063 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPC-LAP")) + + +(defppclapmacro clrrri (&rest args) + (target-arch-case + (:ppc32 `(clrrwi ,@args)) + (:ppc64 `(clrrdi ,@args)))) + +(defppclapmacro clrlri (&rest args) + (target-arch-case + (:ppc32 `(clrlwi ,@args)) + (:ppc64 `(clrldi ,@args)))) + +(defppclapmacro clrlri. (&rest args) + (target-arch-case + (:ppc32 `(clrlwi. ,@args)) + (:ppc64 `(clrldi. ,@args)))) + +(defppclapmacro ldr (&rest args) + (target-arch-case + (:ppc32 `(lwz ,@args)) + (:ppc64 `(ld ,@args)))) + +(defppclapmacro ldrx (&rest args) + (target-arch-case + (:ppc32 `(lwzx ,@args)) + (:ppc64 `(ldx ,@args)))) + +(defppclapmacro ldru (&rest args) + (target-arch-case + (:ppc32 `(lwzu ,@args)) + (:ppc64 `(ldu ,@args)))) + +(defppclapmacro str (&rest args) + (target-arch-case + (:ppc32 `(stw ,@args)) + (:ppc64 `(std ,@args)))) + +(defppclapmacro strx (&rest args) + (target-arch-case + (:ppc32 `(stwx ,@args)) + (:ppc64 `(stdx ,@args)))) + +(defppclapmacro stru (&rest args) + (target-arch-case + (:ppc32 `(stwu ,@args)) + (:ppc64 `(stdu ,@args)))) + +(defppclapmacro strux (&rest args) + (target-arch-case + (:ppc32 `(stwux ,@args)) + (:ppc64 `(stdux ,@args)))) + +(defppclapmacro lrarx (&rest args) + (target-arch-case + (:ppc32 `(lwarx ,@args)) + (:ppc64 `(ldarx ,@args)))) + +(defppclapmacro strcx. (&rest args) + (target-arch-case + (:ppc32 `(stwcx. ,@args)) + (:ppc64 `(stdcx. ,@args)))) + +(defppclapmacro cmpr (&rest args) + (target-arch-case + (:ppc32 `(cmpw ,@args)) + (:ppc64 `(cmpd ,@args)))) + +(defppclapmacro cmpri (&rest args) + (target-arch-case + (:ppc32 `(cmpwi ,@args)) + (:ppc64 `(cmpdi ,@args)))) + +(defppclapmacro cmplr (&rest args) + (target-arch-case + (:ppc32 `(cmplw ,@args)) + (:ppc64 `(cmpld ,@args)))) + +(defppclapmacro cmplri (&rest args) + (target-arch-case + (:ppc32 `(cmplwi ,@args)) + (:ppc64 `(cmpldi ,@args)))) + +(defppclapmacro trlge (&rest args) + (target-arch-case + (:ppc32 `(twlge ,@args)) + (:ppc64 `(tdlge ,@args)))) + +(defppclapmacro trlgei (&rest args) + (target-arch-case + (:ppc32 `(twlgei ,@args)) + (:ppc64 `(tdlgei ,@args)))) + +(defppclapmacro trllt (&rest args) + (target-arch-case + (:ppc32 `(twllt ,@args)) + (:ppc64 `(tdllt ,@args)))) + +(defppclapmacro trllti (&rest args) + (target-arch-case + (:ppc32 `(twllti ,@args)) + (:ppc64 `(tdllti ,@args)))) + +(defppclapmacro trlgti (&rest args) + (target-arch-case + (:ppc32 `(twlgti ,@args)) + (:ppc64 `(tdlgti ,@args)))) + +(defppclapmacro trlti (&rest args) + (target-arch-case + (:ppc32 `(twlti ,@args)) + (:ppc64 `(tdlti ,@args)))) + +(defppclapmacro trlle (&rest args) + (target-arch-case + (:ppc32 `(twlle ,@args)) + (:ppc64 `(tdlle ,@args)))) + +(defppclapmacro treqi (&rest args) + (target-arch-case + (:ppc32 `(tweqi ,@args)) + (:ppc64 `(tdeqi ,@args)))) + +(defppclapmacro trnei (&rest args) + (target-arch-case + (:ppc32 `(twnei ,@args)) + (:ppc64 `(tdnei ,@args)))) + +(defppclapmacro trgti (&rest args) + (target-arch-case + (:ppc32 `(twgti ,@args)) + (:ppc64 `(tdgti ,@args)))) + + +(defppclapmacro srari (&rest args) + (target-arch-case + (:ppc32 `(srawi ,@args)) + (:ppc64 `(sradi ,@args)))) + +(defppclapmacro srar (&rest args) + (target-arch-case + (:ppc32 `(sraw ,@args)) + (:ppc64 `(srad ,@args)))) + +(defppclapmacro slr (&rest args) + (target-arch-case + (:ppc32 `(slw ,@args)) + (:ppc64 `(sld ,@args)))) + +(defppclapmacro srri (&rest args) + (target-arch-case + (:ppc32 `(srwi ,@args)) + (:ppc64 `(srdi ,@args)))) + +(defppclapmacro slri (&rest args) + (target-arch-case + (:ppc32 `(slwi ,@args)) + (:ppc64 `(sldi ,@args)))) + +(defppclapmacro slri. (&rest args) + (target-arch-case + (:ppc32 `(slwi. ,@args)) + (:ppc64 `(sldi. ,@args)))) + +(defppclapmacro srr (&rest args) + (target-arch-case + (:ppc32 `(srw ,@args)) + (:ppc64 `(srd ,@args)))) + +(defppclapmacro bkpt () + `(tweq rzero rzero)) + +(defppclapmacro dbg (&optional save-lr?) + (if save-lr? + `(progn + (mflr loc-pc) + (str imm0 -40 sp) ; better than clobbering imm0 + (bla .SPbreakpoint) + (ldr imm0 -40 sp) + (mtlr loc-pc)) + `(bla .SPbreakpoint))) + +(defppclapmacro lwi (dest n) + (setq n (logand n #xffffffff)) + (let* ((mask #xffff8000) + (masked (logand n mask)) + (high (ash n -16)) + (low (logand #xffff n))) + (if (or (= 0 masked) (= mask masked)) + `(li ,dest ,low) + (if (= low 0) + `(lis ,dest ,high) + `(progn + (lis ,dest ,high) + (ori ,dest ,dest ,low)))))) + +(defppclapmacro set-nargs (n) + (check-type n (unsigned-byte 13)) + `(li nargs ',n)) + +(defppclapmacro check-nargs (min &optional (max min)) + (if (eq max min) + `(trnei nargs ',min) + (if (null max) + (unless (= min 0) + `(trllti nargs ',min)) + (if (= min 0) + `(trlgti nargs ',max) + `(progn + (trllti nargs ',min) + (trlgti nargs ',max)))))) + +;; Event-polling involves checking to see if the value of the current +;; thread's interrupt-level is > 0. For now, use nargs; this may +;; change to "any register BUT nargs". (Note that most number-of-args +;; traps use unsigned comparisons.) +(defppclapmacro event-poll () + (target-arch-case + (:ppc32 + '(progn + (lwz nargs ppc32::tcr.tlb-pointer ppc32::rcontext) + (lwz nargs ppc32::interrupt-level-binding-index nargs) + (twgti nargs 0))) + (:ppc64 + '(progn + (ld nargs ppc64::tcr.tlb-pointer ppc64::rcontext) + (ld nargs ppc64::interrupt-level-binding-index nargs) + (tdgti nargs 0))))) + + +;;; There's no "else"; learn to say "(progn ...)". +;;; Note also that the condition is a CR bit specification (or a "negated" one). +;;; Whatever affected that bit (hopefully) happened earlier in the pipeline. +(defppclapmacro if (test then &optional (else nil else-p)) + (multiple-value-bind (bitform negated) (ppc-lap-parse-test test) + (let* ((false-label (gensym))) + (if (not else-p) + `(progn + (,(if negated 'bt 'bf) ,bitform ,false-label) + ,then + ,false-label) + (let* ((cont-label (gensym))) + `(progn + (,(if negated 'bt 'bf) ,bitform ,false-label) + ,then + (b ,cont-label) + ,false-label + ,else + ,cont-label)))))) + +(defppclapmacro save-pc () + `(mflr loc-pc)) + +;;; This needs to be done if we aren't a leaf function (e.g., if we +;;; clobber our return address or need to reference any constants. Note +;;; that it's not atomic wrt a preemptive scheduler, but we need to +;;; pretend that it will be.) The VSP to be saved is the value of the +;;; VSP before any of this function's arguments were vpushed by its +;;; caller; that's not the same as the VSP register if any non-register +;;; arguments were received, but is usually easy to compute. + +(defppclapmacro save-lisp-context (&optional (vsp 'vsp) (save-pc t)) + (target-arch-case + (:ppc32 + `(progn + ,@(if save-pc + '((save-pc))) + (stwu sp (- ppc32::lisp-frame.size) sp) + (stw fn ppc32::lisp-frame.savefn sp) + (stw loc-pc ppc32::lisp-frame.savelr sp) + (stw ,vsp ppc32::lisp-frame.savevsp sp) + (mr fn nfn))) + (:ppc64 + `(progn + ,@(if save-pc + '((save-pc))) + (stdu sp (- ppc64::lisp-frame.size) sp) + (std fn ppc64::lisp-frame.savefn sp) + (std loc-pc ppc64::lisp-frame.savelr sp) + (std ,vsp ppc64::lisp-frame.savevsp sp) + (mr fn nfn))))) + +;;; There are a few cases to deal with when restoring: whether or not +;;; to restore the vsp, whether we need to saved LR back in the LR or +;;; whether it only needs to get as far as loc-pc, etc. This fully +;;; restores everything (letting the caller specify some register +;;; other than the VSP, if that's useful.) Note that, since FN gets +;;; restored, it's no longer possible to use it to address the current +;;; function's constants. +(defppclapmacro restore-full-lisp-context (&optional (vsp 'vsp)) + (target-arch-case + (:ppc32 + `(progn + (lwz loc-pc ppc32::lisp-frame.savelr sp) + (lwz ,vsp ppc32::lisp-frame.savevsp sp) + (mtlr loc-pc) + (lwz fn ppc32::lisp-frame.savefn sp) + (la sp ppc32::lisp-frame.size sp))) + (:ppc64 + `(progn + (ld loc-pc ppc64::lisp-frame.savelr sp) + (ld ,vsp ppc64::lisp-frame.savevsp sp) + (mtlr loc-pc) + (ld fn ppc64::lisp-frame.savefn sp) + (la sp ppc64::lisp-frame.size sp))))) + +(defppclapmacro restore-pc () + `(mtlr loc-pc)) + +(defppclapmacro push (src stack) + `(stru ,src ,(- (arch::target-lisp-node-size (backend-target-arch *target-backend*))) ,stack)) + +(defppclapmacro vpush (src) + `(push ,src vsp)) + +;;; You typically don't want to do this to pop a single register (it's better to +;;; do a sequence of loads, and then adjust the stack pointer.) + +(defppclapmacro pop (dest stack) + `(progn + (ldr ,dest 0 ,stack) + (la ,stack ,(arch::target-lisp-node-size (backend-target-arch *target-backend*)) ,stack))) + +(defppclapmacro vpop (dest) + `(pop ,dest vsp)) + +(defppclapmacro %cdr (dest node) + (target-arch-case + (:ppc32 `(lwz ,dest ppc32::cons.cdr ,node)) + (:ppc64 `(ld ,dest ppc64::cons.cdr ,node)))) + +(defppclapmacro %car (dest node) + (target-arch-case + (:ppc32 `(lwz ,dest ppc32::cons.car ,node)) + (:ppc64 `(ld ,dest ppc64::cons.car ,node)))) + +(defppclapmacro extract-lisptag (dest node) + (let* ((tb *target-backend*)) + `(clrlri ,dest ,node (- ,(arch::target-nbits-in-word (backend-target-arch tb)) + ,(arch::target-nlisptagbits (backend-target-arch tb)))))) + +(defppclapmacro extract-fulltag (dest node) + (let* ((tb *target-backend*)) + `(clrlri ,dest ,node (- ,(arch::target-nbits-in-word (backend-target-arch tb)) + ,(arch::target-ntagbits (backend-target-arch tb)))))) + +(defppclapmacro extract-lowtag (dest node) + (target-arch-case + (:ppc32 + (error "EXTRACT-LOWTAG lapmacro makes no sense on PPC32.")) + (:ppc64 + `(clrldi ,dest ,node (- 64 ppc64::nlowtagbits))))) + + +(defppclapmacro extract-subtag (dest node) + (target-arch-case + (:ppc32 + `(lbz ,dest ppc32::misc-subtag-offset ,node)) + (:ppc64 + `(lbz ,dest ppc64::misc-subtag-offset ,node)))) + +(defppclapmacro extract-typecode (dest node &optional (crf :cr0)) + (target-arch-case + (:ppc32 + `(progn + (extract-lisptag ,dest ,node) + (cmpwi ,crf ,dest ppc32::tag-misc) + (if (,crf :eq) + (extract-subtag ,dest ,node)))) + (:ppc64 + `(progn + (extract-fulltag ,dest ,node) + (cmpdi ,crf ,dest ppc64::fulltag-misc) + (extract-lisptag ,dest ,dest) + (if (,crf :eq) + (extract-subtag ,dest ,node)))))) + +(defppclapmacro trap-unless-lisptag= (node tag &optional (immreg ppc::imm0)) + `(progn + (extract-lisptag ,immreg ,node) + (trnei ,immreg ,tag))) + +(defppclapmacro trap-unless-fulltag= (node tag &optional (immreg ppc::imm0)) + `(progn + (extract-fulltag ,immreg ,node) + (trnei ,immreg ,tag))) + + +(defppclapmacro trap-unless-typecode= (node tag &optional (immreg ppc::imm0) (crf :cr0)) + `(progn + (extract-typecode ,immreg ,node ,crf) + (trnei ,immreg ,tag))) + + +(defppclapmacro load-constant (dest constant) + `(ldr ,dest ',constant fn)) + +;;; This is about as hard on the pipeline as anything I can think of. +(defppclapmacro call-symbol (function-name) + (target-arch-case + (:ppc32 + `(progn + (load-constant fname ,function-name) + (lwz nfn ppc32::symbol.fcell fname) + (lwz loc-pc ppc32::misc-data-offset nfn) + (mtctr loc-pc) + (bctrl))) + (:ppc64 + `(progn + (load-constant fname ,function-name) + (ld nfn ppc64::symbol.fcell fname) + (ld loc-pc ppc64::misc-data-offset nfn) + (mtctr loc-pc) + (bctrl))))) + +(defppclapmacro sp-call-symbol (function-name) + `(progn + (load-constant fname ,function-name) + (bla .SPjmpsym))) + +(defppclapmacro getvheader (dest src) + (target-arch-case + (:ppc32 + `(lwz ,dest ppc32::misc-header-offset ,src)) + (:ppc64 + `(ld ,dest ppc64::misc-header-offset ,src)))) + +;;; "Size" is unboxed element-count. +(defppclapmacro header-size (dest vheader) + (target-arch-case + (:ppc32 + `(srwi ,dest ,vheader ppc32::num-subtag-bits)) + (:ppc64 + `(srdi ,dest ,vheader ppc64::num-subtag-bits)))) + + +;;; "Length" is fixnum element-count. +(defppclapmacro header-length (dest vheader) + (target-arch-case + (:ppc32 + `(rlwinm ,dest + ,vheader + (- ppc32::nbits-in-word (- ppc32::num-subtag-bits ppc32::nfixnumtagbits)) + (- ppc32::num-subtag-bits ppc32::nfixnumtagbits) + (- ppc32::least-significant-bit ppc32::nfixnumtagbits))) + (:ppc64 + `(progn + (rldicr ,dest + ,vheader + (- 64 (- ppc64::num-subtag-bits ppc64::fixnumshift)) + (- 63 ppc64::fixnumshift)) + (clrldi ,dest ,dest (- ppc64::num-subtag-bits ppc64::fixnumshift)))))) + + +(defppclapmacro header-subtag[fixnum] (dest vheader) + (target-arch-case + (:ppc32 + `(rlwinm ,dest + ,vheader + ppc32::fixnumshift + (- ppc32::nbits-in-word (+ ppc32::num-subtag-bits ppc32::nfixnumtagbits)) + (- ppc32::least-significant-bit ppc32::nfixnumtagbits))) + (:ppc64 + `(clrlsldi ,dest + ,vheader (- ppc64::nbits-in-word ppc64::num-subtag-bits) + ppc64::fixnumshift)))) + + +(defppclapmacro vector-size (dest v vheader) + `(progn + (getvheader ,vheader ,v) + (header-size ,dest ,vheader))) + +(defppclapmacro vector-length (dest v vheader) + `(progn + (getvheader ,vheader ,v) + (header-length ,dest ,vheader))) + + +;;; Reference a 32-bit miscobj entry at a variable index. +;;; Make the caller explicitly designate a scratch register +;;; to use for the scaled index. + +(defppclapmacro vref32 (dest miscobj index scaled-idx) + `(progn + (la ,scaled-idx ppc32::misc-data-offset ,index) + (lwzx ,dest ,miscobj ,scaled-idx))) + +;; The simple (no-memoization) case. +(defppclapmacro vset32 (src miscobj index scaled-idx) + `(progn + (la ,scaled-idx ppc32::misc-data-offset ,index) + (stwx ,src ,miscobj ,scaled-idx))) + +(defppclapmacro extract-lowbyte (dest src) + (target-arch-case + (:ppc32 `(clrlwi ,dest ,src (- 32 8))) + (:ppc64 `(clrldi ,dest ,src (- 64 8))))) + +(defppclapmacro unbox-fixnum (dest src) + (target-arch-case + (:ppc32 + `(srawi ,dest ,src ppc32::fixnumshift)) + (:ppc64 + `(sradi ,dest ,src ppc64::fixnumshift)))) + +(defppclapmacro box-fixnum (dest src) + (target-arch-case + (:ppc32 + `(slwi ,dest ,src ppc32::fixnumshift)) + (:ppc64 + `(sldi ,dest ,src ppc64::fixnumshift)))) + + + +;;; If crf is specified, type checks src +(defppclapmacro unbox-base-char (dest src &optional crf) + (if (null crf) + (target-arch-case + (:ppc32 `(srwi ,dest ,src ppc32::charcode-shift)) + (:ppc64 `(srdi ,dest ,src ppc64::charcode-shift))) + (let ((label (gensym))) + (target-arch-case + (:ppc32 `(progn + (clrlwi ,dest ,src (- ppc32::nbits-in-word ppc32::charcode-shift)) + (cmpwi ,crf ,dest ppc32::subtag-character) + (srwi ,dest ,src ppc32::charcode-shift) + (beq+ ,crf ,label) + (uuo_interr arch::error-object-not-base-char ,src) + ,label)) + (:ppc64 + `(progn + (clrldi ,dest ,src (- ppc64::nbits-in-word ppc64::num-subtag-bits)) + (cmpdi ,crf ,dest ppc64::subtag-character) + (srdi ,dest ,src ppc64::charcode-shift) + (beq+ ,crf ,label) + (uuo_interr arch::error-object-not-base-char ,src) + ,label)))))) + + + + +(defppclapmacro ref-global (reg sym) + (target-arch-case + (:ppc32 + (let* ((offset (ppc32::%kernel-global sym))) + `(lwz ,reg (+ ,offset ppc32::nil-value) 0))) + (:ppc64 + (let* ((offset (ppc64::%kernel-global sym))) + `(ld ,reg (+ ,offset ppc64::nil-value) 0))))) + +(defppclapmacro set-global (reg sym) + (target-arch-case + (:ppc32 + (let* ((offset (ppc32::%kernel-global sym))) + `(stw ,reg (+ ,offset ppc32::nil-value) 0))) + (:ppc64 + (let* ((offset (ppc64::%kernel-global sym))) + `(std ,reg (+ ,offset ppc64::nil-value) 0))))) + +;;; Set "dest" to those bits in "src" that are other than those that +;;; would be set if "src" is a fixnum and of type (unsigned-byte +;;; "width"). If no bits are set in "dest", then "src" is indeed of +;;; type (unsigned-byte "width"). Set (:CR0 :EQ) according to the +;;; result. +(defppclapmacro extract-unsigned-byte-bits. (dest src width) + (target-arch-case + (:ppc32 + `(rlwinm. ,dest ,src 0 (- 32 ppc32::fixnumshift) (- 31 (+ ,width ppc32::fixnumshift)))) + (:ppc64 + `(rldicr. ,dest ,src (- 64 ppc64::fixnumshift) (- 63 ,width))))) + + + +;;; You generally don't want to have to say "mfcr": it crosses functional +;;; units and forces synchronization (all preceding insns must complete, +;;; no subsequent insns may start.) +;;; There are often algebraic ways of computing ppc32::t-offset: + +;;; Src has all but the least significant bit clear. Map low bit to T/NIL. +(defppclapmacro bit0->boolean (dest src temp) + (target-arch-case + (:ppc32 + `(progn + (rlwimi ,temp ,src 4 27 27) + (addi ,dest ,temp ppc32::nil-value))) + (:ppc64 + `(progn + (mulli ,temp ,src ppc64::t-offset) ; temp = ppc64::t-offset, or 0 + (addi ,dest ,temp ppc64::nil-value))))) ; dest = (src == 1), lisp-wise + +(defppclapmacro eq0->boolean (dest src temp) + (target-arch-case + (:ppc32 + `(progn + (cntlzw ,temp ,src) ; 32 leading zeros if (src == 0) + (srwi ,temp ,temp 5) ; temp = (src == 0), C-wise + (bit0->boolean ,dest ,temp ,temp))) + (:ppc64 + `(progn + (cntlzd ,temp ,src) ; 64 leading zeros if (src == 0) + (srdi ,temp ,temp 6) ; temp = (src == 0), C-wise + (bit0->boolean ,dest ,temp ,temp))))) + +(defppclapmacro eq->boolean (dest rx ry temp) + `(progn + (sub ,temp ,rx ,ry) + (eq0->boolean ,dest ,temp ,temp))) + + +(defppclapmacro repeat (n inst) + (let* ((insts ())) + (dotimes (i n `(progn ,@(nreverse insts))) + (push inst insts)))) + +(defppclapmacro get-single-float (dest node) + (target-arch-case + (:ppc32 + `(lfs ,dest ppc32::single-float.value ,node)) + (:ppc64 + `(progn + (std ,node ppc64::tcr.single-float-convert ppc64::rcontext) + (lfs ,dest ppc64::tcr.single-float-convert ppc64::rcontext))))) + +(defppclapmacro get-double-float (dest node) + (target-arch-case + (:ppc32 + `(lfd ,dest ppc32::double-float.value ,node)) + (:ppc64 + `(lfd ,dest ppc64::double-float.value ,node)))) + + +(defppclapmacro put-single-float (src node) + (target-arch-case + (:ppc32 + `(stfs ,src ppc32::single-float.value ,node)) + (:ppc64 + `(progn + (stfs ,src ppc64::tcr.single-float-convert ppc64::rcontext) + (ld ,node ppc64::tcr.single-float-convert ppc64::rcontext))))) + +(defppclapmacro put-double-float (src node) + (target-arch-case + (:ppc32 + `(stfd ,src ppc32::double-float.value ,node)) + (:ppc64 + `(stfd ,src ppc64::double-float.value ,node)))) + +(defppclapmacro clear-fpu-exceptions () + `(mtfsf #xfc #.ppc::fp-zero)) + + + +;;; from ppc-bignum.lisp +(defppclapmacro digit-h (dest src) + (target-arch-case + (:ppc32 + `(rlwinm ,dest ,src (+ 16 ppc32::fixnumshift) (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnumshift))) + (:ppc64 + (error "DIGIT-H on PPC64 ?")))) + +;;; from ppc-bignum.lisp +(defppclapmacro digit-l (dest src) + (target-arch-case + (:ppc32 + `(clrlslwi ,dest ,src 16 ppc32::fixnumshift)) + (:ppc64 + (error "DIGIT-L on PPC64 ?")))) + +;;; from ppc-bignum.lisp +(defppclapmacro compose-digit (dest high low) + (target-arch-case + (:ppc32 + `(progn + (rlwinm ,dest ,low (- ppc32::nbits-in-word ppc32::fixnumshift) 16 31) + (rlwimi ,dest ,high (- 16 ppc32::fixnumshift) 0 15))) + (:ppc64 + (error "COMPOSE-DIGIT on PPC64 ?")))) + +(defppclapmacro macptr-ptr (dest macptr) + (target-arch-case + (:ppc32 + `(lwz ,dest ppc32::macptr.address ,macptr)) + (:ppc64 + `(ld ,dest ppc64::macptr.address ,macptr)))) + +(defppclapmacro svref (dest index vector) + (target-arch-case + (:ppc32 + `(lwz ,dest (+ (* 4 ,index) ppc32::misc-data-offset) ,vector)) + (:ppc64 + `(ld ,dest (+ (* 8 ,index) ppc64::misc-data-offset) ,vector)))) + +;;; This evals its args in the wrong order. +;;; Can't imagine any code will care. +(defppclapmacro svset (new-value index vector) + (target-arch-case + (:ppc32 + `(stw ,new-value (+ (* 4 ,index) ppc32::misc-data-offset) ,vector)) + (:ppc64 + `(std ,new-value (+ (* 8 ,index) ppc64::misc-data-offset) ,vector)))) + +(defppclapmacro vpush-argregs () + (let* ((none (gensym)) + (two (gensym)) + (one (gensym))) + `(progn + (cmpri cr1 nargs '2) + (cmpri cr0 nargs 0) + (beq cr1 ,two) + (beq cr0 ,none) + (blt cr1 ,one) + (vpush arg_x) + ,two + (vpush arg_y) + ,one + (vpush arg_z) + ,none))) + + + + +;;; Saving and restoring AltiVec registers. + +;;; Note that under the EABI (to which PPCLinux conforms), the OS +;;; doesn't attach any special significance to the value of the VRSAVE +;;; register (spr 256). Under some other ABIs, VRSAVE is a bitmask +;;; which indicates which vector registers are live at context switch +;;; time. These macros contain code to maintain VRSAVE when the +;;; variable *ALTIVEC-LAPMACROS-MAINTAIN-VRSAVE-P* is true at +;;; macroexpand time; that variable is initialized to true if and only +;;; if :EABI-TARGET is not on *FEATURES*. Making this behavior +;;; optional is supposed to help make code which uses these macros +;;; easier to port to other platforms. + +;;; From what I can tell, a function that takes incoming arguments in +;;; vector registers (vr2 ... vr13) (and doesn't use any other vector +;;; registers) doesn't need to assert that it uses any vector +;;; registers (even on platforms that maintain VRSAVE.) A function +;;; that uses vector registers that were not incoming arguments has to +;;; assert that it uses those registers on platforms that maintain +;;; VRSAVE. On all platforms, a function that uses any non-volatile +;;; vector registers (vr20 ... vr31) has to assert that it uses these +;;; registers and save and restore the caller's value of these registers +;;; around that usage. + +(defparameter *altivec-lapmacros-maintain-vrsave-p* + #-eabi-target t + #+eabi-target nil + "Control the expansion of certain lap macros. Initialized to NIL on +LinuxPPC; initialized to T on platforms (such as MacOS X/Darwin) that +require that the VRSAVE SPR contain a bitmask of active vector registers +at all times.") + +(defun %vr-register-mask (reglist) + (let* ((mask 0)) + (dolist (reg reglist mask) + (let* ((regval (ppc-vector-register-name-or-expression reg))) + (unless (typep regval '(mod 32)) + (error "Bad AltiVec register - ~s" reg)) + (setq mask (logior mask (ash #x80000000 (- regval)))))))) + + + +;;; Build a frame on the temp stack large enough to hold N 128-bit vector +;;; registers and the saved value of the VRSAVE spr. That frame will look +;;; like: +;;; #x??????I0 backpointer to previous tstack frame +;;; #x??????I4 non-zero marker: frame doesn't contain tagged lisp data +;;; #x??????I8 saved VRSAVE +;;; #x??????IC pad word for alignment +;;; #x??????J0 first saved vector register +;;; #x??????K0 second saved vector register +;;; ... +;;; #x??????X0 last saved vector register +;;; #x??????Y0 (possibly) 8 bytes wasted for alignment. +;;; #x???????? UNKNOWN; not necessarily the previous tstack frame +;;; +;;; Use the specified immediate register to build the frame. +;;; Save the caller's VRSAVE in the frame. + +(defppclapmacro %build-vrsave-frame (n tempreg) + (if (or (> n 0) *altivec-lapmacros-maintain-vrsave-p*) + (if (zerop n) + ;; Just make room for vrsave; no need to align to 16-byte boundary. + `(progn + (stwu tsp -16 tsp) + (stw tsp 4 tsp)) + `(progn + (la ,tempreg ,(- (ash (1+ n) 4)) ppc::tsp) + (clrrwi ,tempreg ,tempreg 4) ; align to 16-byte boundary + (sub ,tempreg ,tempreg ppc32::tsp) ; calculate (aligned) frame size. + (stwux ppc::tsp ppc::tsp ,tempreg) + (stw ppc::tsp 4 ppc::tsp))) ; non-zero: non-lisp + `(progn))) + +;;; Save the current value of the VRSAVE spr in the newly-created +;;; tstack frame. + +(defppclapmacro %save-vrsave (tempreg) + (if *altivec-lapmacros-maintain-vrsave-p* + `(progn + (mfspr ,tempreg 256) ; SPR 256 = vrsave + (stw ,tempreg 8 tsp)) + `(progn))) + + + +;;; When this is expanded, "tempreg" should contain the caller's vrsave. +(defppclapmacro %update-vrsave (tempreg mask) + (let* ((mask-high (ldb (byte 16 16) mask)) + (mask-low (ldb (byte 16 0) mask))) + `(progn + ,@(unless (zerop mask-high) `((oris ,tempreg ,tempreg ,mask-high))) + ,@(unless (zerop mask-low) `((ori ,tempreg ,tempreg ,mask-low))) + (mtspr 256 ,tempreg)))) + +;;; Save each of the vector regs in "nvrs" into the current tstack +;;; frame, starting at offset 16 +(defppclapmacro %save-vector-regs (nvrs tempreg) + (let* ((insts ())) + (do* ((offset 16 (+ 16 offset)) + (regs nvrs (cdr regs))) + ((null regs) `(progn ,@(nreverse insts))) + (declare (fixnum offset)) + (push `(la ,tempreg ,offset ppc::tsp) insts) + (push `(stvx ,(car regs) ppc::rzero ,tempreg) insts)))) + + +;;; Pretty much the same idea, only we restore VRSAVE first and +;;; discard the tstack frame after we've reloaded the vector regs. +(defppclapmacro %restore-vector-regs (nvrs tempreg) + (let* ((loads ())) + (do* ((offset 16 (+ 16 offset)) + (regs nvrs (cdr regs))) + ((null regs) `(progn + ,@ (when *altivec-lapmacros-maintain-vrsave-p* + `((progn + (lwz ,tempreg 8 ppc::tsp) + (mtspr 256 ,tempreg)))) + ,@(nreverse loads) + (lwz ppc::tsp 0 ppc::tsp))) + (declare (fixnum offset)) + (push `(la ,tempreg ,offset ppc::tsp) loads) + (push `(lvx ,(car regs) ppc::rzero ,tempreg) loads)))) + + +(defun %extract-non-volatile-vector-registers (vector-reg-list) + (let* ((nvrs ())) + (dolist (reg vector-reg-list (nreverse nvrs)) + (let* ((regval (ppc-vector-register-name-or-expression reg))) + (unless (typep regval '(mod 32)) + (error "Bad AltiVec register - ~s" reg)) + (when (>= regval 20) + (pushnew regval nvrs)))))) + + +;;; One could imagine something more elaborate: +;;; 1) Binding a global bitmask that represents the assembly-time notion +;;; of VRSAVE's contents; #'ppc-vector-register-name-or-expression +;;; could then warn if a vector register wasn't marked as active. +;;; Maybe a good idea, but PPC-LAP would have to bind that special +;;; variable to 0 to make things reentrant. +;;; 2) Binding a user-specified variable to the list of NVRs that need +;;; to be restored, so that it'd be more convenient to insert one's +;;; own calls to %RESTORE-VECTOR-REGS at appropriate points. +;;; Ad infinitum. As is, this allows one to execute a "flat" body of code +;;; that's bracketed by the stuff needed to keep VRSAVE in sync and +;;; to save and restore any non-volatile vector registers specified. +;;; That body of code is "flat" in the sense that it doesn't return, +;;; tail-call, establish a catch or unwind-protect frame, etc. +;;; It -can- contain lisp or foreign function calls. + +(defppclapmacro %with-altivec-registers ((&key (immreg 'ppc::imm0)) reglist &body body) + (let* ((mask (%vr-register-mask reglist)) + (nvrs (%extract-non-volatile-vector-registers reglist)) + (num-nvrs (length nvrs))) + (if (or *altivec-lapmacros-maintain-vrsave-p* nvrs) + `(progn + (%build-vrsave-frame ,num-nvrs ,immreg) + (%save-vrsave ,immreg) + ,@ (if *altivec-lapmacros-maintain-vrsave-p* + `((%update-vrsave ,immreg ,mask))) + (%save-vector-regs ,nvrs ,immreg) + (progn ,@body) + (%restore-vector-regs ,nvrs ,immreg)) + `(progn ,@body)))) + + +(defppclapmacro with-altivec-registers (reglist &body body) + "Specify the set of AltiVec registers used in body. If +*altivec-lapmacros-maintain-vrsave-p* is true when the macro is expanded, +generates code to save the VRSAVE SPR and updates VRSAVE to incude a +bitmask generated from the specified register list. Generates code which +saves any non-volatile vector registers which appear in the register list, +executes body, and restores the saved non-volatile vector registers (and, +if *altivec-lapmacros-maintain-vrsave-p* is true, restores VRSAVE as well. +Uses the IMM0 register (r3) as a temporary." + `(%with-altivec-registers () ,reglist ,@body)) + + +;;; Create an aligned buffer on the temp stack, large enough for N vector +;;; registers. Make base be a pointer to this buffer (base can be +;;; any available GPR, since the buffer will be fixnum-tagged.) N should +;;; be a constant. +;;; The intent here is that the register 'base' can be used in subsequent +;;; stvx/lvx instructions. Any vector registers involved in such instructions +;;; must have their corresponding bits saved in VRSAVE on platforms where +;;; that matters. + +(defppclapmacro allocate-vector-buffer (base n) + `(progn + (stwux tsp (- (ash (1+ ,n) 4))) ; allocate a frame on temp stack + (stw tsp 4 tsp) ; temp frame contains immediate data + (la ,base (+ 8 8) tsp) ; skip header, round up + (clrrwi ,base ,base 4))) ; align (round down) + +;;; Execute the specified body of code; on entry to that body, BASE +;;; will point to the lowest address of a vector-aligned buffer with +;;; room for N vector registers. On exit, the buffer will be +;;; deallocated. The body should preserve the value of BASE as long +;;; as it needs to reference the buffer. + +(defppclapmacro with-vector-buffer (base n &body body) + "Generate code which allocates a 16-byte aligned buffer large enough +to contain N vector registers; the GPR base points to the lowest address +of this buffer. After processing body, the buffer will be deallocated. +The body should preserve the value of base as long as it needs to +reference the buffer. It's intended that base be used as a base register +in stvx and lvx instructions within the body." + `(progn + (allocate-vector-buffer ,base ,n) + (progn + (progn ,@body) + (unlink tsp)))) + +#| + +;;; This is just intended to test the macros; I can't test whether or not the code works. + +(defppclapfunction load-array ((n arg_z)) + (check-nargs 1) + (with-altivec-registers (vr1 vr2 vr3 vr27) ; Clobbers imm0 + (li imm0 ppc32::misc-data-offset) + (lvx vr1 arg_z imm0) ; load MSQ + (lvsl vr27 arg_z imm0) ; set the permute vector + (addi imm0 imm0 16) ; address of LSQ + (lvx vr2 arg_z imm0) ; load LSQ + (vperm vr3 vr1 vr2 vr27) ; aligned result appears in VR3 + (dbg t)) ; Look at result in some debugger + (blr)) +|# + +;;; see "Optimizing PowerPC Code" p. 156 +;;; Note that the constant #x4330000080000000 is now in fp-s32conv + +(defppclapmacro int-to-freg (int freg imm) + (target-arch-case + (:ppc32 + `(let ((temp 8) + (temp.h 8) + (temp.l 12)) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd ppc::fp-s32conv temp tsp) + (unbox-fixnum ,imm ,int) + (xoris ,imm ,imm #x8000) ; invert sign of unboxed fixnum + (stw ,imm temp.l tsp) + (lfd ,freg temp tsp) + (lwz tsp 0 tsp) + (fsub ,freg ,freg ppc::fp-s32conv))) + (:ppc64 + `(progn + (unbox-fixnum ,imm ,int) + (std ,imm -8 sp) + (lfd ,freg -8 sp) + (fcfid ,freg ,freg))))) + +;;; Set the most significant bit in DEST, clear all other bits. +(defppclapmacro load-highbit (dest) + (target-arch-case + (:ppc32 + `(lis ,dest #x8000)) + (:ppc64 + `(progn + (lis ,dest #x8000) + (sldi ,dest ,dest 32))))) + +(defppclapmacro extract-bit-shift-count (dest src) + (target-arch-case + (:ppc32 `(clrlwi ,dest ,src (- 32 ppc32::bitmap-shift))) + (:ppc64 `(clrldi ,dest ,src (- 64 ppc64::bitmap-shift))))) + +;;; "index" is the result of subtracting a base address from some +;;; possibly tagged pointer. "bitwords" is the address of the first +;;; word of an (untagged) bitvector. +(defppclapmacro set-bit-at-index (bitwords index &optional (mask ppc::imm3) (count ppc::imm4) (was ppc::imm1)) + (let* ((done (gensym)) + (again (gensym))) + `(progn + (load-highbit ,mask) + (srri ,index ,index ,(target-arch-case + (:ppc32 ppc32::dnode-shift) + (:ppc64 ppc64::dnode-shift))) + (extract-bit-shift-count ,count ,index) + (srr ,mask ,mask ,count) + (srri ,index ,index ,(target-arch-case + (:ppc32 ppc32::bitmap-shift) + (:ppc64 ppc64::bitmap-shift))) + (slri ,index ,index ,(target-arch-case + (:ppc32 ppc32::word-shift) + (:ppc64 ppc64::word-shift))) + (ldrx ,was ,bitwords ,index) + (and. ,was ,was ,mask) + (bne ,done) + ,again + (lrarx ,was ,bitwords ,index) + (or ,was ,was ,mask) + (strcx. ,was ,bitwords ,index) + (bne ,again) + ,done))) + +;;; Like SET-BIT-AT-INDEX, but sets CR0[EQ] iff the index'th bit +;;; is set. +(defppclapmacro test-bit-at-index (bitwords index &optional (mask ppc::imm3) (count ppc::imm4) (was ppc::imm1)) + `(progn + (load-highbit ,mask) + (srri ,index ,index ,(target-arch-case + (:ppc32 ppc32::dnode-shift) + (:ppc64 ppc64::dnode-shift))) + (extract-bit-shift-count ,count ,index) + (srr ,mask ,mask ,count) + (srri ,index ,index ,(target-arch-case + (:ppc32 ppc32::bitmap-shift) + (:ppc64 ppc64::bitmap-shift))) + (slri ,index ,index ,(target-arch-case + (:ppc32 ppc32::word-shift) + (:ppc64 ppc64::word-shift))) + (ldrx ,was ,bitwords ,index) + (and. ,mask ,was ,mask))) + + +(provide "PPC-LAPMACROS") + +;;; end of ppc-lapmacros.lisp Index: /branches/experimentation/later/source/compiler/PPC/ppc2.lisp =================================================================== --- /branches/experimentation/later/source/compiler/PPC/ppc2.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/PPC/ppc2.lisp (revision 8058) @@ -0,0 +1,9074 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 :execute) + (require "NXENV") + (require "PPCENV")) + +(eval-when (:load-toplevel :execute :compile-toplevel) + (require "PPC-BACKEND")) + +(defparameter *ppc2-debug-mask* 0) +(defconstant ppc2-debug-verbose-bit 0) +(defconstant ppc2-debug-vinsns-bit 1) +(defconstant ppc2-debug-lcells-bit 2) +(defparameter *ppc2-target-lcell-size* 0) +(defparameter *ppc2-target-node-size* 0) +(defparameter *ppc2-target-fixnum-shift* 0) +(defparameter *ppc2-target-node-shift* 0) +(defparameter *ppc2-target-bits-in-word* 0) +(defparameter *ppc2-ppc32-half-fixnum-type* '(signed-byte 29)) +(defparameter *ppc2-ppc64-half-fixnum-type* `(signed-byte 60)) +(defparameter *ppc2-target-half-fixnum-type* nil) + + + + +(defun ppc2-immediate-operand (x) + (if (eq (acode-operator x) (%nx1-operator immediate)) + (cadr x) + (compiler-bug "~&Bug: not an immediate: ~s" x))) + +(defmacro with-ppc-p2-declarations (declsform &body body) + `(let* ((*ppc2-tail-allow* *ppc2-tail-allow*) + (*ppc2-reckless* *ppc2-reckless*) + (*ppc2-open-code-inline* *ppc2-open-code-inline*) + (*ppc2-trust-declarations* *ppc2-trust-declarations*)) + (ppc2-decls ,declsform) + ,@body)) + + +(defmacro with-ppc-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)) + `(%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var)))) + (macrolet ((<- (,retvreg-var) + `(ppc2-copy-register ,',segvar ,',vreg-var ,,retvreg-var)) + (@ (,labelnum-var) + `(backend-gen-label ,',segvar ,,labelnum-var)) + (-> (,label-var) + `(! jump (aref *backend-labels* ,,label-var))) + (^ (&rest branch-args) + `(ppc2-branch ,',segvar ,',xfer-var ,',vreg-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 + (if (eq class :gpr) + (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))) + ($ (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 + (if (eq class :gpr) + (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)))) + ,@body)))) + + + + + + + + + + + + +(defvar *ppc-current-context-annotation* nil) +(defvar *ppc2-woi* nil) +(defvar *ppc2-open-code-inline* nil) +(defvar *ppc2-register-restore-count* 0) +(defvar *ppc2-register-restore-ea* nil) +(defvar *ppc2-compiler-register-save-label* nil) +(defvar *ppc2-valid-register-annotations* 0) +(defvar *ppc2-register-annotation-types* nil) +(defvar *ppc2-register-ea-annotations* nil) + +(defparameter *ppc2-tail-call-aliases* + () + #| '((%call-next-method . (%tail-call-next-method . 1))) |# + +) + +(defvar *ppc2-popreg-labels* nil) +(defvar *ppc2-popj-labels* nil) +(defvar *ppc2-valret-labels* nil) +(defvar *ppc2-nilret-labels* nil) + +(defvar *ppc2-icode* nil) +(defvar *ppc2-undo-stack* nil) +(defvar *ppc2-undo-because* nil) + + +(defvar *ppc2-cur-afunc* nil) +(defvar *ppc2-vstack* 0) +(defvar *ppc2-cstack* 0) +(defvar *ppc2-undo-count* 0) +(defvar *ppc2-returning-values* nil) +(defvar *ppc2-vcells* nil) +(defvar *ppc2-fcells* nil) +(defvar *ppc2-entry-vsp-saved-p* nil) + +(defvar *ppc2-entry-label* nil) +(defvar *ppc2-tail-label* nil) +(defvar *ppc2-tail-vsp* nil) +(defvar *ppc2-tail-nargs* nil) +(defvar *ppc2-tail-allow* t) +(defvar *ppc2-reckless* nil) +(defvar *ppc2-trust-declarations* nil) +(defvar *ppc2-entry-vstack* nil) +(defvar *ppc2-fixed-nargs* nil) +(defvar *ppc2-need-nargs* t) + +(defparameter *ppc2-inhibit-register-allocation* nil) +(defvar *ppc2-record-symbols* nil) +(defvar *ppc2-recorded-symbols* nil) + +(defvar *ppc2-result-reg* ppc::arg_z) + + + + + +(declaim (fixnum *ppc2-vstack* *ppc2-cstack*)) + + + + +;;; Before any defppc2's, make the *ppc2-specials* vector. + +(defvar *ppc2-all-lcells* ()) + + + + + +(defun ppc2-free-lcells () + (without-interrupts + (let* ((prev (pool.data *lcell-freelist*))) + (dolist (r *ppc2-all-lcells*) + (setf (lcell-kind r) prev + prev r)) + (setf (pool.data *lcell-freelist*) prev) + (setq *ppc2-all-lcells* nil)))) + +(defun ppc2-note-lcell (c) + (push c *ppc2-all-lcells*) + c) + +(defvar *ppc2-top-vstack-lcell* ()) +(defvar *ppc2-bottom-vstack-lcell* ()) + +(defun ppc2-new-lcell (kind parent width attributes info) + (ppc2-note-lcell (make-lcell kind parent width attributes info))) + +(defun ppc2-new-vstack-lcell (kind width attributes info) + (setq *ppc2-top-vstack-lcell* (ppc2-new-lcell kind *ppc2-top-vstack-lcell* width attributes info))) + +(defun ppc2-reserve-vstack-lcells (n) + (dotimes (i n) (ppc2-new-vstack-lcell :reserved *ppc2-target-lcell-size* 0 nil))) + +(defun ppc2-vstack-mark-top () + (ppc2-new-lcell :tos *ppc2-top-vstack-lcell* 0 0 nil)) + +;;; Alist mapping VARs to lcells/lregs +(defvar *ppc2-var-cells* ()) + +(defun ppc2-note-var-cell (var cell) + ;(format t "~& ~s -> ~s" (var-name var) cell) + (push (cons var cell) *ppc2-var-cells*)) + +(defun ppc2-note-top-cell (var) + (ppc2-note-var-cell var *ppc2-top-vstack-lcell*)) + +(defun ppc2-lookup-var-cell (var) + (or (cdr (assq var *ppc2-var-cells*)) + (and nil (warn "Cell not found for ~s" (var-name var))))) + +(defun ppc2-collect-lcells (kind &optional (bottom *ppc2-bottom-vstack-lcell*) (top *ppc2-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 ppc2-ensure-lcell-offset (c expected) + (if c (= (calc-lcell-offset c) expected) (zerop expected))) + +(defun ppc2-check-lcell-depth (&optional (context "wherever")) + (when (logbitp ppc2-debug-verbose-bit *ppc2-debug-mask*) + (let* ((depth (calc-lcell-depth *ppc2-top-vstack-lcell*))) + (or (= depth *ppc2-vstack*) + (warn "~a: lcell depth = ~d, vstack = ~d" context depth *ppc2-vstack*))))) + +(defun ppc2-do-lexical-reference (seg vreg ea) + (when vreg + (with-ppc-local-vinsn-macros (seg vreg) + (if (memory-spec-p ea) + (ensuring-node-target (target vreg) + (progn + (ppc2-stack-to-register seg ea target) + (if (addrspec-vcell-p ea) + (! vcell-ref target target)))) + (<- ea))))) + +(defun ppc2-do-lexical-setq (seg vreg ea valreg) + (with-ppc-local-vinsn-macros (seg vreg) + (cond ((typep ea 'lreg) + (ppc2-copy-register seg ea valreg)) + ((addrspec-vcell-p ea) ; closed-over vcell + (ppc2-copy-register seg ppc::arg_z valreg) + (ppc2-stack-to-register seg ea ppc::arg_x) + (ppc2-copy-register seg ppc::arg_y ppc::rzero) + (! call-subprim-3 ppc::arg_z (subprim-name->offset '.SPgvset) ppc::arg_x ppc::arg_y ppc::arg_z)) + ((memory-spec-p ea) ; vstack slot + (ppc2-register-to-stack seg valreg ea)) + (t + (ppc2-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 ppc2-heap-cons-next-method-var (seg var) + (with-ppc-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 ($ ppc::arg_z)) + (result ($ ppc::arg_z))) + (ppc2-do-lexical-reference seg arg ea) + (ppc2-set-nargs seg 1) + (! ref-constant ($ ppc::fname) (backend-immediate-index (ppc2-symbol-entry-locative '%cons-magic-next-method-arg))) + (! call-known-symbol arg) + (ppc2-do-lexical-setq seg nil ea result))))) + +(defun ppc2-reverse-cc (cc) + ; NE NE EQ EQ LE GE LT GT GE LE GT LT MI PL PL MI + (%cdr (assq cc '((6 . 6) (7 . 7) (15 . 12) (13 . 14) (12 . 15) (14 . 13) (11 . 10) (10 . 11))))) + + ; NE NE EQ EQ LE GE LT GT GE LE GT LT MI PL PL MI +(defun ppc2-reverse-condition-keyword (k) + (cdr (assq k '((:ne . :ne) (:eq . :eq) (:le . :ge) (:lt . :gt) (:ge . :le) (:gt . :lt))))) + + + + +(defun acode-condition-to-ppc-cr-bit (cond) + (condition-to-ppc-cr-bit (cadr cond))) + +(defun condition-to-ppc-cr-bit (cond) + (case cond + (:EQ (values ppc::ppc-eq-bit t)) + (:NE (values ppc::ppc-eq-bit nil)) + (:GT (values ppc::ppc-gt-bit t)) + (:LE (values ppc::ppc-gt-bit nil)) + (:LT (values ppc::ppc-lt-bit t)) + (:GE (values ppc::ppc-lt-bit 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 ppc2-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 ppc2-ensure-binding-indices-for-vcells (vcells) + (dolist (cell vcells) + (ensure-binding-index (car cell))) + vcells) + +(defun ppc2-compile (afunc &optional lambda-form *ppc2-record-symbols*) + (progn + (dolist (a (afunc-inner-functions afunc)) + (unless (afunc-lfun a) + (ppc2-compile a + (if lambda-form + (afunc-lambdaform a)) + *ppc2-record-symbols*))) ; always compile inner guys + (let* ((*ppc2-cur-afunc* afunc) + (*ppc2-returning-values* nil) + (*ppc-current-context-annotation* nil) + (*ppc2-woi* nil) + (*next-lcell-id* -1) + (*ppc2-open-code-inline* nil) + (*ppc2-register-restore-count* nil) + (*ppc2-compiler-register-save-label* nil) + (*ppc2-valid-register-annotations* 0) + (*ppc2-register-ea-annotations* (ppc2-make-stack 16)) + (*ppc2-register-restore-ea* nil) + (*ppc2-vstack* 0) + (*ppc2-cstack* 0) + (*ppc2-target-lcell-size* (arch::target-lisp-node-size (backend-target-arch *target-backend*))) + (*ppc2-target-fixnum-shift* (arch::target-fixnum-shift (backend-target-arch *target-backend*))) + (*ppc2-target-node-shift* (arch::target-word-shift (backend-target-arch *target-backend*))) + (*ppc2-target-bits-in-word* (arch::target-nbits-in-word (backend-target-arch *target-backend*))) + (*ppc2-target-node-size* *ppc2-target-lcell-size*) + (*ppc2-target-half-fixnum-type* (target-word-size-case + (32 *ppc2-ppc32-half-fixnum-type*) + (64 *ppc2-ppc64-half-fixnum-type*))) + (*ppc2-all-lcells* ()) + (*ppc2-top-vstack-lcell* nil) + (*ppc2-bottom-vstack-lcell* (ppc2-new-vstack-lcell :bottom 0 0 nil)) + (*ppc2-var-cells* nil) + (*backend-vinsns* (backend-p2-vinsn-templates *target-backend*)) + (*backend-node-regs* ppc-node-regs) + (*backend-node-temps* ppc-temp-node-regs) + (*available-backend-node-temps* ppc-temp-node-regs) + (*backend-imm-temps* ppc-imm-regs) + (*available-backend-imm-temps* ppc-imm-regs) + (*backend-crf-temps* ppc-cr-fields) + (*available-backend-crf-temps* ppc-cr-fields) + (*backend-fp-temps* ppc-temp-fp-regs) + (*available-backend-fp-temps* ppc-temp-fp-regs) + (bits 0) + (*logical-register-counter* -1) + (*backend-all-lregs* ()) + (*ppc2-popj-labels* nil) + (*ppc2-popreg-labels* nil) + (*ppc2-valret-labels* nil) + (*ppc2-nilret-labels* nil) + (*ppc2-undo-count* 0) + (*backend-labels* (ppc2-make-stack 64 target::subtag-simple-vector)) + (*ppc2-undo-stack* (ppc2-make-stack 64 target::subtag-simple-vector)) + (*ppc2-undo-because* (ppc2-make-stack 64)) + (*backend-immediates* (ppc2-make-stack 64 target::subtag-simple-vector)) + (*ppc2-entry-label* nil) + (*ppc2-tail-label* nil) + (*ppc2-tail-vsp* nil) + (*ppc2-tail-nargs* nil) + (*ppc2-inhibit-register-allocation* nil) + (*ppc2-tail-allow* t) + (*ppc2-reckless* nil) + (*ppc2-trust-declarations* t) + (*ppc2-entry-vstack* nil) + (*ppc2-fixed-nargs* nil) + (*ppc2-need-nargs* t) + (fname (afunc-name afunc)) + (*ppc2-entry-vsp-saved-p* nil) + (*ppc2-vcells* (ppc2-ensure-binding-indices-for-vcells (afunc-vcells afunc))) + (*ppc2-fcells* (afunc-fcells afunc)) + *ppc2-recorded-symbols*) + (set-fill-pointer + *backend-labels* + (set-fill-pointer + *ppc2-undo-stack* + (set-fill-pointer + *ppc2-undo-because* + (set-fill-pointer + *backend-immediates* 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 (ppc2-form vinsns (make-wired-lreg *ppc2-result-reg*) $backend-return (afunc-acode afunc))) + (dotimes (i (length *backend-immediates*)) + (let ((imm (aref *backend-immediates* i))) + (when (ppc2-symbol-locative-p imm) (aset *backend-immediates* i (car imm))))) + (optimize-vinsns vinsns) + (when (logbitp ppc2-debug-vinsns-bit *ppc2-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 (*lap-instructions* *lap-instruction-freelist*) + (let* ((*lap-labels* nil)) + (ppc2-expand-vinsns vinsns) + (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (let* ((function-debugging-info (afunc-lfun-info afunc))) + (when (or function-debugging-info lambda-form *ppc2-record-symbols*) + (if lambda-form (setq function-debugging-info + (list* 'function-lambda-expression lambda-form function-debugging-info))) + (if *ppc2-record-symbols* + (setq function-debugging-info (nconc (list 'function-symbol-map *ppc2-recorded-symbols*) + function-debugging-info))) + (setq bits (logior (ash 1 $lfbits-symmap-bit) bits)) + (backend-new-immediate function-debugging-info))) + (if (or fname lambda-form *ppc2-recorded-symbols*) + (backend-new-immediate fname) + (setq bits (logior (ash -1 $lfbits-noname-bit) bits))) + (unless (afunc-parent afunc) + (ppc2-fixup-fwd-refs afunc)) + (setf (afunc-all-vars afunc) nil) + (setf (afunc-argsword afunc) bits) + (let* ((regsave-label (if (typep *ppc2-compiler-register-save-label* 'vinsn-note) + (vinsn-label-info (vinsn-note-label *ppc2-compiler-register-save-label*)))) + (regsave-reg (if regsave-label (- 32 *ppc2-register-restore-count*))) + (regsave-addr (if regsave-label (- *ppc2-register-restore-ea*)))) + (setf (afunc-lfun afunc) + (ppc2-xmake-function + *lap-instructions* + *lap-labels* + *backend-immediates* + bits + regsave-label + regsave-reg + regsave-addr + (if (and fname (symbolp fname)) (symbol-name fname))))) + (ppc2-digest-symbols)))) + (backend-remove-labels)))) + afunc)) + +(defun ppc2-xmake-function (codeheader labels imms bits *ppc-lap-regsave-label* *ppc-lap-regsave-reg* *ppc-lap-regsave-addr* &optional traceback-string) + (let* ((*lap-instructions* codeheader) + (*lap-labels* labels) + (cross-compiling (not (eq *host-backend* *target-backend*))) + (numimms (length imms)) + (function (%alloc-misc (+ numimms 2) + (if cross-compiling + target::subtag-xfunction + target::subtag-function)))) + (dotimes (i numimms) + (setf (uvref function (1+ i)) (aref imms i))) + (setf (uvref function (+ numimms 1)) bits) + (let* ((maxpc (ppc-lap-encode-regsave-info (ppc-lap-do-labels))) + (traceback-size (traceback-fullwords traceback-string)) + (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*))) + (prefix-size (length prefix)) + (code-vector-size (+ traceback-size (ash maxpc -2) prefix-size))) + #+ppc32-target + (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow)) + (let* ((code-vector (%alloc-misc code-vector-size + (if cross-compiling + target::subtag-xcode-vector + target::subtag-code-vector))) + (i prefix-size)) + (dotimes (i prefix-size) + (setf (uvref code-vector i) (pop prefix))) + (ppc-lap-resolve-labels) + (do-dll-nodes (insn *lap-instructions*) + (ppc-lap-generate-instruction code-vector i insn) + (incf i)) + (unless (eql 0 traceback-size) + (add-traceback-table code-vector i traceback-string)) + (setf (uvref function 0) code-vector) + (%make-code-executable code-vector) + function)))) + + +(defun ppc2-make-stack (size &optional (subtype target::subtag-s16-vector)) + (make-uarray-1 subtype size t 0 nil nil nil nil t nil)) + +(defun ppc2-fixup-fwd-refs (afunc) + (dolist (f (afunc-inner-functions afunc)) + (ppc2-fixup-fwd-refs f)) + (let ((fwd-refs (afunc-fwd-refs afunc))) + (when fwd-refs + (let* ((v (afunc-lfun afunc)) + (vlen (uvsize v))) + (declare (fixnum vlen)) + (dolist (ref fwd-refs) + (let* ((ref-fun (afunc-lfun ref))) + (do* ((i 1 (1+ i))) + ((= i vlen)) + (declare (fixnum i)) + (if (eq (%svref v i) ref) + (setf (%svref v i) ref-fun))))))))) + +(defun ppc2-digest-symbols () + (if *ppc2-recorded-symbols* + (let* ((symlist *ppc2-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))) + (flet ((label-address (note start-p sym) + (let* ((label (vinsn-note-label note)) + (lap-label (if label (vinsn-label-info label)))) + (if lap-label + (lap-label-address lap-label) + (compiler-bug "Missing or bad ~s label: ~s" + (if start-p 'start 'end) sym))))) + (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)) (label-address startlab t sym)) + (setf (aref ptrs (incf i)) (label-address endlab nil sym)))))))) + +(defun ppc2-decls (decls) + (if (fixnump decls) + (locally (declare (fixnum decls)) + (setq *ppc2-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls)) + *ppc2-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls)) + *ppc2-reckless* (neq 0 (%ilogand2 $decl_unsafe decls)) + *ppc2-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls)))))) + + +(defun %ppc2-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 ppc2-partition-vars (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 + (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits)))) + 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))))) + (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 ppc2-allocate-global-registers (fcells vcells all-vars no-regs) + (if no-regs + (progn + (dolist (c fcells) (%rplacd c nil)) + (dolist (c vcells) (%rplacd c nil)) + (values 0 nil)) + (let* ((maybe (ppc2-partition-vars all-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 #'%ppc2-bigger-cdr-than) (cdr things)) + (n 0 (1+ n)) + (regno ppc::save0 (1- regno)) + (constant-alist ())) + ((or (null things) (= n $numppcsaveregs)) + (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)) + (nx-set-var-bits var + (%ilogior (%ilogand (%ilognot $vrefmask) (nx-var-bits var)) + regno + (%ilsl $vbitreg 1)))))))))) + + +;;; Vpush the last N non-volatile-registers. +;;; Could use a STM here, especially if N is largish or optimizing for space. +(defun ppc2-save-nvrs (seg n) + (declare (fixnum n)) + (when (> n 0) + (setq *ppc2-compiler-register-save-label* (ppc2-emit-note seg :regsave)) + (with-ppc-local-vinsn-macros (seg) + (if *ppc2-open-code-inline* + (! save-nvrs-individually (- 32 n)) + (! save-nvrs (- 32 n)))) + (dotimes (i n) + (ppc2-new-vstack-lcell :regsave *ppc2-target-lcell-size* 0 (- ppc::save0 i))) + (incf *ppc2-vstack* (the fixnum (* n *ppc2-target-node-size*))) + (setq *ppc2-register-restore-ea* *ppc2-vstack* + *ppc2-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.) +;;; We DON'T try to compute this from the saved context, since the +;;; saved vsp may belong to a different stack segment. (It's cheaper +;;; to compute/copy than to load it, anyway.) + +(defun ppc2-restore-nvrs (seg ea nregs &optional from-fp) + (when (null from-fp) + (setq from-fp ppc::vsp)) + (when (and ea nregs) + (with-ppc-local-vinsn-macros (seg) + (let* ((first (- 32 nregs))) + (declare (fixnum cell first n)) + (! restore-nvrs first from-fp (- *ppc2-vstack* ea)))))) + + + +(defun ppc2-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)) + (ppc2-check-lcell-depth) + (dolist (arg inherited) + (if (memq arg passed-in-regs) + (ppc2-set-var-ea seg arg (var-ea arg)) + (let* ((lcell (pop lcells))) + (if (setq reg (ppc2-assign-register-var arg)) + (ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc)) + (ppc2-bind-var seg arg vloc lcell)) + (setq vloc (%i+ vloc *ppc2-target-node-size*))))) + (dolist (arg req) + (if (memq arg passed-in-regs) + (ppc2-set-var-ea seg arg (var-ea arg)) + (let* ((lcell (pop lcells))) + (if (setq reg (ppc2-assign-register-var arg)) + (ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc)) + (ppc2-bind-var seg arg vloc lcell)) + (setq vloc (%i+ vloc *ppc2-target-node-size*))))) + (when opt + (if (ppc2-hard-opt-p opt) + (setq vloc (apply #'ppc2-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) + (ppc2-set-var-ea seg var (var-ea var)) + (let* ((lcell (pop lcells))) + (if (setq reg (ppc2-assign-register-var var)) + (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) + (ppc2-bind-var seg var vloc lcell)) + (setq vloc (+ vloc *ppc2-target-node-size*))))))) + (when rest + (if lexpr + (progn + (if (setq reg (ppc2-assign-register-var rest)) + (progn + (ppc2-load-lexpr-address seg reg) + (ppc2-set-var-ea seg rest reg)) + (with-imm-temps () ((nargs-cell :natural)) + (ppc2-load-lexpr-address seg nargs-cell) + (let* ((loc *ppc2-vstack*)) + (ppc2-vpush-register seg nargs-cell :reserved) + (ppc2-note-top-cell rest) + (ppc2-bind-var seg rest loc *ppc2-top-vstack-lcell*))))) + (let* ((rvloc (+ vloc (* 2 *ppc2-target-node-size* nkeys)))) + (if (setq reg (ppc2-assign-register-var rest)) + (ppc2-init-regvar seg rest reg (ppc2-vloc-ea rvloc)) + (ppc2-bind-var seg rest rvloc (pop lcells)))))) + (when keys + (apply #'ppc2-init-keys seg vloc lcells keys)) + (ppc2-seq-bind seg (%car auxen) (%cadr auxen))) + +(defun ppc2-initopt (seg vloc spvloc lcells splcells vars inits spvars) + (with-ppc-local-vinsn-macros (seg) + (dolist (var vars vloc) + (let* ((initform (pop inits)) + (spvar (pop spvars)) + (lcell (pop lcells)) + (splcell (pop splcells)) + (reg (ppc2-assign-register-var var)) + (sp-reg ($ ppc::arg_z)) + (regloadedlabel (if reg (backend-get-next-label)))) + (unless (nx-null initform) + (ppc2-stack-to-register seg (ppc2-vloc-ea spvloc) sp-reg) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t)) + (if reg + (ppc2-form seg reg regloadedlabel initform) + (ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc))) + (@ skipinitlabel))) + (if reg + (progn + (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) + (@ regloadedlabel)) + (ppc2-bind-var seg var vloc lcell)) + (when spvar + (if (setq reg (ppc2-assign-register-var spvar)) + (ppc2-init-regvar seg spvar reg (ppc2-vloc-ea spvloc)) + (ppc2-bind-var seg spvar spvloc splcell)))) + (setq vloc (%i+ vloc *ppc2-target-node-size*)) + (if spvloc (setq spvloc (%i+ spvloc *ppc2-target-node-size*)))))) + +(defun ppc2-init-keys (seg vloc lcells allow-others keyvars keysupp keyinits keykeys) + (declare (ignore keykeys allow-others)) + (with-ppc-local-vinsn-macros (seg) + (dolist (var keyvars) + (let* ((spvar (pop keysupp)) + (initform (pop keyinits)) + (reg (ppc2-assign-register-var var)) + (regloadedlabel (if reg (backend-get-next-label))) + (var-lcell (pop lcells)) + (sp-lcell (pop lcells)) + (sp-reg ($ ppc::arg_z)) + (sploc (%i+ vloc *ppc2-target-node-size*))) + (unless (nx-null initform) + (ppc2-stack-to-register seg (ppc2-vloc-ea sploc) sp-reg) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t)) + (if reg + (ppc2-form seg reg regloadedlabel initform) + (ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc))) + (@ skipinitlabel))) + (if reg + (progn + (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) + (@ regloadedlabel)) + (ppc2-bind-var seg var vloc var-lcell)) + (when spvar + (if (setq reg (ppc2-assign-register-var spvar)) + (ppc2-init-regvar seg spvar reg (ppc2-vloc-ea sploc)) + (ppc2-bind-var seg spvar sploc sp-lcell)))) + (setq vloc (%i+ vloc (* 2 *ppc2-target-node-size*)))))) + +;;; Vpush register r, unless var gets a globally-assigned register. +;;; Return NIL if register was vpushed, else var. +(defun ppc2-vpush-arg-register (seg reg var) + (when var + (let* ((bits (nx-var-bits var))) + (declare (fixnum bits)) + (if (logbitp $vbitreg bits) + var + (progn + (ppc2-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 ppc2-argregs-entry (seg revargs) + (with-ppc-local-vinsn-macros (seg) + (let* ((nargs (length revargs)) + (reg-vars ())) + (declare (type (unsigned-byte 16) nargs)) + (! save-lr) + (if (<= nargs $numppcargregs) ; caller didn't vpush anything + (if *ppc2-open-code-inline* + (! save-lisp-context-vsp) + (! save-lisp-context-vsp-ool)) + (let* ((offset (* (the fixnum (- nargs $numppcargregs)) *ppc2-target-node-size*))) + (declare (fixnum offset)) + (if *ppc2-open-code-inline* + (! save-lisp-context-offset offset) + (! save-lisp-context-offset-ool offset)))) + (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs + (let* ((nstackargs (length stack-args))) + (ppc2-set-vstack (* nstackargs *ppc2-target-node-size*)) + (dotimes (i nstackargs) + (ppc2-new-vstack-lcell :reserved *ppc2-target-lcell-size* 0 nil)) + (if (>= nargs 3) + (push (ppc2-vpush-arg-register seg ($ ppc::arg_x) xvar) reg-vars)) + (if (>= nargs 2) + (push (ppc2-vpush-arg-register seg ($ ppc::arg_y) yvar) reg-vars)) + (if (>= nargs 1) + (push (ppc2-vpush-arg-register seg ($ ppc::arg_z) zvar) reg-vars)))) + reg-vars))) + +;;; Just required args. +;;; Since this is just a stupid bootstrapping port, always save +;;; lisp context. +(defun ppc2-req-nargs-entry (seg rev-fixed-args) + (let* ((nargs (length rev-fixed-args))) + (declare (type (unsigned-byte 16) nargs)) + (with-ppc-local-vinsn-macros (seg) + (unless *ppc2-reckless* + (! check-exact-nargs nargs)) + (ppc2-argregs-entry seg rev-fixed-args)))) + +;;; No more than three &optional args; all default to NIL and none have +;;; supplied-p vars. No &key/&rest. +(defun ppc2-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-ppc-local-vinsn-macros (seg) + (unless *ppc2-reckless* + (when rev-req-args + (! check-min-nargs min)) + (! check-max-nargs max)) + (if (= nopt 1) + (! default-1-arg min) + (if (= nopt 2) + (! default-2-args min) + (! default-3-args min))) + (ppc2-argregs-entry seg (append rev-opt-args rev-req-args))))) + +;;; 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 ppc2-lexpr-entry (seg num-fixed) + (with-ppc-local-vinsn-macros (seg) + (! save-lexpr-argregs num-fixed) + (dotimes (i num-fixed) + (! copy-lexpr-argument)) + (! save-lisp-context-lexpr))) + +(defun ppc2-load-lexpr-address (seg dest) + (with-ppc-local-vinsn-macros (seg) + (! load-vframe-address dest *ppc2-vstack*))) + + +(defun ppc2-structured-initopt (seg lcells vloc context vars inits spvars) + (with-ppc-local-vinsn-macros (seg) + (dolist (var vars vloc) + (let* ((initform (pop inits)) + (spvar (pop spvars)) + (spvloc (%i+ vloc *ppc2-target-node-size*)) + (var-lcell (pop lcells)) + (sp-reg ($ ppc::arg_z)) + (sp-lcell (pop lcells))) + (unless (nx-null initform) + (ppc2-stack-to-register seg (ppc2-vloc-ea spvloc) sp-reg) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t)) + (ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc)) + (@ skipinitlabel))) + (ppc2-bind-structured-var seg var vloc var-lcell context) + (when spvar + (ppc2-bind-var seg spvar spvloc sp-lcell))) + (setq vloc (%i+ vloc (* 2 *ppc2-target-node-size*)))))) + + + +(defun ppc2-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys) + (declare (ignore keykeys allow-others)) + (with-ppc-local-vinsn-macros (seg) + (dolist (var keyvars) + (let* ((spvar (pop keysupp)) + (initform (pop keyinits)) + (sploc (%i+ vloc *ppc2-target-node-size*)) + (var-lcell (pop lcells)) + (sp-reg ($ ppc::arg_z)) + (sp-lcell (pop lcells))) + (unless (nx-null initform) + (ppc2-stack-to-register seg (ppc2-vloc-ea sploc) sp-reg) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t)) + (ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc)) + (@ skipinitlabel))) + (ppc2-bind-structured-var seg var vloc var-lcell context) + (when spvar + (ppc2-bind-var seg spvar sploc sp-lcell))) + (setq vloc (%i+ vloc (* 2 *ppc2-target-node-size*)))))) + +(defun ppc2-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 ppc2-form (seg vreg xfer form) + (if (nx-null form) + (ppc2-nil seg vreg xfer) + (if (nx-t form) + (ppc2-t seg vreg xfer) + (let* ((op nil) + (fn nil)) + (if (and (consp form) + (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form)))))) + (if (and (null vreg) + (%ilogbitp operator-acode-subforms-bit op) + (%ilogbitp operator-assignment-free-bit op)) + (dolist (f (%cdr form) (ppc2-branch seg xfer nil)) + (ppc2-form seg nil nil f )) + (apply fn seg vreg xfer (%cdr form))) + (compiler-bug "ppc2-form ? ~s" form)))))) + +;;; dest is a float reg - form is acode +(defun ppc2-form-float (seg freg xfer form) + (declare (ignore xfer)) + (when (or (nx-null form)(nx-t form))(compiler-bug "ppc2-form to freg ~s" form)) + (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double) + (ppc2-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 nil)) + (if (and (consp form) + (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (acode-operator form))))) + (apply fn seg freg nil (%cdr form)) + (compiler-bug "ppc2-form ? ~s" form)))) + + + +(defun ppc2-form-typep (form type) + (acode-form-typep form type *ppc2-trust-declarations*) +) + +(defun ppc2-form-type (form) + (acode-form-type form *ppc2-trust-declarations*)) + +(defun ppc2-use-operator (op seg vreg xfer &rest forms) + (declare (dynamic-extent forms)) + (apply (svref *ppc2-specials* (%ilogand operator-id-mask op)) seg vreg xfer forms)) + +;;; Returns true iff lexical variable VAR isn't setq'ed in FORM. +;;; Punts a lot ... +(defun ppc2-var-not-set-by-form-p (var form) + (or (not (%ilogbitp $vbitsetq (nx-var-bits var))) + (ppc2-setqed-var-not-set-by-form-p var form))) + +(defun ppc2-setqed-var-not-set-by-form-p (var form) + (setq form (acode-unwrapped-form form)) + (or (atom form) + (ppc-constant-form-p form) + (ppc2-lexical-reference-p form) + (let ((op (acode-operator form)) + (subforms nil)) + (if (eq op (%nx1-operator setq-lexical)) + (and (neq var (cadr form)) + (ppc2-setqed-var-not-set-by-form-p var (caddr form))) + (and (%ilogbitp operator-side-effect-free-bit op) + (flet ((not-set-in-formlist (formlist) + (dolist (subform formlist t) + (unless (ppc2-setqed-var-not-set-by-form-p var subform) (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))) + (ppc2-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 ppc2-nil (seg vreg xfer) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (ppc2-for-value-p vreg) + (ensuring-node-target (target vreg) + (! load-nil target))) + (ppc2-branch seg (ppc2-cd-false xfer) vreg))) + +(defun ppc2-t (seg vreg xfer) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (ppc2-for-value-p vreg) + (ensuring-node-target (target vreg) + (! load-t target))) + (ppc2-branch seg (ppc2-cd-true xfer) vreg))) + +(defun ppc2-for-value-p (vreg) + (and vreg (not (backend-crf-p vreg)))) + +(defun ppc2-mvpass (seg form &optional xfer) + (with-ppc-local-vinsn-macros (seg) + (ppc2-form seg ($ ppc::arg_z) (logior (or xfer 0) $backend-mvpass-mask) form))) + +(defun ppc2-adjust-vstack (delta) + (ppc2-set-vstack (%i+ *ppc2-vstack* delta))) + +(defun ppc2-set-vstack (new) + (setq *ppc2-vstack* new)) + + +;;; Emit a note at the end of the segment. +(defun ppc2-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 ppc-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 ppc2-close-note (seg note) + (let* ((end (close-vinsn-note note))) + (append-dll-node (vinsn-note-label end) seg) + end)) + + + + + + +(defun ppc2-stack-to-register (seg memspec reg) + (with-ppc-local-vinsn-macros (seg) + (! vframe-load reg (memspec-frame-address-offset memspec) *ppc2-vstack*))) + +(defun ppc2-lcell-to-register (seg lcell reg) + (with-ppc-local-vinsn-macros (seg) + (! lcell-load reg lcell (ppc2-vstack-mark-top)))) + +(defun ppc2-register-to-lcell (seg reg lcell) + (with-ppc-local-vinsn-macros (seg) + (! lcell-store reg lcell (ppc2-vstack-mark-top)))) + +(defun ppc2-register-to-stack (seg reg memspec) + (with-ppc-local-vinsn-macros (seg) + (! vframe-store reg (memspec-frame-address-offset memspec) *ppc2-vstack*))) + + +(defun ppc2-ea-open (ea) + (if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea)) + (make-memory-spec (memspec-frame-address-offset ea)) + ea)) + +(defun ppc2-set-NARGS (seg n) + (if (> n call-arguments-limit) + (compiler-bug "~s exceeded." call-arguments-limit) + (with-ppc-local-vinsn-macros (seg) + (! set-nargs n)))) + +(defun ppc2-assign-register-var (v) + (let ((bits (nx-var-bits v))) + (when (%ilogbitp $vbitreg bits) + (%ilogand bits $vrefmask)))) + +(defun ppc2-single-float-bits (the-sf) + (single-float-bits the-sf)) + +(defun ppc2-double-float-bits (the-df) + (double-float-bits the-df)) + +(defun ppc2-immediate (seg vreg xfer form) + (with-ppc-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* ((bits (ppc2-single-float-bits form))) + (with-imm-temps () ((bitsreg :u32)) + (! lri bitsreg bits) + (! load-single-float-constant vreg bitsreg))) + (multiple-value-bind (high low) (ppc2-double-float-bits form) + (declare (integer high low)) + (with-imm-temps () ((highreg :u32) (lowreg :u32)) + (if (zerop high) + (setq highreg ($ ppc::rzero)) + (! lri highreg high)) + (if (zerop low) + (setq lowreg ($ ppc::rzero)) + (! lri lowreg low)) + (! load-double-float-constant vreg highreg lowreg))))) + (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)) + (ppc2-lri seg vreg form) + (ensuring-node-target + (target vreg) + (if (characterp form) + (! load-character-constant target (char-code form)) + (ppc2-store-immediate seg form target))))) + (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*)) + (ppc2-store-immediate seg form ($ ppc::temp0)))) + (^))) + +(defun ppc2-register-constant-p (form) + (and (consp form) + (or (memq form *ppc2-vcells*) + (memq form *ppc2-fcells*)) + (%cdr form))) + +(defun ppc2-store-immediate (seg imm dest) + (with-ppc-local-vinsn-macros (seg) + (let* ((reg (ppc2-register-constant-p imm))) + (if reg + (ppc2-copy-register seg dest reg) + (let* ((idx (backend-immediate-index imm))) + (target-arch-case + (:ppc32 + (if (< idx 8192) + (! ref-constant dest idx) + (with-imm-target () (idxreg :s32) + (ppc2-lri seg idxreg (+ ppc32::misc-data-offset (ash (1+ idx) 2))) + (! ref-indexed-constant dest idxreg)))) + (:ppc64 + (if (< idx 4096) + (! ref-constant dest idx) + (with-imm-target () (idxreg :s64) + (ppc2-lri seg idxreg (+ ppc64::misc-data-offset (ash (1+ idx) 3))) + (! ref-indexed-constant dest idxreg))))))) + dest))) + + +;;; Returns label iff form is (local-go ) and can go without adjusting stack. +(defun ppc2-go-label (form) + (let ((current-stack (ppc2-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)) + (ppc2-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 (ppc2-equal-encodings-p (cdr tagdata) current-stack) + (null (caar tagdata)) + (< 0 (cdar tagdata) $backend-mvpass) + (cdar tagdata))))))))) + +(defun ppc2-single-valued-form-p (form) + (setq form (acode-unwrapped-form 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 ppc2-box-s32 (seg node-dest s32-src) + (with-ppc-local-vinsn-macros (seg) + (if (target-arch-case + (:ppc32 *ppc2-open-code-inline*) + (:ppc64 t)) + (! s32->integer node-dest s32-src) + (let* ((arg_z ($ ppc::arg_z)) + (imm0 ($ ppc::imm0 :mode :s32))) + (ppc2-copy-register seg imm0 s32-src) + (! call-subprim (subprim-name->offset '.SPmakes32)) + (ppc2-copy-register seg node-dest arg_z))))) + +(defun ppc2-box-s64 (seg node-dest s64-src) + (with-ppc-local-vinsn-macros (seg) + (if (target-arch-case + (:ppc32 (compiler-bug "Bug!")) + (:ppc64 *ppc2-open-code-inline*)) + (! s64->integer node-dest s64-src) + (let* ((arg_z ($ ppc::arg_z)) + (imm0 ($ ppc::imm0 :mode :s64))) + (ppc2-copy-register seg imm0 s64-src) + (! call-subprim (subprim-name->offset '.SPmakes64)) + (ppc2-copy-register seg node-dest arg_z))))) + +(defun ppc2-box-u32 (seg node-dest u32-src) + (with-ppc-local-vinsn-macros (seg) + (if (target-arch-case + (:ppc32 *ppc2-open-code-inline*) + (:ppc64 t)) + (! u32->integer node-dest u32-src) + (let* ((arg_z ($ ppc::arg_z)) + (imm0 ($ ppc::imm0 :mode :u32))) + (ppc2-copy-register seg imm0 u32-src) + (! call-subprim (subprim-name->offset '.SPmakeu32)) + (ppc2-copy-register seg node-dest arg_z))))) + +(defun ppc2-box-u64 (seg node-dest u64-src) + (with-ppc-local-vinsn-macros (seg) + (if (target-arch-case + (:ppc32 (compiler-bug "Bug!")) + (:ppc64 *ppc2-open-code-inline*)) + (! u64->integer node-dest u64-src) + (let* ((arg_z ($ ppc::arg_z)) + (imm0 ($ ppc::imm0 :mode :u64))) + (ppc2-copy-register seg imm0 u64-src) + (! call-subprim (subprim-name->offset '.SPmakeu64)) + (ppc2-copy-register seg node-dest arg_z))))) + +(defun ppc2-vref1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum) + (with-ppc-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 (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)) + (temp-is-vreg nil)) + (cond + (is-node + (ensuring-node-target (target vreg) + (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))))) + (! misc-ref-c-node target src index-known-fixnum) + (with-imm-target () (idx-reg :u64) + (if index-known-fixnum + (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *ppc2-target-node-shift*))) + (! scale-node-misc-index idx-reg unscaled-idx)) + (! misc-ref-node target src idx-reg))))) + (is-32-bit + (with-imm-target () (temp :u32) + (with-fp-target () (fp-val :single-float) + (if (eql vreg-class hard-reg-class-gpr) + (if + (if is-signed + (or (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-s64)) + (or (eql vreg-mode hard-reg-class-gpr-mode-u32) + (eql vreg-mode hard-reg-class-gpr-mode-u64))) + (setq temp vreg temp-is-vreg t) + (if is-signed + (set-regspec-mode temp hard-reg-class-gpr-mode-s32))) + (if (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-single)) + (setf fp-val vreg temp-is-vreg t))) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch))) + (cond ((eq type-keyword :single-float-vector) + (! misc-ref-c-single-float fp-val src index-known-fixnum)) + (t + (if is-signed + (! misc-ref-c-s32 temp src index-known-fixnum) + (! misc-ref-c-u32 temp src index-known-fixnum))))) + (with-imm-target () idx-reg + (if index-known-fixnum + (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) + (! scale-32bit-misc-index idx-reg unscaled-idx)) + (cond ((eq type-keyword :single-float-vector) + (! misc-ref-single-float fp-val src idx-reg)) + (t + (if is-signed + (! misc-ref-s32 temp src idx-reg) + (! misc-ref-u32 temp src idx-reg))))) + (case type-keyword + (:single-float-vector + (if (eq vreg-class hard-reg-class-fpr) + (<- fp-val) + (ensuring-node-target (target vreg) + (! single->node target fp-val)))) + (:signed-32-bit-vector + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (ppc2-box-s32 seg target temp)))) + (:fixnum-vector + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (! box-fixnum target temp)))) + (:simple-string + (ensuring-node-target (target vreg) + (! u32->char target temp))) + (t + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (ppc2-box-u32 seg target temp)))))))) + (is-8-bit + (with-imm-target () (temp :u8) + (if (and (eql vreg-class hard-reg-class-gpr) + (or + (and is-signed + (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 (not is-signed) + (or (eql vreg-mode hard-reg-class-gpr-mode-u8) + (eql vreg-mode hard-reg-class-gpr-mode-s16) + (eql vreg-mode hard-reg-class-gpr-mode-u16) + (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-u32) + (eql vreg-mode hard-reg-class-gpr-mode-s64) + (eql vreg-mode hard-reg-class-gpr-mode-u64))))) + (setq temp vreg temp-is-vreg t) + (if is-signed + (set-regspec-mode temp hard-reg-class-gpr-mode-s8))) + (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-imm-target () idx-reg + (if index-known-fixnum + (ppc2-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)))) + (ecase type-keyword + (:unsigned-8-bit-vector + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (! box-fixnum target temp)))) + (:signed-8-bit-vector + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (! box-fixnum target temp)))) + (:simple-string + (ensuring-node-target (target vreg) + (! u32->char target temp)))))) + (is-16-bit + (ensuring-node-target (target vreg) + (with-imm-target () temp + (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 + (ppc2-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)))) + (is-64-bit + (with-fp-target () (fp-val :double-float) + (with-imm-target () (temp :u64) + (if (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-double)) + (setq fp-val vreg) + (if (eql vreg-class hard-reg-class-gpr) + (if (or (and is-signed + (eql vreg-mode hard-reg-class-gpr-mode-s64)) + (and (not is-signed) + (eql vreg-mode hard-reg-class-gpr-mode-u64))) + (setf temp vreg temp-is-vreg t) + (if is-signed + (set-regspec-mode temp hard-reg-class-gpr-mode-s64))))) + (case type-keyword + (:double-float-vector + (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) + (with-imm-target () idx-reg + (if index-known-fixnum + (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))) + (! scale-64bit-misc-index idx-reg unscaled-idx)) + (! misc-ref-double-float fp-val src idx-reg))) + (if (eq vreg-class hard-reg-class-fpr) + (<- fp-val) + (ensuring-node-target (target vreg) + (! double->heap target fp-val)))) + ((:signed-64-bit-vector :fixnum-vector) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-ref-c-s64 temp src index-known-fixnum) + (with-imm-target () idx-reg + (if index-known-fixnum + (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))) + (! scale-64bit-misc-index idx-reg unscaled-idx)) + (! misc-ref-s64 temp src idx-reg))) + (if (eq type-keyword :fixnum-vector) + (ensuring-node-target (target vreg) + (! box-fixnum target temp)) + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (! s64->integer target temp))))) + (t + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-ref-c-u64 temp src index-known-fixnum) + (with-imm-target () idx-reg + (if index-known-fixnum + (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))) + (! scale-64bit-misc-index idx-reg unscaled-idx)) + (! misc-ref-u64 temp src idx-reg))) + (unless temp-is-vreg + (ensuring-node-target (target vreg) + (! u64->integer target temp)))))))) + (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-temps + () (word-index bitnum dest) + (if index-known-fixnum + (progn + (ppc2-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -5))) + (ppc2-lri seg bitnum (logand index-known-fixnum #x1f))) + (! scale-1bit-misc-index word-index bitnum unscaled-idx)) + (! misc-ref-u32 dest src word-index) + (! extract-variable-bit-fixnum target dest bitnum)))))))) + (^))) + + + +;;; 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 ppc2-vref (seg vreg xfer type-keyword vector index safe) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (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) + (ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z)) + (setq src (ppc2-one-untargeted-reg-form seg vector ppc::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)) + (ppc2-vref1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum)))) + + + +(defun ppc2-aset2 (seg vreg xfer array i j new safe type-keyword dim0 dim1) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (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 (ppc2-constant-value-ok-for-type-keyword type-keyword new)) + (needs-memoization (and is-node (ppc2-acode-needs-memoization new))) + (src) + (unscaled-i) + (unscaled-j) + (val-reg (ppc2-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) + (ppc2-two-targeted-reg-forms seg array ($ ppc::temp0) new val-reg)) + (multiple-value-setq (src unscaled-i unscaled-j val-reg) + (if needs-memoization + (progn + (ppc2-four-targeted-reg-forms seg + array ($ ppc::temp0) + i ($ ppc::arg_x) + j ($ ppc::arg_y) + new val-reg) + (values ($ ppc::temp0) ($ ppc::arg_x) ($ ppc::arg_y) ($ ppc::arg_z))) + (ppc2-four-untargeted-reg-forms seg + array ($ ppc::temp0) + i ($ ppc::arg_x) + j ($ ppc::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 ($ ppc::arg_y))) + (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)) + (let* ((v ($ ppc::arg_x))) + (! array-data-vector-ref v src) + (ppc2-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (ppc2-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization))))))))) + + +(defun ppc2-aset3 (seg vreg xfer array i j k new safe type-keyword dim0 dim1 dim2) + (with-ppc-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 (ppc2-constant-value-ok-for-type-keyword type-keyword new)) + (needs-memoization (and is-node (ppc2-acode-needs-memoization new))) + (src) + (unscaled-i) + (unscaled-j) + (unscaled-k) + (val-reg (ppc2-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) + (ppc2-two-targeted-reg-forms seg array ($ ppc::temp0) new val-reg)) + (progn + (setq src ($ ppc::temp1) + unscaled-i ($ ppc::temp0) + unscaled-j ($ ppc::arg_x) + unscaled-k ($ ppc::arg_y)) + (ppc2-push-register + seg + (ppc2-one-untargeted-reg-form seg array ($ ppc::arg_z))) + (ppc2-four-targeted-reg-forms seg + i ($ ppc::temp0) + j ($ ppc::arg_x) + k ($ ppc::arg_y) + new val-reg) + (ppc2-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 ($ ppc::arg_y))) + (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)) + (let* ((v ($ ppc::arg_x))) + (! array-data-vector-ref v src) + (ppc2-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (ppc2-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization)))))))))) + +(defun ppc2-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1) + (with-ppc-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 (ppc2-one-targeted-reg-form seg array ($ ppc::arg_z))) + (multiple-value-setq (src unscaled-i unscaled-j) + (ppc2-three-untargeted-reg-forms seg + array ppc::arg_x + i ppc::arg_y + j ppc::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) + (ppc2-vref1 seg vreg xfer typekeyword v idx-reg constidx))))))) + + + +(defun ppc2-aref3 (seg vreg xfer array i j k safe typekeyword &optional dim0 dim1 dim2) + (with-ppc-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 (ppc2-one-targeted-reg-form seg array ($ ppc::arg_z))) + (multiple-value-setq (src unscaled-i unscaled-j unscaled-k) + (ppc2-four-untargeted-reg-forms seg + array ppc::temp0 + i ppc::arg_x + j ppc::arg_y + k ppc::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) + (ppc2-vref1 seg vreg xfer typekeyword v idx-reg constidx)))))) + + +(defun ppc2-constant-value-ok-for-type-keyword (type-keyword form) + (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 ppc2-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 vreg (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 ppc::arg_z))) + (cond ((or is-node + 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 ppc2-unboxed-reg-for-aset (seg type-keyword result-reg safe constval) + (with-ppc-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) + (ppc2-lri seg reg (char-code constval)) + (! unbox-base-char reg result-reg))) + ((eq type-keyword :single-float-vector) + (if (typep constval 'single-float) + (ppc2-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)) + (ppc2-lri seg reg constval) + (! 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)) + (ppc2-lri seg reg constval) + (! 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)) + (ppc2-lri seg reg constval) + (! 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)) + (ppc2-lri seg reg constval) + (! 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)) + (ppc2-lri seg reg constval) + (! unbox-u8 reg result-reg)) + reg))) + (t + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8))) + (unless (typep constval 'bit) + (! unbox-bit-bit0 reg result-reg)) + reg))))))) + + +;;; "val-reg" might be boxed, if the vreg requires it to be. +(defun ppc2-vset1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum val-reg unboxed-val-reg constval &optional (node-value-needs-memoization t)) + (with-ppc-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) ppc::arg_x) + (eql (hard-regspec-value unscaled-idx) ppc::arg_y) + (eql (hard-regspec-value val-reg) ppc::arg_z)) + (nx-error "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))))) + (! misc-set-c-node val-reg src index-known-fixnum) + (with-imm-target () scaled-idx + + (if index-known-fixnum + (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *ppc2-target-node-shift*))) + (! scale-node-misc-index scaled-idx unscaled-idx)) + (! misc-set-node val-reg src scaled-idx)))) + (t + (with-imm-target (unboxed-val-reg) scaled-idx + (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 + (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))) + (! scale-64bit-misc-index scaled-idx unscaled-idx)) + (if (eq type-keyword :double-float-vector) + (! misc-set-double-float unboxed-val-reg src scaled-idx) + (if is-signed + (! misc-set-s64 unboxed-val-reg src scaled-idx) + (! misc-set-u64 unboxed-val-reg src scaled-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 + (if index-known-fixnum + (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (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 + (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 + (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (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 + (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 + (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) 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))))) + (t + (unless is-1-bit + (nx-error "~& unsupported vector type: ~s" + type-keyword)) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) + (with-imm-target (unboxed-val-reg) word + (let* ((word-index (ash index-known-fixnum -5)) + (bit-number (logand index-known-fixnum #x1f))) + (! misc-ref-c-u32 word src word-index) + (if constval + (if (zerop constval) + (! set-constant-ppc-bit-to-0 word word bit-number) + (! set-constant-ppc-bit-to-1 word word bit-number)) + (! set-constant-ppc-bit-to-variable-value word word unboxed-val-reg bit-number)) + (! misc-set-c-u32 word src word-index))) + (with-imm-temps (unboxed-val-reg) (word-index bit-number temp) + (! scale-1bit-misc-index word-index bit-number unscaled-idx) + (if constval + (progn + (! lri temp #x80000000) + (! shift-right-variable-word bit-number temp bit-number) + (! misc-ref-u32 temp src word-index) + (if (zerop constval) + (! u32logandc2 temp temp bit-number) + (! u32logior temp temp bit-number))) + (with-imm-temps () (bitval) + (! shift-right-variable-word bitval unboxed-val-reg bit-number) + (! lri temp #x80000000) + (! shift-right-variable-word bit-number temp bit-number) + (! misc-ref-u32 temp src word-index) + (! u32logandc2 temp temp bit-number) + (! u32logior temp temp bitval))) + (! misc-set-u32 temp src word-index)))))))) + (when (and vreg val-reg) (<- val-reg)) + (^)))) + + +(defun ppc2-vset (seg vreg xfer type-keyword vector index value safe) + (with-ppc-local-vinsn-macros (seg) + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (constval (ppc2-constant-value-ok-for-type-keyword type-keyword value)) + (needs-memoization (and is-node (ppc2-acode-needs-memoization value))) + (index-known-fixnum (acode-fixnum-form-p index))) + (let* ((src ($ ppc::arg_x)) + (unscaled-idx ($ ppc::arg_y)) + (result-reg ($ ppc::arg_z))) + (cond (needs-memoization + (ppc2-three-targeted-reg-forms seg + vector src + index unscaled-idx + value result-reg)) + (t + (setq result-reg (ppc2-target-reg-for-aset vreg type-keyword)) + (ppc2-three-targeted-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)))) + (when (and value (logbitp value *available-backend-imm-temps*)) + (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*))) + (if (typep safe 'fixnum) + (! trap-unless-typecode= src safe)) + (unless index-known-fixnum + (! trap-unless-fixnum unscaled-idx)) + (! check-misc-bound unscaled-idx src))) + (ppc2-vset1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum result-reg (ppc2-unboxed-reg-for-aset seg type-keyword result-reg safe constval) constval needs-memoization))))) + + +(defun ppc2-tail-call-alias (immref sym &optional arglist) + (let ((alias (cdr (assq sym *ppc2-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 ppc2-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 (ppc2-lexical-reference-p (%car reg-args)) rest)) + (return nil)) + (flet ((independent-of-all-values (form) + (setq form (acode-unwrapped-form form)) + (or (ppc-constant-form-p form) + (let* ((lexref (ppc2-lexical-reference-p form))) + (and lexref + (neq lexref rest) + (dolist (val rest-values t) + (unless (ppc2-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) $numppcargregs) + (list nil (reverse arglist)) + (list (butlast arglist $numppcargregs) + (reverse (last arglist $numppcargregs)))) + nil))) + (return nil)))) + (if (eq op (%nx1-operator local-block)) + (setq body (%cadr body)) + (if (and (eq op (%nx1-operator if)) + (eq (ppc2-lexical-reference-p (%cadr body)) rest)) + (setq body (%caddr body)) + (return nil))))))))) + +(defun ppc2-call-fn (seg vreg xfer fn arglist spread-p) + (with-ppc-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 (car reg-args)))) + (setq spread-p nil) + (let* ((nargs (length stack-args))) + (declare (fixnum nargs)) + (if (<= nargs $numppcargregs) + (setq arglist (list nil (reverse stack-args))) + (setq arglist (list (butlast stack-args $numppcargregs) (reverse (last stack-args $numppcargregs))))))))) + (let* ((lexref (ppc2-lexical-reference-p fn)) + (simple-case (or (fixnump fn) + (typep fn 'lreg) + (ppc2-immediate-function-p fn) + (and + lexref + (not spread-p) + (flet ((all-simple (args) + (dolist (arg args t) + (when (and arg (not (ppc2-var-not-set-by-form-p lexref arg))) + (return))))) + (and (all-simple (car arglist)) + (all-simple (cadr arglist)) + (setq fn (var-ea lexref))))))) + (cstack *ppc2-cstack*) + (top *ppc2-top-vstack-lcell*) + (vstack *ppc2-vstack*)) + (setq xfer (or xfer 0)) + (when (and (eq xfer $backend-return) + (eq 0 *ppc2-undo-count*) + (acode-p fn) + (eq (acode-operator fn) (%nx1-operator immediate)) + (symbolp (cadr fn))) + (setq fn (ppc2-tail-call-alias fn (%cadr fn) arglist))) + + (if (and (eq xfer $backend-return) (not (ppc2-tailcallok xfer))) + (progn + (ppc2-call-fn seg vreg $backend-mvpass fn arglist spread-p) + (ppc2-set-vstack (%i+ (if simple-case 0 *ppc2-target-node-size*) vstack)) + (setq *ppc2-cstack* cstack) + (let ((*ppc2-returning-values* t)) (ppc2-do-return seg))) + (let* ((mv-p (ppc2-mv-p xfer))) + (unless simple-case + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg fn ppc::arg_z)) + (setq fn (ppc2-vloc-ea vstack))) + (ppc2-invoke-fn seg fn (ppc2-arglist seg arglist) spread-p xfer) + (if (and (logbitp $backend-mvpass-bit xfer) + (not simple-case)) + (progn + (! save-values) + (! vstack-discard 1) + (ppc2-set-nargs seg 0) + (! recover-values)) + (unless (or mv-p simple-case) + (! vstack-discard 1))) + (ppc2-set-vstack vstack) + (setq *ppc2-top-vstack-lcell* top) + (setq *ppc2-cstack* cstack) + (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p)) + (<- ppc::arg_z) + (ppc2-branch seg (logand (lognot $backend-mvpass-mask) xfer) vreg)))) + nil))) + +(defun ppc2-restore-full-lisp-context (seg) + (with-ppc-local-vinsn-macros (seg) + (if *ppc2-open-code-inline* + (! restore-full-lisp-context) + (! restore-full-lisp-context-ool)))) + +(defun ppc2-call-symbol (seg jump-p) + ; fname contains a symbol; we can either call it via + ; a call to .SPjmpsym or expand the instructions inline. + ; Since the branches are unconditional, the call doesn't + ; cost much, but doing the instructions inline would give + ; an instruction scheduler some opportunities to improve + ; performance, so this isn't a strict time/speed tradeoff. + ; This should probably dispatch on something other than + ; *ppc2-open-code-inline*, since that does imply a time/speed + ; tradeoff. + (with-ppc-local-vinsn-macros (seg) + (if *ppc2-open-code-inline* + (if jump-p + (! jump-known-symbol) + (! call-known-symbol ppc::arg_z)) + (if jump-p + (! jump-known-symbol-ool) + (! call-known-symbol-ool))))) + +;;; Nargs = nil -> multiple-value case. +(defun ppc2-invoke-fn (seg fn nargs spread-p xfer) + (with-ppc-local-vinsn-macros (seg) + (let* ((f-op (acode-unwrapped-form 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 -1) (- 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 ($ ppc::fname) (if lfunp ($ ppc::nfn) (unless label-p ($ ppc::temp0))))) + (alternate-tail-call + (and tail-p label-p *ppc2-tail-label* (eql nargs *ppc2-tail-nargs*) (not spread-p))) + ) + (when expression-p + ;Have to do this before spread args, since might be vsp-relative. + (if nargs + (ppc2-do-lexical-reference seg destreg fn) + (ppc2-copy-register seg destreg fn))) + (if (or symp lfunp) + (setq func (if symp (ppc2-symbol-entry-locative func) + (ppc2-afunc-lfun-ref func)) + a-reg (ppc2-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 + (ppc2-copy-register seg destreg a-reg)) + (unless spread-p + (unless alternate-tail-call + (if nargs + (ppc2-restore-nvrs seg *ppc2-register-restore-ea* *ppc2-register-restore-count*) + (when *ppc2-register-restore-count* + (with-imm-temps () (vsp0) + (! fixnum-add vsp0 ppc::vsp ppc::nargs) + (ppc2-restore-nvrs seg *ppc2-register-restore-ea* *ppc2-register-restore-count* vsp0))))))) + (if spread-p + (progn + (ppc2-set-nargs seg (%i- nargs 1)) + (when (and tail-p *ppc2-register-restore-count*) + (! copy-gpr ppc::temp1 ppc::vsp)) ; .SPspread-lexpr-z & .SPspreadargz preserve temp1 + (if (eq spread-p 0) + (! spread-lexpr) + (! spread-list)) + (when (and tail-p *ppc2-register-restore-count*) + (ppc2-restore-nvrs seg *ppc2-register-restore-ea* *ppc2-register-restore-count* ppc::temp1))) + (if nargs + (unless alternate-tail-call (ppc2-set-nargs seg nargs)) + (! pop-argument-registers))) + (if callable + (if (not tail-p) + (if (ppc2-mvpass-p xfer) + (let* ((call-reg (if symp ($ ppc::fname) ($ ppc::temp0)))) + (if label-p + (ppc2-copy-register seg call-reg ($ ppc::fn)) + (if a-reg + (ppc2-copy-register seg call-reg a-reg) + (ppc2-store-immediate seg func call-reg))) + (if symp + (! pass-multiple-values-symbol) + (! pass-multiple-values))) + (progn + (if label-p + (progn + (ppc2-copy-register seg ($ ppc::nfn) ($ ppc::fn)) + (! call-label (aref *backend-labels* 1))) + (progn + (if a-reg + (ppc2-copy-register seg destreg a-reg) + (ppc2-store-immediate seg func destreg)) + (if symp + (ppc2-call-symbol seg nil) + (! call-known-function)))))) + (if alternate-tail-call + (progn + (ppc2-unwind-stack seg xfer 0 0 *ppc2-tail-vsp*) + (! jump (aref *backend-labels* *ppc2-tail-label*))) + (progn + (ppc2-unwind-stack seg xfer 0 0 #x7fffff) + (if (and (not spread-p) nargs (%i<= nargs $numppcargregs)) + (progn + (if label-p + (ppc2-copy-register seg ppc::nfn ppc::fn)) + (unless (or label-p a-reg) (ppc2-store-immediate seg func destreg)) + (ppc2-restore-full-lisp-context seg) + (if label-p + (! jump (aref *backend-labels* 1)) + (progn + (if symp + (ppc2-call-symbol seg t) + (! jump-known-function))))) + (progn + (if label-p + (ppc2-copy-register seg ppc::nfn ppc::fn) + (unless a-reg (ppc2-store-immediate seg func destreg))) + (cond ((or spread-p (null nargs)) + (if symp + (! tail-call-sym-gen) + (! tail-call-fn-gen))) + ((%i> nargs $numppcargregs) + (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)) + (ppc2-one-targeted-reg-form seg fn destreg)) + (if (not tail-p) + (if (ppc2-mvpass-p xfer) + (! pass-multiple-values) + (! funcall)) + (cond ((or (null nargs) spread-p) + (! tail-funcall-gen)) + ((%i> nargs $numppcargregs) + (! tail-funcall-slide)) + (t + (! tail-funcall-vsp))))))) + nil)) + +(defun ppc2-seq-fbind (seg vreg xfer vars afuncs body p2decls) + (let* ((old-stack (ppc2-encode-stack)) + (copy afuncs) + (func nil)) + (with-ppc-p2-declarations p2decls + (dolist (var vars) + (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs)))) + (ppc2-seq-bind-var seg var (nx1-afunc-ref func)))) + (ppc2-undo-body seg vreg xfer body old-stack) + (dolist (var vars) + (when (neq 0 (afunc-fn-refcount (setq func (pop copy)))) + (ppc2-close-var seg var)))))) + +(defun ppc2-make-closure (seg afunc downward-p) + (with-ppc-local-vinsn-macros (seg) + (flet ((var-to-reg (var target) + (let* ((ea (var-ea (var-bits var)))) + (if ea + (ppc2-addrspec-to-reg seg (ppc2-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 ($ ppc::arg_z)) + (vsize (+ (length inherited-vars) + 2 ; %closure-code%, afunc + 2))) ; name, lfun-bits + (declare (list inherited-vars)) + (if downward-p + (progn + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-lri seg ppc::arg_x (ash (nx-lookup-target-uvector-subtag :function) *ppc2-target-fixnum-shift*)) + (! %closure-code% ppc::arg_y) + (ppc2-store-immediate seg (ppc2-afunc-lfun-ref afunc) ppc::arg_z) + (ppc2-vpush-register-arg seg ppc::arg_x) + (ppc2-vpush-register-arg seg ppc::arg_y) + (ppc2-vpush-register-arg seg ppc::arg_z) + ; Could be smarter about memory traffic here. + (dolist (v inherited-vars) + (ppc2-vpush-register-arg seg (var-to-reg v ppc::arg_z))) + (! load-nil ppc::arg_z) + (ppc2-vpush-register-arg seg ppc::arg_z) + (ppc2-lri seg ppc::arg_z (ash (ash 1 $lfbits-trampoline-bit) *ppc2-target-fixnum-shift*)) + (ppc2-vpush-register-arg seg ppc::arg_z) + (ppc2-set-nargs seg (1+ vsize)) ; account for subtag + (! make-stack-gvector)) + (ppc2-open-undo $undostkblk)) + (let* ((cell 0)) + (declare (fixnum cell)) + (progn + (ppc2-lri seg + ppc::imm0 + (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function))) + (! %alloc-misc-fixed dest ppc::imm0 (ash vsize (arch::target-word-shift arch))) + ) + (! %closure-code% ppc::arg_x) + (ppc2-store-immediate seg (ppc2-afunc-lfun-ref afunc) ppc::arg_y) + (with-node-temps (ppc::arg_z) (t0 t1 t2 t3) + (do* ((ccode ppc::arg_x nil) + (func ppc::arg_y nil)) + ((null inherited-vars)) + (let* ((t0r (or ccode (if inherited-vars (var-to-reg (pop inherited-vars) t0)))) + (t1r (or func (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))))) + (ppc2-lri seg ppc::arg_y (ash (ash 1 $lfbits-trampoline-bit) *ppc2-target-fixnum-shift*)) + (! load-nil ppc::arg_x) + (! misc-set-c-node ppc::arg_x dest cell) + (! misc-set-c-node ppc::arg_y dest (1+ cell)))) + dest)))) + +(defun ppc2-symbol-entry-locative (sym) + (setq sym (require-type sym 'symbol)) + (when (eq sym '%call-next-method-with-args) + (setf (afunc-bits *ppc2-cur-afunc*) + (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *ppc2-cur-afunc*)))) + (or (assq sym *ppc2-fcells*) + (let ((new (list sym))) + (push new *ppc2-fcells*) + new))) + +(defun ppc2-symbol-value-cell (sym) + (setq sym (require-type sym 'symbol)) + (or (assq sym *ppc2-vcells*) + (let ((new (list sym))) + (push new *ppc2-vcells*) + (ensure-binding-index sym) + new))) + + +(defun ppc2-symbol-locative-p (imm) + (and (consp imm) + (or (memq imm *ppc2-vcells*) + (memq imm *ppc2-fcells*)))) + + + + +(defun ppc2-immediate-function-p (f) + (setq f (acode-unwrapped-form f)) + (and (acode-p f) + (or (eq (%car f) (%nx1-operator immediate)) + (eq (%car f) (%nx1-operator simple-function))))) + +(defun ppc-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 ppc2-long-constant-p (form) + (setq form (acode-unwrapped-form form)) + (or (acode-fixnum-form-p form) + (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq form (%cadr form)) + (if (integerp form) + form)))) + + +(defun ppc-side-effect-free-form-p (form) + (when (consp (setq form (acode-unwrapped-form form))) + (or (ppc-constant-form-p form) + ;(eq (acode-operator form) (%nx1-operator bound-special-ref)) + (if (eq (acode-operator form) (%nx1-operator lexical-reference)) + (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form)))))))) + +(defun ppc2-formlist (seg stkargs &optional revregargs) + (with-ppc-local-vinsn-macros (seg) + (let* ((nregs (length revregargs)) + (n nregs)) + (declare (fixnum n)) + (dolist (arg stkargs) + (let* ((reg (ppc2-one-untargeted-reg-form seg arg ppc::arg_z))) + (ppc2-vpush-register-arg seg reg) + (incf n))) + (when revregargs + (let* ((zform (%car revregargs)) + (yform (%cadr revregargs)) + (xform (%caddr revregargs))) + (if (eq 3 nregs) + (ppc2-three-targeted-reg-forms seg xform ($ ppc::arg_x) yform ($ ppc::arg_y) zform ($ ppc::arg_z)) + (if (eq 2 nregs) + (ppc2-two-targeted-reg-forms seg yform ($ ppc::arg_y) zform ($ ppc::arg_z)) + (ppc2-one-targeted-reg-form seg zform ($ ppc::arg_z)))))) + n))) + +(defun ppc2-arglist (seg args) + (ppc2-formlist seg (car args) (cadr args))) + + + + +;;; treat form as a 32-bit immediate value and load it into immreg. +;;; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars +;;; count, and we don't care about the integer's sign. + +(defun ppc2-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type) + (let* ((mode (case ffi-arg-type + ((nil) :natural) + (:signed-byte :s8) + (:unsigned-byte :u8) + (:signed-halfword :s16) + (:unsigned-halfword :u16) + (:signed-fullword :s32) + (:unsigned-fullword :u32))) + (modeval (gpr-mode-name-value mode))) + (with-ppc-local-vinsn-macros (seg) + (let* ((value (ppc2-long-constant-p form))) + (if value + (if (eql value 0) + (make-wired-lreg ppc::rzero :mode modeval) + (progn + (unless (typep immreg 'lreg) + (setq immreg (make-unwired-lreg immreg :mode modeval))) + (ppc2-lri seg immreg value) + immreg)) + (progn + (ppc2-one-targeted-reg-form seg form (make-wired-lreg ppc::imm0 :mode modeval)))))))) + + +(defun ppc2-macptr-arg-to-reg (seg form address-reg) + (ppc2-one-targeted-reg-form seg + form + address-reg)) + + +(defun ppc2-one-lreg-form (seg form lreg) + (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr))) + (if is-float + (ppc2-form-float seg lreg nil form) + (ppc2-form seg lreg nil form)) + lreg)) + +(defun ppc2-one-targeted-reg-form (seg form reg) + (ppc2-one-lreg-form seg form reg)) + +(defun ppc2-one-untargeted-lreg-form (seg form reg) + (ppc2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg)))) + +(defun ppc2-one-untargeted-reg-form (seg form suggested) + (with-ppc-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 (ppc2-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 (eql 0 (acode-fixnum-form-p form)) + ($ ppc::rzero) + (if (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq reg (ppc2-register-constant-p (cadr form)))) + reg + (if (and (acode-p form) + (eq (acode-operator form) (%nx1-operator %current-tcr))) + (target-arch-case + (:ppc32 ($ ppc32::rcontext)) + (:ppc64 ($ ppc64::rcontext))) + (ppc2-one-untargeted-lreg-form seg form suggested))))))) + (ppc2-one-untargeted-lreg-form seg form suggested))))) + + +(defun ppc2-push-register (seg areg) + (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr)) + (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double))) + (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node))) + vinsn) + (with-ppc-local-vinsn-macros (seg) + (if a-node + (setq vinsn (ppc2-vpush-register seg areg :node-temp)) + (progn + (setq vinsn + (if a-float + (if a-double + (! temp-push-double-float areg) + (! temp-push-single-float areg)) + (! temp-push-unboxed-word areg))) + (ppc2-open-undo $undostkblk))) + vinsn))) + +(defun ppc2-pop-register (seg areg) + (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr)) + (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double))) + (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node))) + vinsn) + (with-ppc-local-vinsn-macros (seg) + (if a-node + (setq vinsn (ppc2-vpop-register seg areg)) + (progn + (setq vinsn + (if a-float + (if a-double + (! temp-pop-double-float areg) + (! temp-pop-single-float areg)) + (! temp-pop-unboxed-word areg))) + (ppc2-close-undo))) + vinsn))) + +(defun ppc2-acc-reg-for (reg) + (with-ppc-local-vinsn-macros (seg) + (let* ((class (hard-regspec-class reg)) + (mode (get-regspec-mode reg))) + (declare (fixnum class mode)) + (cond ((= class hard-reg-class-fpr) + (make-wired-lreg ppc::fp1 :class class :mode mode)) + ((= class hard-reg-class-gpr) + (if (= mode hard-reg-class-gpr-mode-node) + ($ ppc::arg_z) + (make-wired-lreg ppc::imm0 :mode mode))) + (t (compiler-bug "Unknown register class for reg ~s" reg)))))) + +;;; The compiler often generates superfluous pushes & pops. Try to +;;; eliminate them. +;;; It's easier to elide pushes and pops to the TSP. +(defun ppc2-elide-pushes (seg push-vinsn pop-vinsn) + (with-ppc-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))) + (tsp-p (vinsn-attribute-p push-vinsn :tsp))) + (when (and tsp-p t) ; vsp case is harder. + (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) + (! copy-fpr 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 ppc2-two-targeted-reg-forms (seg aform areg bform breg) + (unless (typep areg 'lreg) + (warn "~s is not an lreg (1/2)" areg)) + (unless (typep breg 'lreg) + (warn "~s is not an lreg (2/2)" breg)) + (let* ((avar (ppc2-lexical-reference-p aform)) + (atriv (ppc2-trivial-p bform)) + (aconst (and (not atriv) (or (ppc-side-effect-free-form-p aform) + (if avar (ppc2-var-not-set-by-form-p avar bform))))) + (apushed (not (or atriv aconst)))) + (progn + (unless aconst + (if atriv + (ppc2-one-targeted-reg-form seg aform areg) + (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) + (ppc2-one-targeted-reg-form seg bform breg) + (if aconst + (ppc2-one-targeted-reg-form seg aform areg) + (if apushed + (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg))))) + (values areg breg))) + + +(defun ppc2-two-untargeted-reg-forms (seg aform areg bform breg) + (with-ppc-local-vinsn-macros (seg) + (let* ((avar (ppc2-lexical-reference-p aform)) + (adest areg) + (bdest breg) + (atriv (ppc2-trivial-p bform)) + (aconst (and (not atriv) (or (ppc-side-effect-free-form-p aform) + (if avar (ppc2-var-not-set-by-form-p avar bform))))) + (apushed (not (or atriv aconst)))) + (progn + (unless aconst + (if atriv + (setq adest (ppc2-one-untargeted-reg-form seg aform areg)) + (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) + (setq bdest (ppc2-one-untargeted-reg-form seg bform breg)) + (if aconst + (setq adest (ppc2-one-untargeted-reg-form seg aform areg)) + (if apushed + (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg))))) + (values adest bdest)))) + + +(defun ppc2-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg) + (unless (typep areg 'lreg) + (warn "~s is not an lreg (1/4)" areg)) + (unless (typep breg 'lreg) + (warn "~s is not an lreg (2/4)" breg)) + (unless (typep creg 'lreg) + (warn "~s is not an lreg (3/4)" creg)) + (unless (typep dreg 'lreg) + (warn "~s is not an lreg (4/4)" dreg)) + (let* ((atriv (or (null aform) + (and (ppc2-trivial-p bform) + (ppc2-trivial-p cform) + (ppc2-trivial-p dform)))) + (btriv (or (null bform) + (and (ppc2-trivial-p cform) + (ppc2-trivial-p dform)))) + (ctriv (or (null cform) + (ppc2-trivial-p dform))) + + (aconst (and (not atriv) + (or (ppc-side-effect-free-form-p aform) + (let ((avar (ppc2-lexical-reference-p aform))) + (and avar + (ppc2-var-not-set-by-form-p avar bform) + (ppc2-var-not-set-by-form-p avar cform) + (ppc2-var-not-set-by-form-p avar dform)))))) + (bconst (and (not btriv) + (or (ppc-side-effect-free-form-p bform) + (let ((bvar (ppc2-lexical-reference-p bform))) + (and bvar + (ppc2-var-not-set-by-form-p bvar cform) + (ppc2-var-not-set-by-form-p bvar dform)))))) + (cconst (and (not ctriv) + (or (ppc-side-effect-free-form-p cform) + (let ((cvar (ppc2-lexical-reference-p cform))) + (and cvar + (ppc2-var-not-set-by-form-p cvar dform)))))) + (apushed nil) + (bpushed nil) + (cpushed nil)) + (if (and aform (not aconst)) + (if atriv + (ppc2-one-targeted-reg-form seg aform areg) + (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (ppc2-one-targeted-reg-form seg bform breg) + (setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg)))))) + (if (and cform (not cconst)) + (if ctriv + (ppc2-one-targeted-reg-form seg cform creg) + (setq cpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg cform (ppc2-acc-reg-for creg)))))) + (ppc2-one-targeted-reg-form seg dform dreg) + (unless ctriv + (if cconst + (ppc2-one-targeted-reg-form seg cform creg) + (ppc2-elide-pushes seg cpushed (ppc2-pop-register seg creg)))) + (unless btriv + (if bconst + (ppc2-one-targeted-reg-form seg bform breg) + (ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg)))) + (unless atriv + (if aconst + (ppc2-one-targeted-reg-form seg aform areg) + (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))) + (values areg breg creg dreg))) + +(defun ppc2-three-targeted-reg-forms (seg aform areg bform breg cform creg) + (unless (typep areg 'lreg) + (warn "~s is not an lreg (1/3)" areg)) + (unless (typep breg 'lreg) + (warn "~s is not an lreg (2/3)" breg)) + (unless (typep creg 'lreg) + (warn "~s is not an lreg (3/3)" creg)) + (let* ((atriv (or (null aform) + (and (ppc2-trivial-p bform) + (ppc2-trivial-p cform)))) + (btriv (or (null bform) + (ppc2-trivial-p cform))) + (aconst (and (not atriv) + (or (ppc-side-effect-free-form-p aform) + (let ((avar (ppc2-lexical-reference-p aform))) + (and avar + (ppc2-var-not-set-by-form-p avar bform) + (ppc2-var-not-set-by-form-p avar cform)))))) + (bconst (and (not btriv) + (or + (ppc-side-effect-free-form-p bform) + (let ((bvar (ppc2-lexical-reference-p bform))) + (and bvar (ppc2-var-not-set-by-form-p bvar cform)))))) + (apushed nil) + (bpushed nil)) + (if (and aform (not aconst)) + (if atriv + (ppc2-one-targeted-reg-form seg aform areg) + (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (ppc2-one-targeted-reg-form seg bform breg) + (setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg)))))) + (ppc2-one-targeted-reg-form seg cform creg) + (unless btriv + (if bconst + (ppc2-one-targeted-reg-form seg bform breg) + (ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg)))) + (unless atriv + (if aconst + (ppc2-one-targeted-reg-form seg aform areg) + (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))) + (values areg breg creg))) + +(defun ppc2-three-untargeted-reg-forms (seg aform areg bform breg cform creg) + (with-ppc-local-vinsn-macros (seg) + (let* ((atriv (or (null aform) + (and (ppc2-trivial-p bform) + (ppc2-trivial-p cform)))) + (btriv (or (null bform) + (ppc2-trivial-p cform))) + (aconst (and (not atriv) + (or (ppc-side-effect-free-form-p aform) + (let ((avar (ppc2-lexical-reference-p aform))) + (and avar + (ppc2-var-not-set-by-form-p avar bform) + (ppc2-var-not-set-by-form-p avar cform)))))) + (bconst (and (not btriv) + (or + (ppc-side-effect-free-form-p bform) + (let ((bvar (ppc2-lexical-reference-p bform))) + (and bvar (ppc2-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 (ppc2-one-untargeted-reg-form seg aform ($ areg))) + (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (setq bdest (ppc2-one-untargeted-reg-form seg bform ($ breg))) + (setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg)))))) + (setq cdest (ppc2-one-untargeted-reg-form seg cform creg)) + (unless btriv + (if bconst + (setq bdest (ppc2-one-untargeted-reg-form seg bform breg)) + (ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg)))) + (unless atriv + (if aconst + (setq adest (ppc2-one-untargeted-reg-form seg aform areg)) + (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))) + (values adest bdest cdest)))) + +(defun ppc2-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg) + (let* ((atriv (or (null aform) + (and (ppc2-trivial-p bform) + (ppc2-trivial-p cform) + (ppc2-trivial-p dform)))) + (btriv (or (null bform) + (and (ppc2-trivial-p cform) + (ppc2-trivial-p dform)))) + (ctriv (or (null cform) + (ppc2-trivial-p dform))) + (aconst (and (not atriv) + (or (ppc-side-effect-free-form-p aform) + (let ((avar (ppc2-lexical-reference-p aform))) + (and avar + (ppc2-var-not-set-by-form-p avar bform) + (ppc2-var-not-set-by-form-p avar cform) + (ppc2-var-not-set-by-form-p avar dform)))))) + (bconst (and (not btriv) + (or + (ppc-side-effect-free-form-p bform) + (let ((bvar (ppc2-lexical-reference-p bform))) + (and bvar + (ppc2-var-not-set-by-form-p bvar cform) + (ppc2-var-not-set-by-form-p bvar dform)))))) + (cconst (and (not ctriv) + (or + (ppc-side-effect-free-form-p cform) + (let ((cvar (ppc2-lexical-reference-p cform))) + (and cvar + (ppc2-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 (ppc2-one-targeted-reg-form seg aform areg)) + (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (setq bdest (ppc2-one-untargeted-reg-form seg bform breg)) + (setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg)))))) + (if (and cform (not cconst)) + (if ctriv + (setq cdest (ppc2-one-untargeted-reg-form seg cform creg)) + (setq cpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg cform (ppc2-acc-reg-for creg)))))) + (setq ddest (ppc2-one-untargeted-reg-form seg dform dreg)) + (unless ctriv + (if cconst + (setq cdest (ppc2-one-untargeted-reg-form seg cform creg)) + (ppc2-elide-pushes seg cpushed (ppc2-pop-register seg creg)))) + (unless btriv + (if bconst + (setq bdest (ppc2-one-untargeted-reg-form seg bform breg)) + (ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg)))) + (unless atriv + (if aconst + (setq adest (ppc2-one-untargeted-reg-form seg aform areg)) + (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))) + (values adest bdest cdest ddest))) + +(defun ppc2-lri (seg reg value) + (with-ppc-local-vinsn-macros (seg) + (if (>= value 0) + (! lri reg value) + (target-arch-case + (:ppc32 (! lri reg (logand value #xffffffff))) + (:ppc64 (! lri reg (logand value #xffffffffffffffff))))))) + + +(defun ppc2-multiple-value-body (seg form) + (let* ((lab (backend-get-next-label)) + (*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (old-stack (ppc2-encode-stack))) + (with-ppc-local-vinsn-macros (seg) + (ppc2-open-undo $undomvexpect) + (ppc2-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack) + (@ lab)))) + +(defun ppc2-afunc-lfun-ref (afunc) + (or + (afunc-lfun afunc) + (progn (pushnew afunc (afunc-fwd-refs *ppc2-cur-afunc*) :test #'eq) + afunc))) + +(defun ppc2-augment-arglist (afunc arglist &optional (maxregs $numppcargregs)) + (let ((inherited-args (afunc-inherited-vars afunc))) + (when inherited-args + (let* ((current-afunc *ppc2-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 #|(compiler-bug "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) + + + +;;; There are other cases involving constants that are worth exploiting. +(defun ppc2-compare (seg vreg xfer i j cr-bit true-p) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((js16 (acode-s16-constant-p j)) + (is16 (acode-s16-constant-p i)) + (boolean (backend-crf-p vreg))) + (if (and boolean (or js16 is16)) + (let* ((reg (ppc2-one-untargeted-reg-form seg (if js16 i j) ppc::arg_z))) + (! compare-signed-s16const vreg reg (or js16 is16)) + (unless (or js16 (eq cr-bit ppc::ppc-eq-bit)) + (setq cr-bit (- 1 cr-bit))) + (^ cr-bit true-p)) + (if (and (eq cr-bit ppc::ppc-eq-bit) + (or js16 is16)) + (ppc2-test-reg-%izerop + seg + vreg + xfer + (ppc2-one-untargeted-reg-form + seg + (if js16 i j) + ppc::arg_z) + cr-bit + true-p + (or js16 is16)) + (multiple-value-bind (ireg jreg) (ppc2-two-untargeted-reg-forms seg i ppc::arg_y j ppc::arg_z) + (ppc2-compare-registers seg vreg xfer ireg jreg cr-bit true-p))))))) + +(defun ppc2-natural-compare (seg vreg xfer i j cr-bit true-p) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((jconstant (acode-fixnum-form-p j)) + (ju16 (typep jconstant '(unsigned-byte 16))) + (iconstant (acode-fixnum-form-p i)) + (iu16 (typep iconstant '(unsigned-byte 16))) + (boolean (backend-crf-p vreg))) + (if (and boolean (or ju16 iu16)) + (with-imm-target + () (reg :natural) + (ppc2-one-targeted-reg-form seg (if ju16 i j) reg) + (! compare-unsigned-u16const vreg reg (if ju16 jconstant iconstant)) + (unless (or ju16 (eq cr-bit ppc::ppc-eq-bit)) + (setq cr-bit (- 1 cr-bit))) + (^ cr-bit true-p)) + (with-imm-target () + (ireg :natural) + (with-imm-target + (ireg) (jreg :natural) + (ppc2-two-targeted-reg-forms seg i ireg j jreg) + (ppc2-compare-natural-registers seg vreg xfer ireg jreg cr-bit true-p))))))) + +(defun ppc2-compare-natural-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if vreg + (regspec-crf-gpr-case + (vreg dest) + (progn + (! compare-logical dest ireg jreg) + (^ cr-bit true-p)) + (with-imm-temps () ((b31-reg :natural)) + (ecase cr-bit + (#. ppc::ppc-eq-bit + (if true-p + (! eq->bit31 b31-reg ireg jreg) + (! ne->bit31 b31-reg ireg jreg))) + (#. ppc::ppc-lt-bit + (if true-p + (! ltu->bit31 b31-reg ireg jreg) + (! geu->bit31 b31-reg ireg jreg))) + (#. ppc::ppc-gt-bit + (if true-p + (! gtu->bit31 b31-reg ireg jreg) + (! leu->bit31 b31-reg ireg jreg)))) + (ensuring-node-target (target dest) + (! lowbit->truth target b31-reg)) + (^))) + (^)))) + +(defun ppc2-compare-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if vreg + (regspec-crf-gpr-case + (vreg dest) + (progn + (! compare dest ireg jreg) + (^ cr-bit true-p)) + (with-imm-temps () ((b31-reg :natural)) + (ecase cr-bit + (#. ppc::ppc-eq-bit + (if true-p + (! eq->bit31 b31-reg ireg jreg) + (! ne->bit31 b31-reg ireg jreg))) + (#. ppc::ppc-lt-bit + (if true-p + (! lt->bit31 b31-reg ireg jreg) + (! ge->bit31 b31-reg ireg jreg))) + (#. ppc::ppc-gt-bit + (if true-p + (! gt->bit31 b31-reg ireg jreg) + (! le->bit31 b31-reg ireg jreg)))) + (ensuring-node-target (target dest) + (! lowbit->truth target b31-reg)) + (^))) + (^)))) + +(defun ppc2-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if vreg + (regspec-crf-gpr-case + (vreg dest) + (progn + (! compare-to-nil dest ireg) + (^ cr-bit true-p)) + (with-imm-temps () ((b31-reg :natural)) + (ecase cr-bit + (#. ppc::ppc-eq-bit + (if true-p + (! eqnil->bit31 b31-reg ireg) + (! nenil->bit31 b31-reg ireg)))) + (ensuring-node-target (target dest) + (! lowbit->truth target b31-reg)) + (^))) + (^)))) + +;;; Have to extract a bit out of the CR when a boolean result needed. +(defun ppc2-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if vreg + (regspec-crf-gpr-case + (vreg dest) + (progn + (! double-float-compare dest ireg jreg) + (^ cr-bit true-p)) + (with-imm-temps () ((lowbit-reg :natural)) + (with-crf-target () flags + (! double-float-compare flags ireg jreg) + (! crbit->bit31 lowbit-reg flags cr-bit)) + (unless true-p + (! invert-lowbit lowbit-reg)) + (ensuring-node-target (target dest) + (! lowbit->truth target lowbit-reg)) + (^))) + (^)))) + + +(defun ppc2-immediate-form-p (form) + (if (and (consp form) + (or (eq (%car form) (%nx1-operator immediate)) + (eq (%car form) (%nx1-operator simple-function)))) + t)) + +(defun ppc2-test-%izerop (seg vreg xfer form cr-bit true-p) + (ppc2-test-reg-%izerop seg vreg xfer (ppc2-one-untargeted-reg-form seg form ppc::arg_z) cr-bit true-p 0)) + +(defun ppc2-test-reg-%izerop (seg vreg xfer reg cr-bit true-p zero) + (declare (fixnum reg zero)) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (regspec-crf-gpr-case + (vreg dest) + (progn + (! compare-signed-s16const dest reg zero) + (^ cr-bit true-p)) + (with-imm-temps (reg) (b31-reg scaled) + (if (zerop zero) + (setq scaled reg) + (! subtract-constant scaled reg zero)) + (ecase cr-bit + (#. ppc::ppc-eq-bit + (if true-p + (! eq0->bit31 b31-reg scaled) + (! ne0->bit31 b31-reg scaled))) + (#. ppc::ppc-lt-bit + (if true-p + (! lt0->bit31 b31-reg scaled) + (! ge0->bit31 b31-reg scaled))) + (#. ppc::ppc-gt-bit + (if true-p + (! gt0->bit31 b31-reg scaled) + (! le0->bit31 b31-reg scaled)))) + (ensuring-node-target (target dest) + (! lowbit->truth target b31-reg)) + (^))))) + +(defun ppc2-lexical-reference-ea (form &optional (no-closed-p t)) + (when (acode-p (setq form (acode-unwrapped-form 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 ppc2-vpush-register (seg src &optional why info attr) + (with-ppc-local-vinsn-macros (seg) + (prog1 + (! vpush-register src) + (ppc2-new-vstack-lcell (or why :node) *ppc2-target-lcell-size* (or attr 0) info) + (ppc2-adjust-vstack *ppc2-target-node-size*)))) + +(defun ppc2-vpush-register-arg (seg src) + (ppc2-vpush-register seg src :outgoing-argument)) + + +(defun ppc2-vpop-register (seg dest) + (with-ppc-local-vinsn-macros (seg) + (prog1 + (! vpop-register dest) + (setq *ppc2-top-vstack-lcell* (lcell-parent *ppc2-top-vstack-lcell*)) + (ppc2-adjust-vstack (- *ppc2-target-node-size*))))) + +(defun ppc2-copy-register (seg dest src) + (with-ppc-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 (and dest-gpr (eql dest-gpr ppc::rzero)) + (compiler-bug "Bad destination register: ~s" dest-gpr)) + (if (null src) + (if dest-gpr + (! load-nil dest-gpr) + (if dest-crf + (! set-eq-bit dest-crf))) + (if (and dest-crf src-gpr) + ;; "Copying" a GPR to a CR field means comparing it to rnil + (! compare-to-nil dest src) + (if (and dest-gpr src-gpr) + (if (eql src-gpr ppc::rzero) + ;; Rzero always contains 0, so we can + ;; save ourselves some trouble. + ;; This assumes that (LI dest-gpr 0) is easier + ;; on the register-renaming pipeline nonsense than + ;; (MR dest-gpr rzero) would be. + (! lri dest-gpr 0) + ;; This is the "GPR <- GPR" case. There are + ;; word-size dependencies, but there's also + ;; lots of redundancy here. + (target-word-size-case + (32 + (case 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 + (ppc2-box-u32 seg dest src)) + (#.hard-reg-class-gpr-mode-s32 + (ppc2-box-s32 seg dest src)) + (#.hard-reg-class-gpr-mode-u16 + (! u16->fixnum dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! s16->fixnum dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->fixnum dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->fixnum dest src)) + (#.hard-reg-class-gpr-mode-address + (! macptr->heap 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) + *ppc2-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 + #.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-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 *ppc2-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))))))) + (64 + (case 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 + (ppc2-box-u64 seg dest src)) + (#.hard-reg-class-gpr-mode-s64 + (ppc2-box-s64 seg dest src)) + (#.hard-reg-class-gpr-mode-u32 + (ppc2-box-u32 seg dest src)) + (#.hard-reg-class-gpr-mode-s32 + (ppc2-box-s32 seg dest src)) + (#.hard-reg-class-gpr-mode-u16 + (! u16->fixnum dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! s16->fixnum dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->fixnum dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->fixnum dest src)) + (#.hard-reg-class-gpr-mode-address + (! macptr->heap 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) + *ppc2-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-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 + (! 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 + (! 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 *ppc2-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)) + *ppc2-reckless*) + (! trap-unless-double-float src)) + (! get-double dest src)) + (#.hard-reg-class-fpr-mode-single + (unless *ppc2-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 + (! double->heap dest src)) + (#.hard-reg-class-fpr-mode-single + (! single->node dest src))))) + (if (and src-fpr dest-fpr) + (unless (eql dest-fpr src-fpr) + (! copy-fpr dest src)))))))))))) + +(defun ppc2-unreachable-store (&optional vreg) + ;; I don't think that anything needs to be done here, + ;; but leave this guy around until we're sure. + ;; (PPC2-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 ppc2-seq-bind (seg vars initforms) + (dolist (var vars) + (ppc2-seq-bind-var seg var (pop initforms)))) + +(defun ppc2-dynamic-extent-form (seg curstack val) + (when (acode-p val) + (with-ppc-local-vinsn-macros (seg) + (let* ((op (acode-operator val))) + (cond ((eq op (%nx1-operator list)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil)) + (ppc2-open-undo $undostkblk curstack) + (! stack-cons-list)) + (setq val ppc::arg_z)) + ((eq op (%nx1-operator list*)) + (let* ((arglist (%cadr val))) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-arglist seg arglist)) + (when (car arglist) + (ppc2-set-nargs seg (length (%car arglist))) + (! stack-cons-list*) + (ppc2-open-undo $undostkblk curstack)) + (setq val ppc::arg_z))) + ((eq op (%nx1-operator multiple-value-list)) + (ppc2-multiple-value-body seg (%cadr val)) + (ppc2-open-undo $undostkblk curstack) + (! stack-cons-list) + (setq val ppc::arg_z)) + ((eq op (%nx1-operator cons)) + (let* ((y ($ ppc::arg_y)) + (z ($ ppc::arg_z)) + (result ($ ppc::arg_z))) + (ppc2-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z) + (ppc2-open-undo $undostkblk ) + (! make-tsp-cons result y z) + (setq val result))) + ((eq op (%nx1-operator %consmacptr%)) + (with-imm-target () (address :address) + (ppc2-one-targeted-reg-form seg val address) + (with-node-temps () (node) + (! macptr->stack node address) + (ppc2-open-undo $undostkblk) + (setq val node)))) + ((eq op (%nx1-operator %new-ptr)) + (let ((clear-form (caddr val))) + (if (nx-constant-form-p clear-form) + (progn + (ppc2-one-targeted-reg-form seg (%cadr val) ($ ppc::arg_z)) + (if (nx-null clear-form) + (! 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 ($ ppc::arg_z)) + (rclear ($ ppc::arg_y))) + (ppc2-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear) + (! compare-to-nil crf rclear) + (! cbranch-false (aref *backend-labels* stack-block-0-label) crf ppc::ppc-eq-bit) + (! make-stack-block) + (-> done-label) + (@ stack-block-0-label) + (! make-stack-block0) + (@ done-label))))) + (ppc2-open-undo $undostkblk) + (setq val ($ ppc::arg_z))) + ((eq op (%nx1-operator make-list)) + (ppc2-two-targeted-reg-forms seg (%cadr val) ($ ppc::arg_y) (%caddr val) ($ ppc::arg_z)) + (ppc2-open-undo $undostkblk curstack) + (! make-stack-list) + (setq val ppc::arg_z)) + ((eq (%car val) (%nx1-operator vector)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil)) + (! make-stack-vector)) + (ppc2-open-undo $undostkblk) + (setq val ppc::arg_z)) + ((eq op (%nx1-operator %gvector)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (arglist (%cadr val))) + (ppc2-set-nargs seg (ppc2-formlist seg (append (car arglist) (reverse (cadr arglist))) nil)) + (! make-stack-gvector)) + (ppc2-open-undo $undostkblk) + (setq val ppc::arg_z)) + ((eq op (%nx1-operator closed-function)) + (setq val (ppc2-make-closure seg (cadr val) t))) ; can't error + ((eq op (%nx1-operator %make-uvector)) + (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr val) + (if init-p + (progn + (ppc2-three-targeted-reg-forms seg element-count ($ ppc::arg_x) subtag ($ ppc::arg_y) init ($ ppc::arg_z)) + (! stack-misc-alloc-init)) + (progn + (ppc2-two-targeted-reg-forms seg element-count ($ ppc::arg_y) subtag ($ ppc::arg_z)) + (! stack-misc-alloc))) + (ppc2-open-undo $undostkblk) + (setq val ($ ppc::arg_z)))))))) + val) + +(defun ppc2-addrspec-to-reg (seg addrspec reg) + (if (memory-spec-p addrspec) + (ppc2-stack-to-register seg addrspec reg) + (ppc2-copy-register seg reg addrspec))) + +(defun ppc2-seq-bind-var (seg var val) + (with-ppc-local-vinsn-macros (seg) + (let* ((sym (var-name var)) + (bits (nx-var-bits var)) + (closed-p (and (%ilogbitp $vbitclosed bits) + (%ilogbitp $vbitsetq bits))) + (curstack (ppc2-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 (ppc2-dynamic-extent-form seg curstack val)))) + (if (%ilogbitp $vbitspecial bits) + (progn + (ppc2-dbind seg val sym) + (ppc2-set-var-ea seg var (ppc2-vloc-ea (- *ppc2-vstack* *ppc2-target-node-size*)))) + (let ((puntval nil)) + (flet ((ppc2-puntable-binding-p (var initform) + ; The value returned is acode. + (let* ((bits (nx-var-bits var))) + (if (%ilogbitp $vbitpuntable bits) + (nx-untyped-form initform))))) + (declare (inline ppc2-puntable-binding-p)) + (if (and (not (ppc2-load-ea-p val)) + (setq puntval (ppc2-puntable-binding-p var val))) + (progn + (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits)) + (ppc2-set-var-ea seg var puntval)) + (progn + (let* ((vloc *ppc2-vstack*) + (reg (let* ((r (ppc2-assign-register-var var))) + (if r ($ r))))) + (if (ppc2-load-ea-p val) + (if reg + (ppc2-addrspec-to-reg seg val reg) + (if (memory-spec-p val) + (with-node-temps () (temp) + (ppc2-addrspec-to-reg seg val temp) + (ppc2-vpush-register seg temp :node var bits)) + (ppc2-vpush-register seg val :node var bits))) + (if reg + (ppc2-one-targeted-reg-form seg val reg) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg val ppc::arg_z) :node var bits))) + (ppc2-set-var-ea seg var (or reg (ppc2-vloc-ea vloc closed-p))) + (if reg + (ppc2-note-var-cell var reg) + (ppc2-note-top-cell var)) + (when make-vcell + (with-node-temps () (vcell closed) + (ppc2-stack-to-register seg vloc closed) + (if closed-downward + (progn + (! make-tsp-vcell vcell closed) + (ppc2-open-undo $undostkblk)) + (! make-vcell vcell closed)) + (ppc2-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 ppc2-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 (ppc2-vloc-ea vloc))) + (with-ppc-local-vinsn-macros (seg) + (if (%ilogbitp $vbitspecial bits) + (progn + (ppc2-dbind seg addr (var-name var)) + (ppc2-set-var-ea seg var (ppc2-vloc-ea (- *ppc2-vstack* *ppc2-target-node-size*))) + t) + (progn + (when (%ilogbitp $vbitpunted bits) + (compiler-bug "bind-var: var ~s was punted" var)) + (when make-vcell + (with-node-temps () (vcell closed) + (ppc2-stack-to-register seg vloc closed) + (if closed-downward + (progn + (! make-tsp-vcell vcell closed) + (ppc2-open-undo $undostkblk)) + (! make-vcell vcell closed)) + (ppc2-register-to-stack seg vcell vloc))) + (when lcell + (setf (lcell-kind lcell) :node + (lcell-attributes lcell) bits + (lcell-info lcell) var) + (ppc2-note-var-cell var lcell)) + (ppc2-set-var-ea seg var (ppc2-vloc-ea vloc closed-p)) + closed-downward)))) + +(defun ppc2-set-var-ea (seg var ea) + (setf (var-ea var) ea) + (when (and *ppc2-record-symbols* (or (typep ea 'lreg) (typep ea 'fixnum))) + (let* ((start (ppc2-emit-note seg :begin-variable-scope))) + (push (list var (var-name var) start (close-vinsn-note start)) + *ppc2-recorded-symbols*))) + ea) + +(defun ppc2-close-var (seg var) + (let ((bits (nx-var-bits var))) + (when (and *ppc2-record-symbols* + (or (logbitp $vbitspecial bits) + (not (logbitp $vbitpunted bits)))) + (let ((endnote (%car (%cdddr (assq var *ppc2-recorded-symbols*))))) + (unless endnote (compiler-bug "ppc2-close-var for ~s ?" (var-name var))) + (setf (vinsn-note-class endnote) :end-variable-scope) + (append-dll-node (vinsn-note-label endnote) seg))))) + +(defun ppc2-load-ea-p (ea) + (or (typep ea 'fixnum) + (typep ea 'lreg) + (typep ea 'lcell))) + +(defun ppc2-dbind (seg value sym) + (with-ppc-local-vinsn-macros (seg) + (let* ((ea-p (ppc2-load-ea-p value)) + (nil-p (unless ea-p (eq (setq value (nx-untyped-form value)) *nx-nil*))) + (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 *ppc2-open-code-inline* + (! bind-interrupt-level-0-inline) + (! bind-interrupt-level-0))) + ((eql fixval -1) (if *ppc2-open-code-inline* + (! bind-interrupt-level-m1-inline) + (! bind-interrupt-level-m1))) + (t + (if ea-p + (ppc2-store-ea seg value ppc::arg_z) + (ppc2-one-targeted-reg-form seg value ($ ppc::arg_z))) + (! bind-interrupt-level)))) + (ppc2-open-undo $undointerruptlevel)) + (t + (if (or nil-p self-p) + (progn + (ppc2-store-immediate seg (ppc2-symbol-value-cell sym) ppc::arg_z) + (if nil-p + (! bind-nil) + (if (or *ppc2-reckless* (eq (acode-operator value) (%nx1-operator special-ref))) + (! bind-self) + (! bind-self-boundp-check)))) + (progn + (if ea-p + (ppc2-store-ea seg value ppc::arg_z) + (ppc2-one-targeted-reg-form seg value ($ ppc::arg_z))) + (ppc2-store-immediate seg (ppc2-symbol-value-cell sym) ($ ppc::arg_y)) + (! bind))) + (ppc2-open-undo $undospecial))) + (ppc2-new-vstack-lcell :special-value *ppc2-target-lcell-size* 0 sym) + (ppc2-new-vstack-lcell :special *ppc2-target-lcell-size* (ash 1 $vbitspecial) sym) + (ppc2-new-vstack-lcell :special-link *ppc2-target-lcell-size* 0 sym) + (ppc2-adjust-vstack (* 3 *ppc2-target-node-size*))))) + +;;; Store the contents of EA - which denotes either a vframe location +;;; or a hard register - in reg. + +(defun ppc2-store-ea (seg ea reg) + (if (typep ea 'fixnum) + (if (memory-spec-p ea) + (ppc2-stack-to-register seg ea reg) + (ppc2-copy-register seg reg ea)) + (if (typep ea 'lreg) + (ppc2-copy-register seg reg ea) + (if (typep ea 'lcell) + (ppc2-lcell-to-register seg ea reg))))) + + + + +;;; Callers should really be sure that this is what they want to use. +(defun ppc2-absolute-natural (seg vreg xfer value) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (when vreg + (ppc2-lri seg vreg value)) + (^))) + + + +(defun ppc2-store-macptr (seg vreg address-reg) + (with-ppc-local-vinsn-macros (seg vreg) + (when (ppc2-for-value-p vreg) + (if (logbitp vreg ppc-imm-regs) + (<- address-reg) + (! macptr->heap vreg address-reg))))) + +(defun ppc2-store-signed-longword (seg vreg imm-reg) + (with-ppc-local-vinsn-macros (seg vreg) + (when (ppc2-for-value-p vreg) + (if (logbitp vreg ppc-imm-regs) + (<- imm-reg) + (ppc2-box-s32 seg vreg imm-reg))))) + +(defun ppc2-store-signed-halfword (seg vreg imm-reg) + (with-ppc-local-vinsn-macros (seg vreg) + (when (ppc2-for-value-p vreg) + (if (logbitp vreg ppc-imm-regs) + (<- imm-reg) + (! s16->fixnum vreg imm-reg))))) + + +(defun ppc2-store-unsigned-halfword (seg vreg imm-reg) + (with-ppc-local-vinsn-macros (seg vreg) + (when (ppc2-for-value-p vreg) + (if (logbitp vreg ppc-imm-regs) + (<- imm-reg) + (! u16->fixnum vreg imm-reg))))) + + + +;;; If "value-first-p" is true and both "offset" and "val" need to be +;;; evaluated, evaluate "val" before evaluating "offset". +(defun ppc2-%immediate-set-ptr (seg vreg xfer ptr offset val) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((intval (acode-absolute-ptr-p val)) + (offval (acode-fixnum-form-p offset)) + (absptr (and offval (acode-absolute-ptr-p ptr))) + (for-value (ppc2-for-value-p vreg))) + (flet ((address-and-node-regs () + (if for-value + (progn + (ppc2-one-targeted-reg-form seg val ($ ppc::arg_z)) + (if (eq intval 0) + (values ppc::rzero ppc::arg_z) + (progn + (if intval + (ppc2-lri seg ppc::imm0 intval) + (! deref-macptr ppc::imm0 ppc::arg_z)) + (values ppc::imm0 ppc::arg_z)))) + (if (eq intval 0) + (values ppc::rzero nil) + (values (ppc2-macptr-arg-to-reg seg val ($ ppc::imm0 :mode :address)) nil))))) + (if (and absptr offval) + (setq absptr (+ absptr offval) offval 0) + (setq absptr nil)) + (and offval (%i> (integer-length offval) 15) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 15) (setq absptr nil)) + (target-arch-case + (:ppc32 (progn)) + (:ppc64 (progn + (and offval (logtest 3 offval) (setq offval nil)) + (and absptr (logtest 3 absptr) (setq absptr nil))))) + (if absptr + (multiple-value-bind (address node) (address-and-node-regs) + (! mem-set-c-address address ppc::rzero absptr) + (if for-value + (<- node))) + ; No absolute ptr (which is presumably a rare case anyway.) + (if offval + ; Easier: need one less register than in the general case. + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (if intval + (with-imm-target (ptr-reg) (val-target :address) + (if (eql intval 0) + (setq val-target ppc::rzero) + (ppc2-lri seg val-target intval)) + (! mem-set-c-address val-target ptr-reg offval) + (if for-value + (<- (set-regspec-mode val-target (gpr-mode-name-value :address))))) + (progn + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk) + (multiple-value-bind (address node) (address-and-node-regs) + (with-imm-target (address) (ptr-reg :address) + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo) + (! mem-set-c-address address ptr-reg offval) + (if for-value + (<- node))))))) + ;; No (16-bit) constant offset. Might still have a 32-bit + ;; constant offset; might have a constant value. Might + ;; not. Might not. Easiest to special-case the + ;; constant-value case first ... + (let* ((xptr-reg nil) + (xoff-reg nil) + (xval-reg nil) + (node-arg_z nil) + (constant-offset (acode-fixnum-form-p offset))) + (if intval + (if constant-offset + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (with-imm-target (ptr-reg) (off-reg :signed-natural) + (ppc2-lri seg off-reg constant-offset) + (with-imm-target (ptr-reg off-reg) (val-reg :address) + (if (eql intval 0) + (setq val-reg ppc::rzero) + (ppc2-lri seg val-reg intval)) + (setq xptr-reg ptr-reg + xoff-reg off-reg + xval-reg val-reg)))) + ; Offset's non-constant. Temp-push the pointer, evaluate + ; and unbox the offset, load the value, pop the pointer. + (progn + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk)) + (with-imm-target () (off-reg :signed-natural) + (! fixnum->signed-natural off-reg (ppc2-one-targeted-reg-form seg offset ($ ppc::arg_z))) + (with-imm-target (off-reg) (val-reg :signed-natural) + (if (eql intval 0) + (setq val-reg ppc::rzero) + (ppc2-lri seg val-reg intval)) + (with-imm-target (off-reg val-reg) (ptr-reg :address) + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo) + (setq xptr-reg ptr-reg + xoff-reg off-reg + xval-reg val-reg)))))) + ;; No intval; maybe constant-offset. + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk) + (progn + (if (not constant-offset) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (multiple-value-bind (address node) (address-and-node-regs) + (with-imm-target (address) (off-reg :s32) + (if constant-offset + (ppc2-lri seg off-reg constant-offset) + (with-node-temps (ppc::arg_z) (temp) + (ppc2-vpop-register seg temp) + (! fixnum->signed-natural off-reg temp))) + (with-imm-target (ppc::imm0 off-reg) (ptr-reg :address) + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo) + (setq xptr-reg ptr-reg + xoff-reg off-reg + xval-reg address + node-arg_z node))))))) + (! mem-set-address xval-reg xptr-reg xoff-reg) + (when for-value + (if node-arg_z + (<- node-arg_z) + (<- (set-regspec-mode + xval-reg + (gpr-mode-name-value :address)))))))) + (^))))) + +(defun ppc2-memory-store-displaced (seg valreg basereg displacement size) + (with-ppc-local-vinsn-macros (seg) + (case size + (8 (! mem-set-c-doubleword valreg basereg displacement)) + (4 (! mem-set-c-fullword valreg basereg displacement)) + (2 (! mem-set-c-halfword valreg basereg displacement)) + (1 (! mem-set-c-byte valreg basereg displacement))))) + +(defun ppc2-memory-store-indexed (seg valreg basereg idxreg size) + (with-ppc-local-vinsn-macros (seg) + (case size + (8 (! mem-set-doubleword valreg basereg idxreg)) + (4 (! mem-set-fullword valreg basereg idxreg)) + (2 (! mem-set-halfword valreg basereg idxreg)) + (1 (! mem-set-byte valreg basereg idxreg))))) + +(defun ppc2-%immediate-store (seg vreg xfer bits ptr offset val) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (eql 0 (%ilogand #xf bits)) + (ppc2-%immediate-set-ptr seg vreg xfer ptr offset val) + (let* ((size (logand #xf bits)) + (long-p (eq size 4)) + (signed (not (logbitp 5 bits))) + (intval (if long-p (ppc2-long-constant-p val) (acode-fixnum-form-p val))) + (offval (acode-fixnum-form-p offset)) + (absptr (and offval (acode-absolute-ptr-p ptr))) + (for-value (ppc2-for-value-p vreg))) + (declare (fixnum size)) + (flet ((val-to-argz-and-imm0 () + (ppc2-one-targeted-reg-form seg val ($ ppc::arg_z)) + (if (eq size 8) + (if signed + (! gets64) + (! getu64)) + (if (and (eq size 4) + (target-arch-case + (:ppc32 t) + (:ppc64 nil))) + (if signed + (! gets32) + (! getu32)) + (! fixnum->signed-natural ppc::imm0 ppc::arg_z))))) + (if (and absptr offval) + (setq absptr (+ absptr offval) offval 0) + (setq absptr nil)) + (and offval (%i> (integer-length offval) 15) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 15) (setq absptr nil)) + (target-arch-case + (:ppc32 (progn)) + (:ppc64 (when (eql size 8) + (and offval (logtest 3 offval) (setq offval nil)) + (and absptr (logtest 3 absptr) (setq absptr nil))))) + (if absptr + (if intval + (with-imm-target () (val-target :s32) + (if (eql intval 0) + (setq val-target ppc::rzero) + (ppc2-lri seg val-target intval)) + (ppc2-memory-store-displaced seg val-target ppc::rzero absptr size) + (if for-value + (<- (set-regspec-mode + val-target + (gpr-mode-name-value + (case size + (8 (if signed :s64 :u64)) + (4 (if signed :s32 :u32)) + (2 (if signed :s16 :u16)) + (1 (if signed :s8 :u8)))))))) + (progn + (val-to-argz-and-imm0) + (ppc2-memory-store-displaced seg ppc::imm0 ppc::rzero absptr size) + (<- ppc::arg_z))) + ; No absolute ptr (which is presumably a rare case anyway.) + (if offval + ; Easier: need one less register than in the general case. + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (if intval + (with-imm-target (ptr-reg) (val-target :s32) + (if (eql intval 0) + (setq val-target ppc::rzero) + (ppc2-lri seg val-target intval)) + (ppc2-memory-store-displaced seg val-target ptr-reg offval size) + (if for-value + (<- (set-regspec-mode + val-target + (gpr-mode-name-value + (case size + (8 (if signed :s64 :u64)) + (4 (if signed :s32 :u32)) + (2 (if signed :s16 :u16)) + (1 (if signed :s8 :u8)))))))) + (progn + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk) + (val-to-argz-and-imm0) + (with-imm-target (ppc::imm0) (ptr-reg :address) + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo) + (ppc2-memory-store-displaced seg ppc::imm0 ptr-reg offval size) + (if for-value + (<- ppc::arg_z)))))) + ;; No (16-bit) constant offset. Might still have a 32-bit constant offset; + ;; might have a constant value. Might not. Might not. + ;; Easiest to special-case the constant-value case first ... + (let* ((xptr-reg nil) + (xoff-reg nil) + (xval-reg nil) + (node-arg_z nil) + (constant-offset (acode-fixnum-form-p offset))) + (if intval + (if constant-offset + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (with-imm-target (ptr-reg) (off-reg :s32) + (ppc2-lri seg off-reg constant-offset) + (with-imm-target (ptr-reg off-reg) (val-reg :s32) + (if (eql intval 0) + (setq val-reg ppc::rzero) + (ppc2-lri seg val-reg intval)) + (setq xptr-reg ptr-reg + xoff-reg off-reg + xval-reg val-reg)))) + ; Offset's non-constant. Temp-push the pointer, evaluate + ; and unbox the offset, load the value, pop the pointer. + (progn + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk)) + (with-imm-target () (off-reg :s32) + (! fixnum->signed-natural off-reg (ppc2-one-targeted-reg-form seg offset ($ ppc::arg_z))) + (with-imm-target (off-reg) (val-reg :s32) + (if (eql intval 0) + (setq val-reg ppc::rzero) + (ppc2-lri seg val-reg intval)) + (with-imm-target (off-reg val-reg) (ptr-reg :address) + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo) + (setq xptr-reg ptr-reg + xoff-reg off-reg + xval-reg val-reg)))))) + ;; No intval; maybe constant-offset. + (with-imm-target () (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk) + (progn + (if (not constant-offset) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (val-to-argz-and-imm0) + (with-imm-target (ppc::imm0) (off-reg :signed-natural) + (if constant-offset + (ppc2-lri seg off-reg constant-offset) + (with-node-temps (ppc::arg_z) (temp) + (ppc2-vpop-register seg temp) + (! fixnum->signed-natural off-reg temp))) + (with-imm-target (ppc::imm0 off-reg) (ptr-reg :address) + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo) + (setq xptr-reg ptr-reg + xoff-reg off-reg + xval-reg ppc::imm0 + node-arg_z t)))))) + (ppc2-memory-store-indexed seg xval-reg xptr-reg xoff-reg size) + (when for-value + (if node-arg_z + (<- ppc::arg_z) + (<- (set-regspec-mode + xval-reg + (gpr-mode-name-value + (case size + (8 (if signed :s64 :u64)) + (4 (if signed :s32 :u32)) + (2 (if signed :s16 :u16)) + (1 (if signed :s8 :u8))))))))))) + (^)))))) + + + + + +(defun ppc2-encoding-undo-count (encoding) + (svref encoding 0)) + +(defun ppc2-encoding-cstack-depth (encoding) ; hardly ever interesting + (svref encoding 1)) + +(defun ppc2-encoding-vstack-depth (encoding) + (svref encoding 2)) + +(defun ppc2-encoding-vstack-top (encoding) + (svref encoding 3)) + +(defun ppc2-encode-stack () + (vector *ppc2-undo-count* *ppc2-cstack* *ppc2-vstack* *ppc2-top-vstack-lcell*)) + +(defun ppc2-decode-stack (encoding) + (values (ppc2-encoding-undo-count encoding) + (ppc2-encoding-cstack-depth encoding) + (ppc2-encoding-vstack-depth encoding) + (ppc2-encoding-vstack-top encoding))) + +(defun ppc2-equal-encodings-p (a b) + (dotimes (i 3 t) + (unless (eq (svref a i) (svref b i)) (return)))) + +(defun ppc2-open-undo (&optional (reason $undocatch) (curstack (ppc2-encode-stack))) + (set-fill-pointer + *ppc2-undo-stack* + (set-fill-pointer *ppc2-undo-because* *ppc2-undo-count*)) + (vector-push-extend curstack *ppc2-undo-stack*) + (vector-push-extend reason *ppc2-undo-because*) + (setq *ppc2-undo-count* (%i+ *ppc2-undo-count* 1))) + +(defun ppc2-close-undo (&aux + (new-count (%i- *ppc2-undo-count* 1)) + (i (aref *ppc2-undo-stack* new-count))) + (multiple-value-setq (*ppc2-undo-count* *ppc2-cstack* *ppc2-vstack* *ppc2-top-vstack-lcell*) + (ppc2-decode-stack i)) + (set-fill-pointer + *ppc2-undo-stack* + (set-fill-pointer *ppc2-undo-because* new-count))) + + + + + +;;; "Trivial" means can be evaluated without allocating or modifying registers. +;;; Interim definition, which will probably stay here forever. +(defun ppc2-trivial-p (form &aux op bits) + (setq form (nx-untyped-form form)) + (and + (consp form) + (not (eq (setq op (%car form)) (%nx1-operator call))) + (or + (nx-null form) + (nx-t 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 form)))) + (neq (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) + (%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits))))))) + +(defun ppc2-lexical-reference-p (form) + (when (acode-p form) + (let ((op (acode-operator (setq form (acode-unwrapped-form form))))) + (when (or (eq op (%nx1-operator lexical-reference)) + (eq op (%nx1-operator inherited-arg))) + (%cadr form))))) + + + +(defun ppc2-ref-symbol-value (seg vreg xfer sym check-boundp) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (when vreg + (if (eq sym '*interrupt-level*) + (ensuring-node-target (target vreg) + (! ref-interrupt-level target)) + (if *ppc2-open-code-inline* + (ensuring-node-target (target vreg) + (with-node-target (target) src + (let* ((vcell (ppc2-symbol-value-cell sym)) + (reg (ppc2-register-constant-p vcell))) + (if reg + (setq src reg) + (ppc2-store-immediate seg vcell src))) + (if check-boundp + (! ref-symbol-value-inline target src) + (! %ref-symbol-value-inline target src)))) + (let* ((src ($ ppc::arg_z)) + (dest ($ ppc::arg_z))) + (ppc2-store-immediate seg (ppc2-symbol-value-cell sym) src) + (if check-boundp + (! ref-symbol-value dest src) + (! %ref-symbol-value dest src)) + (<- dest))))) + (^))) + +#| +(defun ppc2-ref-symbol-value (seg vreg xfer sym check-boundp) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (when vreg + (if (eq sym '*interrupt-level*) + (ensuring-node-target (target vreg) + (! ref-interrupt-level target)) + (let* ((src ($ ppc::arg_z)) + (dest ($ ppc::arg_z))) + (ppc2-store-immediate seg (ppc2-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 ppc2-extract-charcode (seg vreg xfer char safe) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((src (ppc2-one-untargeted-reg-form seg char ppc::arg_z))) + (when safe + (! trap-unless-character src)) + (if vreg + (ensuring-node-target (target vreg) + (! character->fixnum target src))) + (^)))) + + +(defun ppc2-reference-list (seg vreg xfer listform safe refcdr) + (if (ppc2-form-typep listform 'list) + (setq safe nil)) ; May also have been passed as NIL. + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((src (ppc2-one-untargeted-reg-form seg listform ppc::arg_z))) + (when safe + (! trap-unless-list src)) + (if vreg + (ensuring-node-target (target vreg) + (if refcdr + (! %cdr target src) + (! %car target src)))) + (^)))) + + + + + + + +(defun ppc2-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 ppc2-allocate-initialized-gvector (seg vreg xfer subtag initforms) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (null vreg) + (dolist (f initforms) (ppc2-form seg nil nil f)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (arch (backend-target-arch *target-backend*)) + (n (length initforms)) + (nntriv (let* ((count 0)) + (declare (fixnum count)) + (dolist (f initforms count) + (unless (ppc-side-effect-free-form-p f) + (incf count))))) + (header (arch::make-vheader n subtag))) + (declare (fixnum n nntriv)) + (cond ( (or *ppc2-open-code-inline* (> nntriv 3)) + (ppc2-formlist seg initforms nil) + (ppc2-lri seg ppc::imm0 header) + (! %ppc-gvector vreg ppc::imm0 (ash n (arch::target-word-shift arch)))) + (t + (let* ((pending ()) + (vstack *ppc2-vstack*)) + (declare (fixnum vstack)) + (dolist (form initforms) + (if (ppc-side-effect-free-form-p form) + (push form pending) + (progn + (push nil pending) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg form ppc::arg_z))))) + (ppc2-lri seg ppc::imm0 header) + (ensuring-node-target (target vreg) + (! %alloc-misc-fixed target ppc::imm0 (ash n (arch::target-word-shift arch))) + (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 (ppc2-one-untargeted-reg-form seg form nodetemp)) + (progn + (decf pushed-cell *ppc2-target-node-size*) + (ppc2-stack-to-register seg (ppc2-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 ppc2-acode-needs-memoization (valform) + (if (ppc2-form-typep valform 'fixnum) + nil + (let* ((val (acode-unwrapped-form valform))) + (if (or (eq val *nx-t*) + (eq val *nx-nil*) + (and (acode-p val) + (let* ((op (acode-operator val))) + (or (eq op (%nx1-operator fixnum)) #|(eq op (%nx1-operator immediate))|#)))) + nil + t)))) + +(defun ppc2-modify-cons (seg vreg xfer ptrform valform safe setcdr returnptr) + (if (ppc2-form-typep ptrform 'cons) + (setq safe nil)) ; May also have been passed as NIL. + (with-ppc-local-vinsn-macros (seg vreg xfer) + (multiple-value-bind (ptr-vreg val-vreg) (ppc2-two-targeted-reg-forms seg ptrform ($ ppc::arg_y) valform ($ ppc::arg_z)) + (when safe + (! trap-unless-cons ptr-vreg)) + (if setcdr + (! call-subprim-2 ($ ppc::arg_z) (subprim-name->offset '.SPrplacd) ptr-vreg val-vreg) + (! call-subprim-2 ($ ppc::arg_z) (subprim-name->offset '.SPrplaca) ptr-vreg val-vreg)) + (if returnptr + (<- ptr-vreg) + (<- val-vreg)) + (^)))) + + + +(defun ppc2-find-nilret-label () + (dolist (l *ppc2-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 *ppc2-vstack*))) + (and + (eq register-restore-count *ppc2-register-restore-count*) + (eq vsp *ppc2-vstack*))) + (or agenda (eq csp *ppc2-cstack*)) + (eq register-restore-ea *ppc2-register-restore-ea*) + (eq (%ilsr 1 (length agenda)) *ppc2-undo-count*) + (dotimes (i (the fixnum *ppc2-undo-count*) t) + (unless (and (eq (pop agenda) (aref *ppc2-undo-because* i)) + (eq (pop agenda) (aref *ppc2-undo-stack* i))) + (return))) + (return label))))) + +(defun ppc2-record-nilret-label () + (let* ((lab (backend-get-next-label)) + (info nil)) + (dotimes (i (the fixnum *ppc2-undo-count*)) + (push (aref *ppc2-undo-because* i) info) + (push (aref *ppc2-undo-stack* i) info)) + (push (cons + lab + (cons + *ppc2-vstack* + (cons + *ppc2-cstack* + (cons + *ppc2-register-restore-count* + (cons + *ppc2-register-restore-ea* + (nreverse info)))))) + *ppc2-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 ppc2-conditional-form (seg xfer form) + (let* ((uwf (acode-unwrapped-form form))) + (if (nx-null uwf) + (ppc2-branch seg (ppc2-cd-false xfer) nil) + (if (ppc-constant-form-p uwf) + (ppc2-branch seg (ppc2-cd-true xfer) nil) + (with-crf-target () crf + (ppc2-form seg crf xfer form)))))) + + +(defun ppc2-branch (seg xfer crf &optional cr-bit true-p) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (with-ppc-local-vinsn-macros (seg) + (setq xfer (or xfer 0)) + (when (logbitp $backend-mvpass-bit xfer) ;(ppc2-mvpass-p cd) + (setq xfer (logand (lognot $backend-mvpass-mask) xfer)) + (unless *ppc2-returning-values* + (ppc2-vpush-register seg ppc::arg_z) + (ppc2-set-nargs seg 1))) + (if (neq 0 xfer) + (if (eq xfer $backend-return) ;; xfer : RETURN ==> popj + (ppc2-do-return seg) + (if (not (ppc2-cd-compound-p xfer)) + (-> xfer) ;; xfer : label# ==> BRA label# + ;; cd is compound : ( / ) + (let* ((truebranch (ppc2-cd-true xfer)) + (falsebranch (ppc2-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 ppc::ppc-eq-bit)) + (if (and tn0 tnret nn0 nnret) + (progn + (! cbranch-true tlabel crf cr-bit ) ;; (label# / label#) + (-> nbranch))) + (if (and nnret tnret) + (if nn0 + (! cbranch-false nlabel crf cr-bit) + (! cbranch-true tlabel crf cr-bit)) + (let* ((aux-label (backend-get-next-label)) + (auxl (aref *backend-labels* aux-label))) + (if tn0 + (! cbranch-true auxl crf cr-bit) + (! cbranch-false auxl crf cr-bit)) + (ppc2-do-return seg) + (@ aux-label)))))))))) + +(defun ppc2-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 (ppc2-cd-compound-p cd) + (ppc2-make-compound-cd + (ppc2-cd-merge (ppc2-cd-true cd) label) + (ppc2-cd-merge (ppc2-cd-false cd) label) + mvpass) + cd) + (if mvpass + (logior $backend-mvpass-mask label) + label)))) + +(defun ppc2-mvpass-p (xfer) + (if xfer (or (logbitp $backend-mvpass-bit xfer) (eq xfer $backend-mvpass)))) + +(defun ppc2-cd-compound-p (xfer) + (if xfer (logbitp $backend-compound-branch-target-bit xfer))) + +(defun ppc2-cd-true (xfer) + (if (ppc2-cd-compound-p xfer) + (ldb $backend-compound-branch-true-byte xfer) + xfer)) + +(defun ppc2-cd-false (xfer) + (if (ppc2-cd-compound-p xfer) + (ldb $backend-compound-branch-false-byte xfer) + xfer)) + +(defun ppc2-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 ppc2-invert-cd (cd) + (if (ppc2-cd-compound-p cd) + (ppc2-make-compound-cd (ppc2-cd-false cd) (ppc2-cd-true cd) (logbitp $backend-mvpass-bit cd)) + cd)) + +(defun ppc2-long-constant-p (form) + (setq form (acode-unwrapped-form form)) + (or (acode-fixnum-form-p form) + (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq form (%cadr form)) + (if (integerp form) + form + (progn + (if (symbolp form) (setq form (symbol-name form))) + (if (and (stringp form) (eql (length form) 4)) + (logior (ash (%char-code (char form 0)) 24) + (ash (%char-code (char form 1)) 16) + (ash (%char-code (char form 2)) 8) + (%char-code (char form 3))) + (if (characterp form) (%char-code form)))))))) + +;;; execute body, cleanup afterwards (if need to) +(defun ppc2-undo-body (seg vreg xfer body old-stack) + (let* ((current-stack (ppc2-encode-stack)) + (numundo (%i- *ppc2-undo-count* (ppc2-encoding-undo-count old-stack)))) + (declare (fixnum numundo)) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (eq current-stack old-stack) + (ppc2-form seg vreg xfer body) + (if (eq xfer $backend-return) + (progn + (ppc2-form seg vreg xfer body) + (dotimes (i numundo) (ppc2-close-undo))) + (if (ppc2-mvpass-p xfer) + (progn + (ppc2-mvpass seg body) ; presumed to be ok + (let* ((*ppc2-returning-values* :pass)) + (ppc2-nlexit seg xfer numundo) + (^)) + (dotimes (i numundo) (ppc2-close-undo))) + (progn + ;; There are some cases where storing thru ppc::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. + (ppc2-form seg (if (or vreg (not (%izerop numundo))) ppc::arg_z) nil body) + (ppc2-unwind-set seg xfer old-stack) + (when vreg (<- ppc::arg_z)) + (^)))))))) + + +(defun ppc2-unwind-set (seg xfer encoding) + (multiple-value-bind (target-catch target-cstack target-vstack target-vstack-lcell) + (ppc2-decode-stack encoding) + (ppc2-unwind-stack seg xfer target-catch target-cstack target-vstack) + (setq *ppc2-undo-count* target-catch + *ppc2-cstack* target-cstack + *ppc2-vstack* target-vstack + *ppc2-top-vstack-lcell* target-vstack-lcell))) + +(defun ppc2-unwind-stack (seg xfer target-catch target-cstack target-vstack) + (let* ((current-catch *ppc2-undo-count*) + (current-cstack *ppc2-cstack*) + (current-vstack *ppc2-vstack*) + (diff (%i- current-catch target-catch)) + target + (exit-vstack current-vstack)) + (declare (ignore-if-unused target)) + (when (neq 0 diff) + (setq exit-vstack (ppc2-nlexit seg xfer diff)) + (multiple-value-setq (target current-cstack current-vstack) + (ppc2-decode-stack (aref *ppc2-undo-stack* target-catch)))) + (if (%i< 0 (setq diff (%i- current-cstack target-cstack))) + (with-ppc-local-vinsn-macros (seg) + (! adjust-sp diff))) + (if (%i< 0 (setq diff (%i- current-vstack target-vstack))) + (with-ppc-local-vinsn-macros (seg) + (! vstack-discard (ash diff (- *ppc2-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 ppc2-do-return (seg) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (mask *ppc2-register-restore-count*) + (ea *ppc2-register-restore-ea*) + (label nil) + (vstack nil) + (foldp (not *ppc2-open-code-inline*))) + (if (%izerop mask) (setq mask nil)) + (with-ppc-local-vinsn-macros (seg) + (progn + (setq vstack (ppc2-set-vstack (ppc2-unwind-stack seg $backend-return 0 0 #x7fffff))) + (if *ppc2-returning-values* + (cond ((and mask foldp (setq label (%cdr (assq vstack *ppc2-valret-labels*)))) + (-> label)) + (t + (@ (setq label (backend-get-next-label))) + (push (cons vstack label) *ppc2-valret-labels*) + (when mask + (with-imm-temps () (vsp0) + (! fixnum-add vsp0 ppc::vsp ppc::nargs) + (ppc2-restore-nvrs seg ea mask vsp0))) + (! nvalret))) + (if (null mask) + (if *ppc2-open-code-inline* + (progn + (! restore-full-lisp-context) + (! jump-return-pc)) + (! popj)) + (if (and foldp (setq label (assq *ppc2-vstack* *ppc2-popreg-labels*))) + (-> (cdr label)) + (let* ((new-label (backend-get-next-label))) + (@ new-label) + (push (cons *ppc2-vstack* new-label) *ppc2-popreg-labels*) + (ppc2-set-vstack (ppc2-restore-nvrs seg ea mask)) + (if *ppc2-open-code-inline* + (progn + (! restore-full-lisp-context) + (! jump-return-pc)) + (! popj)))))))) + nil)) + + + +(defun ppc2-mvcall (seg vreg xfer fn arglist &optional recursive-p) + (let* ((cstack *ppc2-cstack*) + (vstack *ppc2-vstack*)) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (and (eq xfer $backend-return) (not (ppc2-tailcallok xfer))) + (progn + (ppc2-mvcall seg vreg $backend-mvpass fn arglist t) + (ppc2-set-vstack (%i+ (if arglist *ppc2-target-node-size* 0) vstack)) + (setq *ppc2-cstack* cstack) + (let* ((*ppc2-returning-values* t)) (^))) + (let* ((mv-p (ppc2-mv-p xfer))) + (if (null arglist) + (ppc2-call-fn seg vreg xfer fn arglist nil) + (progn + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg fn ppc::arg_z)) + (ppc2-multiple-value-body seg (pop arglist)) + (when arglist + (ppc2-open-undo $undostkblk) + (! save-values) + (dolist (form arglist) + (ppc2-multiple-value-body seg form) + (! add-values)) + (ppc2-set-nargs seg 0) + (! recover-values) + (ppc2-close-undo)) + (! lisp-word-ref ppc::temp0 ppc::vsp ppc::nargs) + (ppc2-invoke-fn seg ppc::temp0 nil nil xfer))) + (unless recursive-p + (if mv-p + (unless (eq xfer $backend-return) + (let* ((*ppc2-returning-values* t)) + (^))) + (progn + (ppc2-adjust-vstack (- *ppc2-target-node-size*)) ; discard function + (! vstack-discard 1) + (<- ppc::arg_z) + (^))))))))) + + +(defun ppc2-hard-opt-p (opts) + (or + (dolist (x (%cadr opts)) + (unless (nx-null x) (return t))) + (dolist (x (%caddr opts)) + (when x (return t))))) + +(defun ppc2-close-lambda (seg req opt rest keys auxen) + (dolist (var req) + (ppc2-close-var seg var)) + (dolist (var (%car opt)) + (ppc2-close-var seg var)) + (dolist (var (%caddr opt)) + (when var + (ppc2-close-var seg var))) + (if rest + (ppc2-close-var seg rest)) + (dolist (var (%cadr keys)) + (ppc2-close-var seg var)) + (dolist (var (%caddr keys)) + (if var (ppc2-close-var seg var))) + (dolist (var (%car auxen)) + (ppc2-close-var seg var))) + +(defun ppc2-close-structured-var (seg var) + (if (ppc2-structured-var-p var) + (apply #'ppc2-close-structured-lambda seg (cdr var)) + (ppc2-close-var seg var))) + +(defun ppc2-close-structured-lambda (seg whole req opt rest keys auxen) + (if whole + (ppc2-close-var seg whole)) + (dolist (var req) + (ppc2-close-structured-var seg var)) + (dolist (var (%car opt)) + (ppc2-close-structured-var seg var)) + (dolist (var (%caddr opt)) + (when var + (ppc2-close-var seg var))) + (if rest + (ppc2-close-structured-var seg rest)) + (dolist (var (%cadr keys)) + (ppc2-close-structured-var seg var)) + (dolist (var (%caddr keys)) + (if var (ppc2-close-var seg var))) + (dolist (var (%car auxen)) + (ppc2-close-var seg var))) + + +(defun ppc2-init-regvar (seg var reg addr) + (with-ppc-local-vinsn-macros (seg) + (ppc2-stack-to-register seg addr reg) + (ppc2-set-var-ea seg var ($ reg)))) + +(defun ppc2-bind-structured-var (seg var vloc lcell &optional context) + (if (not (ppc2-structured-var-p var)) + (let* ((reg (ppc2-assign-register-var var))) + (if reg + (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) + (ppc2-bind-var seg var vloc lcell))) + (let* ((v2 (%cdr var)) + (v v2) + (vstack *ppc2-vstack*) + (whole (pop v)) + (req (pop v)) + (opt (pop v)) + (rest (pop v)) + (keys (pop v))) + + (apply #'ppc2-bind-structured-lambda seg + (ppc2-spread-lambda-list seg (ppc2-vloc-ea vloc) whole req opt rest keys context) + vstack context v2)))) + +(defun ppc2-bind-structured-lambda (seg lcells vloc context whole req opt rest keys auxen + &aux (nkeys (list-length (%cadr keys)))) + (declare (fixnum vloc)) + (when whole + (ppc2-bind-structured-var seg whole vloc (pop lcells)) + (incf vloc *ppc2-target-node-size*)) + (dolist (arg req) + (ppc2-bind-structured-var seg arg vloc (pop lcells) context) + (incf vloc *ppc2-target-node-size*)) + (when opt + (if (ppc2-hard-opt-p opt) + (setq vloc (apply #'ppc2-structured-initopt seg lcells vloc context opt) + lcells (nthcdr (ash (length (car opt)) 1) lcells)) + (dolist (var (%car opt)) + (ppc2-bind-structured-var seg var vloc (pop lcells) context) + (incf vloc *ppc2-target-node-size*)))) + (when rest + (ppc2-bind-structured-var seg rest vloc (pop lcells) context) + (incf vloc *ppc2-target-node-size*)) + (when keys + (apply #'ppc2-structured-init-keys seg lcells vloc context keys) + (setq vloc (%i+ vloc (* *ppc2-target-node-size* (+ nkeys nkeys))))) + (ppc2-seq-bind seg (%car auxen) (%cadr auxen))) + +(defun ppc2-structured-var-p (var) + (and (consp var) (or (eq (%car var) *nx-lambdalist*) + (eq (%car var) (%nx1-operator lambda-list))))) + +(defun ppc2-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 ppc2-nlexit (seg xfer &optional (nlevels 0)) + (let* ((numnthrow 0) + (n *ppc2-undo-count*) + (cstack *ppc2-cstack*) + (vstack *ppc2-vstack*) + (target-cstack) + (target-vstack) + (lastcatch n) + (i nil) + (returning (eq xfer $backend-return)) + (junk1 nil) + (unbind ()) + (dest (%i- n nlevels)) + (retval *ppc2-returning-values*) + reason) + (declare (ignorable junk1)) + (with-ppc-local-vinsn-macros (seg) + (when (neq 0 nlevels) + (let* ((numnlispareas 0)) + (declare (fixnum numnlispareas)) + (flet ((popnlispareas () + (dotimes (i numnlispareas) + (! discard-temp-frame))) + (throw-through-numnthrow-catch-frames () + (when (neq 0 numnthrow) + (ppc2-lri seg ppc::imm0 (ash numnthrow *ppc2-target-fixnum-shift*)) + (if retval + (! nthrowvalues) + (! nthrow1value)) + (setq numnthrow 0) + (multiple-value-setq (junk1 cstack vstack) + (ppc2-decode-stack (aref *ppc2-undo-stack* lastcatch)))))) + (while (%i> n dest) + (cond ((eql $undocatch (setq reason (aref *ppc2-undo-because* (setq n (%i- n 1))))) + (popnlispareas) + (setq numnthrow (%i+ numnthrow 1) lastcatch n)) + ((eql $undostkblk reason) + (throw-through-numnthrow-catch-frames) + (incf numnlispareas)) + ((eql $undo-ppc-c-frame reason) + (! discard-c-frame)))) + (throw-through-numnthrow-catch-frames) + (setq i lastcatch) + (while (%i> i dest) + (let ((reason (aref *ppc2-undo-because* (setq i (%i- i 1))))) + (if (or (eql reason $undospecial) + (eql reason $undointerruptlevel)) + (push reason unbind)))) + (if unbind + (ppc2-dpayback-list seg (nreverse unbind))) + (when (and (neq lastcatch dest) + (%i> + vstack + (setq target-vstack + (nth-value 2 (ppc2-decode-stack (aref *ppc2-undo-stack* dest))))) + (neq retval t)) + (unless returning + (let ((vdiff (%i- vstack target-vstack))) + (if retval + (progn + (ppc2-lri seg ppc::imm0 vdiff) + (! slide-values)) + (! adjust-vsp vdiff))))) + (setq numnlispareas 0) + (while (%i> lastcatch dest) + (let ((reason (aref *ppc2-undo-because* (setq lastcatch (%i- lastcatch 1))))) + (setq target-cstack (nth-value 1 + (ppc2-decode-stack (aref *ppc2-undo-stack* lastcatch)))) + (if (eq reason $undostkblk) + (incf numnlispareas)) + (if (%i> cstack target-cstack) + (with-ppc-local-vinsn-macros (seg) + (! adjust-sp (%i- cstack target-cstack)))) + ; else what's going on? $sp-stkcons, for one thing + (setq cstack target-cstack))) + (popnlispareas))) + vstack)))) + + +;;; Restore the most recent dynamic bindings. Bindings +;;; of *INTERRUPT-LEVEL* get special treatment. +(defun ppc2-dpayback-list (seg reasons) + (with-ppc-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 *ppc2-open-code-inline* + (! unbind-interrupt-level-inline) + (! unbind-interrupt-level))) + (nx-error "unknown payback token ~s" r))))))) + +(defun ppc2-spread-lambda-list (seg listform whole req opt rest keys + &optional enclosing-ea cdr-p) + (with-ppc-local-vinsn-macros (seg) + (let* ((numopt (length (%car opt))) + (nkeys (length (%cadr keys))) + (numreq (length req)) + (vtotal numreq) + (old-top *ppc2-top-vstack-lcell*) + (listreg ($ ppc::temp3)) + (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) + (ppc2-store-ea seg listform listreg) + (ppc2-one-targeted-reg-form seg listform listreg)) + (when whole + (ppc2-vpush-register seg listreg :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)))) + (ppc2-store-immediate seg (%car (%cdr (%cdr (%cdr (%cdr keys))))) ppc::temp2)) + (when opt + (setq vtotal (%i+ vtotal numopt)) + (when (ppc2-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))) + (ppc2-reserve-vstack-lcells vtotal) + (! load-adl doadlword) + (if cdr-p + (! macro-bind) + (if enclosing-ea + (progn + (ppc2-store-ea seg enclosing-ea ppc::arg_z) + (! destructuring-bind-inner)) + (! destructuring-bind))) + (ppc2-set-vstack (%i+ *ppc2-vstack* (* *ppc2-target-node-size* vtotal))) + (ppc2-collect-lcells :reserved old-top)))) + + +(defun ppc2-tailcallok (xfer) + (and (eq xfer $backend-return) + *ppc2-tail-allow* + (eq 0 *ppc2-undo-count*))) + +(defun ppc2-mv-p (cd) + (or (eq cd $backend-return) (ppc2-mvpass-p cd))) + +(defun ppc2-expand-note (note) + (let* ((lab (vinsn-note-label note))) + (case (vinsn-note-class note) + ((:regsave :begin-variable-scope :end-variable-scope) + (setf (vinsn-label-info lab) (emit-lap-label lab)))))) + +(defun ppc2-expand-vinsns (header) + (do-dll-nodes (v header) + (if (%vinsn-label-p v) + (let* ((id (vinsn-label-id v))) + (if (typep id 'fixnum) + (when (or t (vinsn-label-refs v)) + (setf (vinsn-label-info v) (emit-lap-label v))) + (ppc2-expand-note id))) + (ppc2-expand-vinsn v))) + ;;; 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 *ppc2-recorded-symbols*) + (let* ((var (car s)) + (ea (var-ea var))) + (when (typep ea 'lreg) + (setf (var-ea var) (lreg-value ea))))) + (free-logical-registers) + (ppc2-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 ppc2-expand-vinsn (vinsn) + (let* ((template (vinsn-template vinsn)) + (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-lap-label unique))) + (labels ((parse-operand-form (valform) + (cond ((typep valform 'keyword) + (or (assq valform unique-labels) + (compiler-bug "unknown vinsn label ~s" valform))) + ((atom valform) valform) + ((atom (cdr valform)) (svref vp (car valform))) + (t (let* ((op-vals (cdr valform)) + (parsed-ops (make-list (length op-vals))) + (tail parsed-ops)) + (declare (dynamic-extent parsed-ops) + (cons parsed-ops tail)) + (dolist (op op-vals (apply (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))) + (ppc-emit-lap-instruction (svref ppc::*ppc-opcodes* (car f)) + head))) + (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) + (cons parsed-ops tail)) + (dolist (op op-vals (apply (cadr f) parsed-ops)) + (setq tail (cdr (rplaca tail (parse-operand-form op))))))) + (: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-form (f) + (if (keywordp f) + (emit-lap-label (assq f unique-labels)) + (if (atom f) + (compiler-bug "Invalid form in vinsn body: ~s" f) + (if (atom (car 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)) + (expand-form form )) + (setf (vinsn-variable-parts vinsn) nil) + (when vp + (free-varparts-vector vp))))) + + + + + +(defun ppc2-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 ppc2-fixed-call-builtin (seg vreg xfer name subprim) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((index (arch::builtin-function-name-offset name)) + (idx-subprim (if index (ppc2-builtin-index-subprim index))) + (tail-p (ppc2-tailcallok xfer))) + (when tail-p + (ppc2-restore-nvrs seg *ppc2-register-restore-ea* *ppc2-register-restore-count*) + (ppc2-restore-full-lisp-context seg)) + (if idx-subprim + (setq subprim idx-subprim) + (if index (! lri ($ ppc::imm0) (ash index *ppc2-target-fixnum-shift*)))) + (if tail-p + (! jump-subprim subprim) + (progn + (! call-subprim subprim) + (<- ($ ppc::arg_z)) + (^)))))) + +(defun ppc2-unary-builtin (seg vreg xfer name form) + (with-ppc-local-vinsn-macros (seg) + (ppc2-one-targeted-reg-form seg form ($ ppc::arg_z)) + (ppc2-fixed-call-builtin seg vreg xfer name (subprim-name->offset '.SPcallbuiltin1)))) + +(defun ppc2-binary-builtin (seg vreg xfer name form1 form2) + (with-ppc-local-vinsn-macros (seg) + (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::arg_z)) + (ppc2-fixed-call-builtin seg vreg xfer name (subprim-name->offset '.SPcallbuiltin2)))) + +(defun ppc2-ternary-builtin (seg vreg xfer name form1 form2 form3) + (with-ppc-local-vinsn-macros (seg) + (ppc2-three-targeted-reg-forms seg form1 ($ ppc::arg_x) form2 ($ ppc::arg_y) form3 ($ ppc::arg_z)) + (ppc2-fixed-call-builtin seg vreg xfer name (subprim-name->offset '.SPcallbuiltin3)))) + + +(eval-when (:compile-toplevel :execute :load-toplevel) + + +(defmacro defppc2 (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-ppc-local-vinsn-macros (,vcode-block ,dest ,control) ,@body)))))) + `(progn + (record-source-file ',name 'function) + (svset *ppc2-specials* (%ilogand #.operator-id-mask (%nx1-operator ,locative)) ,fun)))))) +) + +(defppc2 ppc2-lambda lambda-list (seg vreg xfer req opt rest keys auxen body p2decls) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((stack-consed-rest 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 *ppc2-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 (ppc2-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) + (*ppc2-vstack* 0)) + (declare (type (unsigned-byte 16) num-req num-opt num-inh reqvloc)) + (with-ppc-p2-declarations p2decls + (setq *ppc2-inhibit-register-allocation* + (setq no-regs (%ilogbitp $fbitnoregs fbits))) + (multiple-value-setq (pregs reglocatives) + (ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) no-regs)) + (@ (backend-get-next-label)) ; generic self-reference label, should be label #1 + (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)))) + (if (not (or opt rest keys)) + (setq arg-regs (ppc2-req-nargs-entry seg rev-fixed)) + (if (and (not (or hardopt rest keys)) + (<= num-opt $numppcargregs)) + (setq arg-regs (ppc2-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. + + (when rev-fixed + (ppc2-reserve-vstack-lcells num-fixed) + (! check-min-nargs num-fixed)) + (unless (or rest keys) + (! check-max-nargs (+ num-fixed num-opt))) + ;; Going to have to call one or more subprims. First save + ;; the LR in LOC-PC. + (! save-lr) + ;; If there were &optional args, initialize their values + ;; to NIL. All of the argregs get vpushed as a result of this. + (when opt + (ppc2-reserve-vstack-lcells num-opt) + (! 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))) + (ppc2-new-vstack-lcell :reserved *ppc2-target-lcell-size* 0 nil)) + (! misc-ref-c-node ppc::temp3 ppc::nfn (1+ (backend-immediate-index keyvect))) + (ppc2-lri seg ppc::imm2 (ash flags *ppc2-target-fixnum-shift*)) + (ppc2-lri seg ppc::imm3 (ash nkeys *ppc2-target-fixnum-shift*)) + (unless (= nprev 0) + (ppc2-lri seg ppc::imm0 (ash nprev *ppc2-target-fixnum-shift*))) + (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 + (ppc2-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 + (ppc2-lri seg ppc::imm0 (ash nprev *ppc2-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 + (ppc2-reserve-vstack-lcells 1)))) + (when hardopt + (ppc2-reserve-vstack-lcells num-opt) + (ppc2-lri seg ppc::imm0 (ash num-opt *ppc2-target-fixnum-shift*)) + + ;; .SPopt-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)) + (! opt-supplied-p)) + (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 *ppc2-target-node-size*))) + (declare (fixnum nwords-vpushed nbytes-vpushed)) + (unless (or lexprp keys) + (if *ppc2-open-code-inline* + (! save-lisp-context-offset nbytes-vpushed) + (! save-lisp-context-offset-ool nbytes-vpushed))) + (ppc2-set-vstack nbytes-vpushed) + (setq optsupvloc (- *ppc2-vstack* (* num-opt *ppc2-target-node-size*))))))) + ;; Caller's context is saved; *ppc2-vstack* is valid. Might still have method-var + ;; to worry about. + (unless (= 0 pregs) + ;; Save NVRs; load constants into any that get constants. + (ppc2-save-nvrs seg pregs) + + (dolist (pair reglocatives) + (declare (cons pair)) + (let* ((constant (car pair)) + (reg (cdr pair))) + (declare (cons constant)) + (rplacd constant reg) + (! ref-constant reg (backend-immediate-index (car constant)))))) + (when (and (not (or opt rest keys)) + (<= num-fixed $numppcargregs) + (not (some #'null arg-regs))) + (setq *ppc2-tail-vsp* *ppc2-vstack* + *ppc2-tail-nargs* num-fixed) + (@ (setq *ppc2-tail-label* (backend-get-next-label)))) + (when method-var + (ppc2-seq-bind-var seg method-var ppc::next-method-context)) + ;; 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-num ppc::arg_z (1- arg-reg-num))) + ((null vars)) + (declare (list vars) (fixnum arg-reg-num)) + (let* ((var (car vars))) + (when var + (let* ((reg (ppc2-assign-register-var var))) + (ppc2-copy-register seg reg arg-reg-num) + (setf (var-ea var) reg)))))) + (setq *ppc2-entry-vsp-saved-p* t) +#| + (when stack-consed-rest + (if rest-ignored-p + (if nil (ppc2-jsrA5 $sp-popnlisparea)) + (progn + (ppc2-open-undo $undostkblk)))) +|# + (when stack-consed-rest + (ppc2-open-undo $undostkblk)) + (setq *ppc2-entry-vstack* *ppc2-vstack*) + (setq reserved-lcells (ppc2-collect-lcells :reserved)) + (ppc2-bind-lambda seg reserved-lcells req opt rest keys auxen optsupvloc arg-regs lexprp inherited-vars)) + (when method-var (ppc2-heap-cons-next-method-var seg method-var)) + (ppc2-form seg vreg xfer body) + (ppc2-close-lambda seg req opt rest keys auxen) + (dolist (v inherited-vars) + (ppc2-close-var seg v)) + (when method-var + (ppc2-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))))) + + +(defppc2 ppc2-progn progn (seg vreg xfer forms) + (declare (list forms)) + (if (null forms) + (ppc2-nil seg vreg xfer) + (loop + (let* ((form (pop forms))) + (if forms + (ppc2-form seg nil nil form) + (return (ppc2-form seg vreg xfer form))))))) + + + +(defppc2 ppc2-prog1 prog1 (seg vreg xfer forms) + (if (eq (list-length forms) 1) + (ppc2-use-operator (%nx1-operator values) seg vreg xfer forms) + (if (null vreg) + (ppc2-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))) + (ppc2-push-register seg + (if (or node-p crf-p) + (ppc2-one-untargeted-reg-form seg first ppc::arg_z) + (ppc2-one-targeted-reg-form seg first vreg))) + (dolist (form forms) + (ppc2-form seg nil nil form)) + (if crf-p + (progn + (ppc2-vpop-register seg ppc::arg_z) + (<- ppc::arg_z)) + (ppc2-pop-register seg vreg)) + (^))))) + +(defppc2 ppc2-free-reference free-reference (seg vreg xfer sym) + (ppc2-ref-symbol-value seg vreg xfer sym t)) + +(defppc2 ppc2-special-ref special-ref (seg vreg xfer sym) + (ppc2-ref-symbol-value seg vreg xfer sym t)) + +(defppc2 ppc2-bound-special-ref bound-special-ref (seg vreg xfer sym) + (ppc2-ref-symbol-value seg vreg xfer sym nil)) + +(defppc2 ppc2-%slot-ref %slot-ref (seg vreg xfer instance idx) + (ensuring-node-target (target (or vreg ($ ppc::arg_z))) + (multiple-value-bind (v i) + (ppc2-two-untargeted-reg-forms seg instance ppc::arg_y idx ppc::arg_z) + (unless *ppc2-reckless* + (! check-misc-bound i v)) + (with-node-temps (v) (temp) + (! %slot-ref temp v i) + (ppc2-copy-register seg target temp)))) + (^)) + +(defppc2 ppc2-%svref %svref (seg vreg xfer vector index) + (ppc2-vref seg vreg xfer :simple-vector vector index nil)) + +(defppc2 ppc2-svref svref (seg vreg xfer vector index) + (ppc2-vref seg vreg xfer :simple-vector vector index (unless *ppc2-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. +(defppc2 ppc2-%sbchar %sbchar (seg vreg xfer string index) + (ppc2-vref seg vreg xfer :simple-string string index (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag :simple-string)))) + + +(defppc2 ppc2-%svset %svset (seg vreg xfer vector index value) + (ppc2-vset seg vreg xfer :simple-vector vector index value nil)) + +(defppc2 ppc2-svset svset (seg vreg xfer vector index value) + (ppc2-vset seg vreg xfer :simple-vector vector index value (nx-lookup-target-uvector-subtag :simple-vector))) + +(defppc2 ppc2-typed-form typed-form (seg vreg xfer typespec form) + (declare (ignore typespec)) ; Boy, do we ever ! + (ppc2-form seg vreg xfer form)) + +(defppc2 ppc2-%primitive %primitive (seg vreg xfer &rest ignore) + (declare (ignore seg vreg xfer ignore)) + (compiler-bug "You're probably losing big: using %primitive ...")) + +(defppc2 ppc2-consp consp (seg vreg xfer cc form) + (if (null vreg) + (ppc2-form seg vreg xfer form) + (let* ((tagreg ppc::imm0)) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (! extract-fulltag tagreg (ppc2-one-untargeted-reg-form seg form ppc::arg_z)) + (ppc2-test-reg-%izerop seg vreg xfer tagreg cr-bit true-p + (target-arch-case + (:ppc32 ppc32::fulltag-cons) + (:ppc64 ppc64::fulltag-cons))))))) + +(defppc2 ppc2-cons cons (seg vreg xfer y z) + (if (null vreg) + (progn + (ppc2-form seg nil nil y) + (ppc2-form seg nil xfer z)) + (multiple-value-bind (yreg zreg) (ppc2-two-untargeted-reg-forms seg y ppc::arg_y z ppc::arg_z) + (ensuring-node-target (target vreg) + (! cons target yreg zreg)) + (^)))) + + + +(defppc2 ppc2-%rplaca %rplaca (seg vreg xfer ptr val) + (ppc2-modify-cons seg vreg xfer ptr val nil nil t)) + +(defppc2 ppc2-%rplacd %rplacd (seg vreg xfer ptr val) + (ppc2-modify-cons seg vreg xfer ptr val nil t t)) + +(defppc2 ppc2-rplaca rplaca (seg vreg xfer ptr val) + (ppc2-modify-cons seg vreg xfer ptr val t nil t)) + +(defppc2 ppc2-set-car set-car (seg vreg xfer ptr val) + (ppc2-modify-cons seg vreg xfer ptr val t nil nil)) + +(defppc2 ppc2-rplacd rplacd (seg vreg xfer ptr val) + (ppc2-modify-cons seg vreg xfer ptr val t t t)) + +(defppc2 ppc2-set-cdr set-cdr (seg vreg xfer ptr val) + (ppc2-modify-cons seg vreg xfer ptr val t t nil)) + +(defppc2 ppc2-%car %car (seg vreg xfer form) + (ppc2-reference-list seg vreg xfer form nil nil)) + +(defppc2 ppc2-%cdr %cdr (seg vreg xfer form) + (ppc2-reference-list seg vreg xfer form nil t)) + +(defppc2 ppc2-car car (seg vreg xfer form) + (ppc2-reference-list seg vreg xfer form t nil)) + +(defppc2 ppc2-cdr cdr (seg vreg xfer form) + (ppc2-reference-list seg vreg xfer form t t)) + + +(defppc2 ppc2-vector vector (seg vreg xfer arglist) + (ppc2-allocate-initialized-gvector seg vreg xfer + (nx-lookup-target-uvector-subtag + :simple-vector) arglist)) + +(defppc2 ppc2-%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 (^)) (ppc2-form seg nil nil form)) + (if (null subtag) + (progn ; Vpush everything and call subprim + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-set-nargs seg (ppc2-formlist seg all-on-stack nil)) + (! gvector)) + (<- ppc::arg_z) + (^)) + (ppc2-allocate-initialized-gvector seg vreg xfer subtag (cdr all-on-stack)))))) + +;;; Should be less eager to box result +(defppc2 ppc2-%char-code %char-code (seg vreg xfer c) + (ppc2-extract-charcode seg vreg xfer c nil)) + +(defppc2 ppc2-char-code char-code (seg vreg xfer c) + (ppc2-extract-charcode seg vreg xfer c (not (ppc2-form-typep c 'character)))) + +(defppc2 ppc2-%ilogior2 %ilogior2 (seg vreg xfer form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (logior fix1 fix2))) + (let* ((fixval (or fix1 fix2)) + (unboxed-fixval (if fixval (ash fixval *ppc2-target-fixnum-shift*))) + (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) + (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) + (otherform (if (or high low) (if fix1 form2 form1)))) + (if otherform + (let* ((other-reg (ppc2-one-untargeted-reg-form seg otherform ppc::arg_z))) + (when vreg + (ensuring-node-target (target vreg) + (if high + (! logior-high target other-reg high) + (! logior-low target other-reg low))))) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::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. + +(defppc2 ppc2-%ilogand2 %ilogand2 (seg vreg xfer form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (logand fix1 fix2)) + (let* ((fixval (or fix1 fix2)) + (fixlen (if fixval (integer-length fixval))) + (unboxed-fixval (if fixval (ash fixval *ppc2-target-fixnum-shift*))) + (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) + (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) + (otherform (if (or high low) (if fix1 form2 form1)))) + (if otherform + (let* ((other-reg (ppc2-one-untargeted-reg-form seg otherform ppc::arg_z))) + (when vreg + (ensuring-node-target (target vreg) + (if high + (! logand-high target other-reg high) + (! logand-low target other-reg low))))) + (if (and fixval (= fixlen (logcount fixval))) + (let* ((nbits (- *ppc2-target-bits-in-word* + (1+ (+ *ppc2-target-fixnum-shift* fixlen)))) + (otherreg (ppc2-one-untargeted-reg-form seg (if fix1 form2 form1) ppc::arg_z))) + + (if vreg (ensuring-node-target (target vreg) + (if (> fixval 0) + (! clear-left target otherreg nbits) + (! clear-right target otherreg (+ fixlen + *ppc2-target-fixnum-shift*)))))) + + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z) + (if vreg (ensuring-node-target (target vreg) (! %logand2 target r1 r2)))))) + (^))))) + +(defppc2 ppc2-%ilogxor2 %ilogxor2 (seg vreg xfer form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (logxor fix1 fix2))) + (let* ((fixval (or fix1 fix2)) + (unboxed-fixval (if fixval (ash fixval *ppc2-target-fixnum-shift*))) + (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) + (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) + (otherform (if (or high low) (if fix1 form2 form1)))) + (if otherform + (let* ((other-reg (ppc2-one-untargeted-reg-form seg otherform ppc::arg_z))) + (when vreg + (ensuring-node-target (target vreg) + (if high + (! logxor-high target other-reg high) + (! logxor-low target other-reg low))))) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z) + (if vreg (ensuring-node-target (target vreg) (! %logxor2 vreg r1 r2))))) + (^)))) + +(defppc2 ppc2-%ineg %ineg (seg vreg xfer n) + (let* ((src (ppc2-one-untargeted-reg-form seg n ppc::arg_z))) + (when vreg + (ensuring-node-target (target vreg) + (if *ppc2-open-code-inline* + (! negate-fixnum-overflow-inline target src) + (progn + (! negate-fixnum-overflow-ool src) + (ppc2-copy-register seg target ($ ppc::arg_z)))))) + (^))) + +(defppc2 ppc2-%%ineg %%ineg (seg vreg xfer n) + (let* ((src (ppc2-one-untargeted-reg-form seg n ppc::arg_z))) + (when vreg + (ensuring-node-target (target vreg) + (! negate-fixnum-no-ovf target src))) + (^))) + +(defppc2 ppc2-characterp characterp (seg vreg xfer cc form) + (ppc2-char-p seg vreg xfer cc form)) + +(defppc2 ppc2-struct-ref struct-ref (seg vreg xfer struct offset) + (ppc2-vref seg vreg xfer :struct struct offset (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag :struct)))) + +(defppc2 ppc2-struct-set struct-set (seg vreg xfer struct offset value) + (ppc2-vset seg vreg xfer :struct struct offset value (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag :struct)))) + +(defppc2 ppc2-istruct-typep istruct-typep (seg vreg xfer cc form type) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form ppc::arg_y type ppc::arg_z) + (with-imm-target () (target :signed-natural) + (! istruct-typep target r1 r2) + (ppc2-test-reg-%izerop seg vreg xfer target cr-bit true-p 0))))) + + +(defppc2 ppc2-lisptag lisptag (seg vreg xfer node) + (if (null vreg) + (ppc2-form seg vreg xfer node) + (progn + (ensuring-node-target (target vreg) + (! extract-tag-fixnum target (ppc2-one-untargeted-reg-form seg node ppc::arg_z))) + (^)))) + +(defppc2 ppc2-fulltag fulltag (seg vreg xfer node) + (if (null vreg) + (ppc2-form seg vreg xfer node) + (progn + (ensuring-node-target (target vreg) + (! extract-fulltag-fixnum target (ppc2-one-untargeted-reg-form seg node ppc::arg_z))) + (^)))) + +(defppc2 ppc2-typecode typecode (seg vreg xfer node) + (if (null vreg) + (ppc2-form seg vreg xfer node) + (let* ((reg (ppc2-one-untargeted-reg-form seg node (if (eq (hard-regspec-value vreg) ppc::arg_z) + ppc::arg_y ppc::arg_z)))) + (ensuring-node-target (target vreg) + (! extract-typecode-fixnum target reg )) + (^)))) + +(defppc2 ppc2-setq-special setq-special (seg vreg xfer sym val) + (let* ((symreg ($ ppc::arg_y)) + (valreg ($ ppc::arg_z))) + (ppc2-one-targeted-reg-form seg val valreg) + (ppc2-store-immediate seg (ppc2-symbol-value-cell sym) symreg) + (! setq-special symreg valreg) + (<- valreg)) + (^)) + + +(defppc2 ppc2-local-go local-go (seg vreg xfer tag) + (declare (ignorable xfer)) + (let* ((curstack (ppc2-encode-stack)) + (label (cadr tag)) + (deststack (caddr tag))) + (if (not (ppc2-equal-encodings-p curstack deststack)) + (multiple-value-bind (catch cstack vstack) + (ppc2-decode-stack deststack) + (ppc2-unwind-stack seg nil catch cstack vstack))) + (-> label) + (ppc2-unreachable-store vreg))) + +(defppc2 ppc2-local-block local-block (seg vreg xfer blocktag body) + (let* ((curstack (ppc2-encode-stack)) + (compound (ppc2-cd-compound-p xfer)) + (mvpass-p (ppc2-mvpass-p xfer)) + (need-label (if xfer (or compound mvpass-p) t)) + end-of-block + last-cd + (dest (if (backend-crf-p vreg) ppc::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 + (ppc2-multiple-value-body seg body) + (ppc2-form seg dest (if xfer last-cd) body)) + (when need-label + (@ end-of-block) + (if compound + (<- dest)) + (ppc2-branch seg (logand (lognot $backend-mvpass-mask) (or xfer 0)) vreg)))) + +(defppc2 ppc2-%izerop %izerop (seg vreg xfer cc form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-test-%izerop seg vreg xfer form cr-bit true-p))) + + +(defppc2 ppc2-uvsize uvsize (seg vreg xfer v) + (let* ((misc-reg (ppc2-one-untargeted-reg-form seg v ppc::arg_z))) + (unless *ppc2-reckless* (! trap-unless-uvector misc-reg)) + (if vreg + (ensuring-node-target (target vreg) + (! misc-element-count-fixnum target misc-reg))) + (^))) + +(defppc2 ppc2-%ilsl %ilsl (seg vreg xfer form1 form2) + (if (null vreg) + (progn + (ppc2-form seg nil nil form1) + (ppc2-form seg nil xfer form2)) + (let* ((const (acode-fixnum-form-p form1)) + (max (target-arch-case (:ppc32 31) (:ppc64 63)))) + (ensuring-node-target (target vreg) + (if const + (let* ((src (ppc2-one-untargeted-reg-form seg form2 ppc::arg_z))) + (if (<= const max) + (! %ilsl-c target const src) + (! lri target 0))) + (multiple-value-bind (count src) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z) + (! %ilsl target count src)))) + (^)))) + +(defppc2 ppc2-endp endp (seg vreg xfer cc form) + (let* ((formreg (ppc2-one-untargeted-reg-form seg form ppc::arg_z))) + (! trap-unless-list formreg) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-compare-register-to-nil seg vreg xfer formreg cr-bit true-p)))) + + + +(defppc2 ppc2-%code-char %code-char (seg vreg xfer c) + (if (null vreg) + (ppc2-form seg nil xfer c) + (progn + (ensuring-node-target (target vreg) + (with-imm-target () (dest :u8) + (! u32->char target (ppc2-one-untargeted-reg-form seg c dest)))) + (^)))) + +(defppc2 ppc2-%schar %schar (seg vreg xfer str idx) + (multiple-value-bind (src unscaled-idx) + (ppc2-two-untargeted-reg-forms seg str ppc::arg_y idx ppc::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))))) + (^))) + +(defppc2 ppc2-%set-schar %set-schar (seg vreg xfer str idx char) + (multiple-value-bind (src unscaled-idx char) + (ppc2-three-untargeted-reg-forms seg + str ppc::arg_x + idx ppc::arg_y + char ppc::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)) + (^))) + +(defppc2 ppc2-%set-scharcode %set-scharcode (seg vreg xfer str idx char) + (multiple-value-bind (src unscaled-idx char) + (ppc2-three-untargeted-reg-forms seg str ppc::arg_x idx ppc::arg_y + char ppc::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)) + (^))) + +(defppc2 ppc2-%scharcode %scharcode (seg vreg xfer str idx) + (multiple-value-bind (src unscaled-idx) + (ppc2-two-untargeted-reg-forms seg str ppc::arg_y idx ppc::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))))) + (^))) + + + +(defppc2 ppc2-code-char code-char (seg vreg xfer c) + (let* ((reg (ppc2-one-untargeted-reg-form seg c ppc::arg_z))) + ;; Typecheck even if result unused. + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! require-u8 reg)) + (t (! require-char-code reg))) + (if vreg + (ensuring-node-target (target vreg) + (! fixnum->char target reg))) + (^))) + +(defppc2 ppc2-eq eq (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-compare seg vreg xfer form1 form2 cr-bit true-p))) + +(defppc2 ppc2-neq neq (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-compare seg vreg xfer form1 form2 cr-bit true-p))) + +(defppc2 ppc2-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 (ppc2-explicit-non-fixnum-type-p form1) + (ppc2-explicit-non-fixnum-type-p form2)) + (ppc2-binary-builtin seg vreg xfer name form1 form2) + (ppc2-inline-numcmp seg vreg xfer cc name form1 form2)))) + +(defun ppc2-inline-numcmp (seg vreg xfer cc name form1 form2) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (let* ((otherform (and (eql cr-bit ppc::ppc-eq-bit) + (if (eql (acode-fixnum-form-p form2) 0) + form1 + (if (eql (acode-fixnum-form-p form1) 0) + form2))))) + (if otherform + (ppc2-one-targeted-reg-form seg otherform ($ ppc::arg_z)) + (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::arg_z))) + (let* ((out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ ppc::arg_z) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ ppc::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ ppc::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* out-of-line))))) + (with-imm-target () (b31-reg :natural) + (if otherform + (if true-p + (! eq0->bit31 b31-reg ($ ppc::arg_z)) + (! ne0->bit31 b31-reg ($ ppc::arg_z))) + (ecase cr-bit + (#. ppc::ppc-eq-bit + (if true-p + (! eq->bit31 b31-reg ($ ppc::arg_y) ($ ppc::arg_z)) + (! ne->bit31 b31-reg ($ ppc::arg_y) ($ ppc::arg_z)))) + (#. ppc::ppc-lt-bit + (if true-p + (! lt->bit31 b31-reg ($ ppc::arg_y) ($ ppc::arg_z)) + (! ge->bit31 b31-reg ($ ppc::arg_y) ($ ppc::arg_z)))) + (#. ppc::ppc-gt-bit + (if true-p + (! gt->bit31 b31-reg ($ ppc::arg_y) ($ ppc::arg_z)) + (! le->bit31 b31-reg ($ ppc::arg_y) ($ ppc::arg_z)))))) + (! lowbit->truth ($ ppc::arg_z) b31-reg) + (-> done) + (@ out-of-line) + (if otherform + (ppc2-lri seg ($ ppc::arg_y) 0)) + (let* ((index (arch::builtin-function-name-offset name)) + (idx-subprim (ppc2-builtin-index-subprim index))) + (! call-subprim-2 ($ ppc::arg_z) idx-subprim ($ ppc::arg_y) ($ ppc::arg_z))) + (@ done) + (<- ($ ppc::arg_z)) + (^))))))) + +(defppc2 ppc2-%word-to-int %word-to-int (seg vreg xfer form) + (if (null vreg) + (ppc2-form seg nil xfer form) + (progn + (ensuring-node-target (target vreg) + (! sign-extend-halfword target (ppc2-one-untargeted-reg-form seg form ppc::arg_z))) + (^)))) + +(defppc2 ppc2-multiple-value-list multiple-value-list (seg vreg xfer form) + (ppc2-multiple-value-body seg form) + (! list) + (when vreg + (<- ppc::arg_z)) + (^)) + +(defppc2 ppc2-immform immediate (seg vreg xfer form) + (ppc2-immediate seg vreg xfer form)) + +(defppc2 ppc2-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))) + (ppc2-form seg vreg xfer ea-or-form) + (let* ((cell (ppc2-lookup-var-cell varnode))) + (if (and cell (typep cell 'lcell)) + (if (ppc2-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 ppc2-debug-verbose-bit *ppc2-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 ppc2-debug-verbose-bit *ppc2-debug-mask*) + (format t "~& 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)) + (ppc2-do-lexical-reference seg vreg ea-or-form) + (^))))) + +(defppc2 ppc2-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 (ppc2-one-untargeted-reg-form seg form (if (and (register-spec-p ea) + (or (null vreg) (eq ea vreg))) + ea + ppc::arg_z)))) + (ppc2-do-lexical-setq seg vreg ea valreg)) + (^))) + +(defppc2 ppc2-fixnum fixnum (seg vreg xfer value) + (if (null vreg) + (^) + (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 + (ppc2-absolute-natural seg vreg xfer value) + (if (= class hard-reg-class-crf) + (progn + ;(compiler-bug "Would have clobbered a GPR!") + (ppc2-branch seg (ppc2-cd-true xfer) nil)) + (progn + (ensuring-node-target (target vreg) + (ppc2-absolute-natural seg target nil (ash value *ppc2-target-fixnum-shift*))) + (^))))))) + +(defppc2 ppc2-%ilogbitp %ilogbitp (seg vreg xfer cc bitnum form) + (if (null vreg) + (progn + (ppc2-form seg nil nil bitnum) + (ppc2-form seg vreg xfer form)) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (let* ((fixbit (acode-fixnum-form-p bitnum))) + (if fixbit + (let* ((reg (ppc2-one-untargeted-reg-form seg form ppc::arg_z)) + (ppc-bit (- (1- *ppc2-target-bits-in-word*) (max (min (+ fixbit *ppc2-target-fixnum-shift*) (1- *ppc2-target-bits-in-word*)) *ppc2-target-fixnum-shift*)))) + (with-imm-temps () (bitreg) + (! extract-constant-ppc-bit bitreg reg ppc-bit) + (regspec-crf-gpr-case + (vreg dest) + (progn + (! compare-signed-s16const dest bitreg 0) + (^ cr-bit true-p)) + (progn + (if true-p + (! invert-lowbit bitreg)) + (ensuring-node-target (target dest) + (! lowbit->truth target bitreg)) + (^))))) + (multiple-value-bind (rbit rform) (ppc2-two-untargeted-reg-forms seg bitnum ppc::arg_y form ppc::arg_z) + (with-imm-temps () (bitreg) + (! extract-variable-non-insane-bit bitreg rform rbit) + (regspec-crf-gpr-case + (vreg dest) + (progn + (! compare-signed-s16const dest bitreg 0) + (^ cr-bit true-p)) + (progn + (if true-p + (! invert-lowbit bitreg)) + (ensuring-node-target (target dest) + (! lowbit->truth target bitreg)) + (^)))))))))) + +(defppc2 ppc2-uvref uvref (seg vreg xfer vector index) + (ppc2-two-targeted-reg-forms seg vector ($ ppc::arg_y) index ($ ppc::arg_z)) + (! misc-ref) + (<- ($ ppc::arg_z)) + (^)) + +(defppc2 ppc2-uvset uvset (seg vreg xfer vector index value) + (ppc2-three-targeted-reg-forms seg vector ($ ppc::arg_x) index ($ ppc::arg_y) value ($ ppc::arg_z)) + (! misc-set) + (<- ($ ppc::arg_z)) + (^)) + +(defppc2 ppc2-%decls-body %decls-body (seg vreg xfer form p2decls) + (with-ppc-p2-declarations p2decls + (ppc2-form seg vreg xfer form))) + + + +(defppc2 ppc2-%err-disp %err-disp (seg vreg xfer arglist) + (ppc2-set-nargs seg (ppc2-arglist seg arglist)) + (! ksignalerr) + (ppc2-nil seg vreg xfer)) + + +(defppc2 ppc2-local-tagbody local-tagbody (seg vreg xfer taglist body) + (let* ((encstack (ppc2-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))) + (@ (car tag))) + (ppc2-form seg nil nil form))) + (ppc2-nil seg vreg xfer))) + +(defppc2 ppc2-call call (seg vreg xfer fn arglist &optional spread-p) + (ppc2-call-fn seg vreg xfer fn arglist spread-p)) + +(defppc2 ppc2-self-call self-call (seg vreg xfer arglist &optional spread-p) + (setq arglist (ppc2-augment-arglist *ppc2-cur-afunc* arglist (if spread-p 1 $numppcargregs))) + (ppc2-call-fn seg vreg xfer -1 arglist spread-p)) + + +(defppc2 ppc2-lexical-function-call lexical-function-call (seg vreg xfer afunc arglist &optional spread-p) + (ppc2-call-fn seg vreg xfer (list (%nx1-operator simple-function) afunc) + (ppc2-augment-arglist afunc arglist (if spread-p 1 $numppcargregs)) + spread-p)) + +(defppc2 ppc2-builtin-call builtin-call (seg vreg xfer index arglist) + (let* ((nargs (ppc2-arglist seg arglist)) + (tail-p (and (ppc2-tailcallok xfer) (<= nargs $numppcargregs))) + (idx (acode-fixnum-form-p index)) + (idx-subprim (ppc2-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 + (ppc2-restore-nvrs seg *ppc2-register-restore-ea* *ppc2-register-restore-count*) + (ppc2-restore-full-lisp-context seg)) + (unless idx-subprim + (! lri ppc::imm0 (ash idx *ppc2-target-fixnum-shift*)) + (when (eql subprim (subprim-name->offset '.SPcallbuiltin)) + (ppc2-set-nargs seg nargs))) + (if tail-p + (! jump-subprim subprim) + (progn + (! call-subprim subprim) + (<- ppc::arg_z) + (^))))) + + +(defppc2 ppc2-if if (seg vreg xfer testform true false) + (if (nx-constant-form-p (acode-unwrapped-form testform)) + (ppc2-form seg vreg xfer (if (nx-null (acode-unwrapped-form testform)) false true)) + (let* ((cstack *ppc2-cstack*) + (vstack *ppc2-vstack*) + (top-lcell *ppc2-top-vstack-lcell*) + (entry-stack (ppc2-encode-stack)) + (true-stack nil) + (false-stack nil) + (true-cleanup-label nil) + (same-stack-effects nil) + (true-is-goto (ppc2-go-label true)) + (false-is-goto (and (not true-is-goto) (ppc2-go-label false))) + (endlabel (backend-get-next-label)) + (falselabel (backend-get-next-label)) + (need-else (unless false-is-goto (or (not (nx-null false)) (ppc2-for-value-p vreg)))) + (both-single-valued (and (not *ppc2-open-code-inline*) + (eq xfer $backend-return) + (ppc2-for-value-p vreg) + need-else + (ppc2-single-valued-form-p true) + (ppc2-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 ppc::arg_z)) + (let ((merge-else-branch-label (if (nx-null false) (ppc2-find-nilret-label)))) + (ppc2-conditional-form seg (ppc2-make-compound-cd 0 falselabel) testform) + (ppc2-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) (@ (ppc2-record-nilret-label))) + (ppc2-form seg result nil false))) + (@ endlabel) + (<- result) + (^))) + (progn + (if (and need-else (ppc2-mvpass-p xfer)) + (setq true-cleanup-label (backend-get-next-label))) + (ppc2-conditional-form + seg + (ppc2-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 (ppc2-cd-merge xfer falselabel))))) + testform) + (if true-is-goto + (ppc2-unreachable-store) + (if true-cleanup-label + (progn + (ppc2-open-undo $undomvexpect) + (ppc2-form seg vreg (logior $backend-mvpass-mask true-cleanup-label) true)) + (ppc2-form seg vreg (if need-else (ppc2-cd-merge xfer endlabel) xfer) true))) + (setq true-stack (ppc2-encode-stack)) + (setq *ppc2-cstack* cstack) + (ppc2-set-vstack vstack) + (setq *ppc2-top-vstack-lcell* top-lcell) + (if false-is-goto (ppc2-unreachable-store)) + (let ((merge-else-branch-label (if (and (nx-null false) (eq xfer $backend-return)) (ppc2-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 + (ppc2-mvpass seg false) + (ppc2-form seg vreg xfer false)) + (setq false-stack (ppc2-encode-stack)))))) + (when true-cleanup-label + (if (setq same-stack-effects (ppc2-equal-encodings-p true-stack false-stack)) ; can share cleanup code + (@ true-cleanup-label)) + (let* ((*ppc2-returning-values* :pass)) + (ppc2-nlexit seg xfer 1) + (ppc2-branch seg (if (and xfer (neq xfer $backend-mvpass-mask)) xfer (if (not same-stack-effects) endlabel)) vreg)) + (unless same-stack-effects + (@ true-cleanup-label) + (multiple-value-setq (true *ppc2-cstack* *ppc2-vstack* *ppc2-top-vstack-lcell*) + (ppc2-decode-stack true-stack)) + (let* ((*ppc2-returning-values* :pass)) + (ppc2-nlexit seg xfer 1) + (^))) + (ppc2-close-undo) + (multiple-value-setq (*ppc2-undo-count* *ppc2-cstack* *ppc2-vstack* *ppc2-top-vstack-lcell*) + (ppc2-decode-stack entry-stack))) + (@ endlabel)))))) + +(defppc2 ppc2-or or (seg vreg xfer forms) + (let* ((mvpass (ppc2-mvpass-p xfer)) + (tag1 (backend-get-next-label)) + (tag2 (backend-get-next-label)) + (vstack *ppc2-vstack*) + (cstack *ppc2-cstack*) + (dest (if (backend-crf-p vreg) vreg (if vreg ppc::arg_z (available-crf-temp *available-backend-crf-temps*)))) + (cd1 (ppc2-make-compound-cd + (if (eq dest ppc::arg_z) tag1 (ppc2-cd-merge (ppc2-cd-true xfer) tag1)) 0))) + (while (cdr forms) + (ppc2-form seg dest (if (eq dest ppc::arg_z) nil cd1) (car forms)) + (when (eq dest ppc::arg_z) + (with-crf-target () val-crf + (ppc2-copy-register seg val-crf dest) + (ppc2-branch seg cd1 val-crf))) + (setq forms (%cdr forms))) + (if mvpass + (progn (ppc2-multiple-value-body seg (car forms)) + (let* ((*ppc2-returning-values* t)) (ppc2-branch seg (ppc2-cd-merge xfer tag2) vreg))) + (ppc2-form seg vreg (if (eq dest ppc::arg_z) (ppc2-cd-merge xfer tag2) xfer) (car forms))) + (setq *ppc2-vstack* vstack *ppc2-cstack* cstack) + (@ tag1) + (when (eq dest ppc::arg_z) + (<- ppc::arg_z) + (^)) + (@ tag2))) + +(defppc2 ppc2-simple-function simple-function (seg vreg xfer afunc) + (ppc2-immediate seg vreg xfer (ppc2-afunc-lfun-ref afunc))) + +(defppc2 ppc2-list list (seg vreg xfer arglist) + (if (null vreg) + (dolist (form arglist) + (ppc2-form seg vreg nil form)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (nargs (ppc2-formlist seg arglist nil))) + (ppc2-set-nargs seg nargs) + (! list) + (<- ppc::arg_z))) + (^)) + +(defppc2 ppc2-list* list* (seg vreg xfer arglist) + (if (null vreg) + (dolist (arg (apply #'append arglist)) + (ppc2-form seg nil nil arg)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (nargs (ppc2-arglist seg arglist))) + (declare (fixnum args)) + (when (> nargs 1) + (ppc2-set-nargs seg (1- nargs)) + (! list*)) + (<- ppc::arg_z))) + (^)) + +(defppc2 ppc2-minus1 minus1 (seg vreg xfer form) + (ppc2-unary-builtin seg vreg xfer '%negate form)) + +(defun ppc2-inline-add2 (seg vreg xfer form1 form2) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::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 ($ ppc::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ ppc::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* out-of-line)))) + (if *ppc2-open-code-inline* + (! fixnum-add-overflow-inline-skip ($ ppc::arg_z) ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* done)) + (progn + (! fixnum-add-overflow-ool ($ ppc::arg_y) ($ ppc::arg_z)) + (-> done))) + (@ out-of-line) + (! call-subprim-2 ($ ppc::arg_z) (subprim-name->offset '.SPbuiltin-plus) ($ ppc::arg_y) ($ ppc::arg_z)) + (@ done) + (ppc2-copy-register seg target ($ ppc::arg_z))) + (^)))) + +(defun ppc2-inline-sub2 (seg vreg xfer form1 form2) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::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 ($ ppc::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ ppc::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* out-of-line)))) + (if *ppc2-open-code-inline* + (! fixnum-sub-overflow-inline-skip ($ ppc::arg_z) ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* done)) + (progn + (! fixnum-sub-overflow-ool ($ ppc::arg_y) ($ ppc::arg_z)) + (-> done))) + (@ out-of-line) + (! call-subprim-2 ($ ppc::arg_z) (subprim-name->offset '.SPbuiltin-minus) ($ ppc::arg_y) ($ ppc::arg_z)) + (@ done) + (ppc2-copy-register seg target ($ ppc::arg_z))) + (^)))) + +;;; Return T if form is declared to be something that couldn't be a fixnum. +(defun ppc2-explicit-non-fixnum-type-p (form) + (let* ((type (ppc2-form-type form)) + (target-fixnum-type (nx-target-type 'fixnum))) + (and (not (subtypep type target-fixnum-type)) + (not (subtypep target-fixnum-type type))))) + + + + +(defppc2 ppc2-add2 add2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *ppc2-trust-declarations*) + (if (and (ppc2-form-typep form1 'double-float) + (ppc2-form-typep form2 'double-float)) + (ppc2-use-operator (%nx1-operator %double-float+-2) + seg + vreg + xfer + form1 + form2) + (if (and (ppc2-form-typep form1 'single-float) + (ppc2-form-typep form2 'single-float)) + (ppc2-use-operator (%nx1-operator %short-float+-2) + seg + vreg + xfer + form1 + form2) + (if (and (ppc2-form-typep form1 'fixnum) + (ppc2-form-typep form2 'fixnum)) + (ppc2-use-operator (%nx1-operator %i+) + seg + vreg + xfer + form1 + form2 + t) + (if (or (ppc2-explicit-non-fixnum-type-p form1) + (ppc2-explicit-non-fixnum-type-p form2)) + (ppc2-binary-builtin seg vreg xfer '+-2 form1 form2) + (ppc2-inline-add2 seg vreg xfer form1 form2))))))) + +(defppc2 ppc2-sub2 sub2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *ppc2-trust-declarations*) + (if (and (ppc2-form-typep form1 'double-float) + (ppc2-form-typep form2 'double-float)) + (ppc2-use-operator (%nx1-operator %double-float--2) + seg + vreg + xfer + form1 + form2) + (if (and (ppc2-form-typep form1 'single-float) + (ppc2-form-typep form2 'single-float)) + (ppc2-use-operator (%nx1-operator %short-float--2) + seg + vreg + xfer + form1 + form2) + (if (and (ppc2-form-typep form1 'fixnum) + (ppc2-form-typep form2 'fixnum)) + (ppc2-use-operator (%nx1-operator %i-) + seg + vreg + xfer + form1 + form2 + t) + (if (or (ppc2-explicit-non-fixnum-type-p form1) + (ppc2-explicit-non-fixnum-type-p form2)) + (ppc2-binary-builtin seg vreg xfer '--2 form1 form2) + (ppc2-inline-sub2 seg vreg xfer form1 form2))))))) + +(defppc2 ppc2-mul2 mul2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *ppc2-trust-declarations*) + (if (and (ppc2-form-typep form1 'double-float) + (ppc2-form-typep form2 'double-float)) + (ppc2-use-operator (%nx1-operator %double-float*-2) + seg + vreg + xfer + form1 + form2) + (if (and (ppc2-form-typep form1 'single-float) + (ppc2-form-typep form2 'single-float)) + (ppc2-use-operator (%nx1-operator %short-float*-2) + seg + vreg + xfer + form1 + form2) + (ppc2-binary-builtin seg vreg xfer '*-2 form1 form2))))) + + +(defppc2 ppc2-div2 div2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *ppc2-trust-declarations*) + (if (and (ppc2-form-typep form1 'double-float) + (ppc2-form-typep form2 'double-float)) + (ppc2-use-operator (%nx1-operator %double-float/-2) + seg + vreg + xfer + form1 + form2) + (if (and (ppc2-form-typep form1 'single-float) + (ppc2-form-typep form2 'single-float)) + (ppc2-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)) + (ppc2-use-operator (%nx1-operator mul2) + seg + vreg + xfer + (make-acode (%nx1-operator fixnum) f1/f2) + (caddr unwrapped)) + (ppc2-binary-builtin seg vreg xfer '/-2 form1 form2))))))) + +(defppc2 ppc2-logbitp logbitp (seg vreg xfer bitnum int) + (ppc2-binary-builtin seg vreg xfer 'logbitp bitnum int)) + + +(defun ppc2-inline-logior2 (seg vreg xfer form1 form2) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (logior fix1 fix2)) + (let* ((fixval (or fix1 fix2)) + (unboxed-fixval (if fixval (ash fixval *ppc2-target-fixnum-shift*))) + (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) + (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) + (otherform (if (or high low) (if fix1 form2 form1))) + (out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + + (if otherform + (ppc2-one-targeted-reg-form seg otherform ($ ppc::arg_z)) + (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::arg_z))) + (ensuring-node-target (target vreg) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ ppc::arg_z) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ ppc::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ ppc::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* out-of-line))))) + (if otherform + (if high + (! logior-high ($ ppc::arg_z) ($ ppc::arg_z) high) + (! logior-low ($ ppc::arg_z) ($ ppc::arg_z) low)) + (! %logior2 ($ ppc::arg_z) ($ ppc::arg_z) ($ ppc::arg_y))) + (-> done) + (@ out-of-line) + (if otherform + (ppc2-lri seg ($ ppc::arg_y) (ash fixval *ppc2-target-fixnum-shift*))) + (! call-subprim-2 ($ ppc::arg_z) (subprim-name->offset '.SPbuiltin-logior) ($ ppc::arg_y) ($ ppc::arg_z)) + (@ done) + (ppc2-copy-register seg target ($ ppc::arg_z))) + (^)))))) + +(defppc2 ppc2-logior2 logior2 (seg vreg xfer form1 form2) + (if (or (ppc2-explicit-non-fixnum-type-p form1) + (ppc2-explicit-non-fixnum-type-p form2)) + (ppc2-binary-builtin seg vreg xfer 'logior-2 form1 form2) + (ppc2-inline-logior2 seg vreg xfer form1 form2))) + +(defppc2 ppc2-logxor2 logxor2 (seg vreg xfer form1 form2) + (ppc2-binary-builtin seg vreg xfer 'logxor-2 form1 form2)) + +(defun ppc2-inline-logand2 (seg vreg xfer form1 form2) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (logand fix1 fix2)) + (let* ((fixval (or fix1 fix2)) + (fixlen (if fixval (integer-length fixval))) + (unboxed-fixval (if fixval (ash fixval *ppc2-target-fixnum-shift*))) + (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) + (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) + (maskable (and fixval (= fixlen (logcount fixval)))) + (otherform (if (or high low maskable) (if fix1 form2 form1))) + (out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (if otherform + (ppc2-one-targeted-reg-form seg otherform ($ ppc::arg_z)) + (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::arg_z))) + (ensuring-node-target (target vreg) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ ppc::arg_z) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ ppc::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ ppc::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ ppc::arg_y) ($ ppc::arg_z) (aref *backend-labels* out-of-line))))) + (if otherform + (if (or high low) + (if high + (! logand-high ($ ppc::arg_z) ($ ppc::arg_z) high) + (! logand-low ($ ppc::arg_z) ($ ppc::arg_z) low)) + (let* ((nbits (- *ppc2-target-bits-in-word* + (1+ (+ *ppc2-target-fixnum-shift* fixlen))))) + (if (> fixval 0) + (! clear-left ($ ppc::arg_z) ($ ppc::arg_z) nbits) + (! clear-right ($ ppc::arg_z) ($ ppc::arg_z) (+ fixlen + *ppc2-target-fixnum-shift*))))) + (! %logand2 ($ ppc::arg_z) ($ ppc::arg_z) ($ ppc::arg_y))) + (-> done) + (@ out-of-line) + (if otherform + (ppc2-lri seg ($ ppc::arg_y) (ash fixval *ppc2-target-fixnum-shift*))) + (! call-subprim-2 ($ ppc::arg_z) (subprim-name->offset '.SPbuiltin-logand) ($ ppc::arg_y) ($ ppc::arg_z)) + (@ done) + (ppc2-copy-register seg target ($ ppc::arg_z))) + (^)))))) + +(defppc2 ppc2-logand2 logand2 (seg vreg xfer form1 form2) + (if (or (ppc2-explicit-non-fixnum-type-p form1) + (ppc2-explicit-non-fixnum-type-p form2)) + (ppc2-binary-builtin seg vreg xfer 'logand-2 form1 form2) + (ppc2-inline-logand2 seg vreg xfer form1 form2))) + + + +(defppc2 ppc2-%aref1 %aref1 (seg vreg xfer v i) + (let* ((vtype (acode-form-type v t)) + (atype (if vtype (specifier-type vtype))) + (keyword (if (and atype + (not (array-ctype-complexp atype))) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (if keyword + (ppc2-vref seg vreg xfer keyword v i (not *ppc2-reckless*)) + (ppc2-binary-builtin seg vreg xfer '%aref1 v i)))) + +(defppc2 ppc2-%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 + (not (array-ctype-complexp atype))) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (if keyword + (ppc2-vset seg vreg xfer keyword v i n (not *ppc2-reckless*)) + (ppc2-ternary-builtin seg vreg xfer '%aset1 v i n)))) + +(defppc2 ppc2-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow) + (when overflow + (let* ((type *ppc2-target-half-fixnum-type*)) + (when (and (ppc2-form-typep form1 type) + (ppc2-form-typep form2 type)) + (setq overflow nil)))) + (cond ((null vreg) + (ppc2-form seg nil nil form1) + (ppc2-form seg nil xfer form2)) + (overflow + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z) + (ensuring-node-target (target vreg) + (if *ppc2-open-code-inline* + (! fixnum-add-overflow-inline target r1 r2) + (progn + (! fixnum-add-overflow-ool r1 r2) + (ppc2-copy-register seg target ($ ppc::arg_z))))) + (^))) + (t + ;; There isn't any "addi" that checks for overflow, which is + ;; why we didn't bother. + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2)) + (other (if (and fix1 + (typep (ash fix1 *ppc2-target-fixnum-shift*) + '(signed-byte 32))) + form2 + (if (and fix2 + (typep (ash fix2 *ppc2-target-fixnum-shift*) + '(signed-byte 32))) + form1)))) + (if (and fix1 fix2) + (ppc2-lri seg vreg (ash (+ fix1 fix2) *ppc2-target-fixnum-shift*)) + (if other + (let* ((constant (ash (or fix1 fix2) *ppc2-target-fixnum-shift*)) + (reg (ppc2-one-untargeted-reg-form seg other ppc::arg_z)) + (high (ldb (byte 16 16) constant)) + (low (ldb (byte 16 0) constant))) + (declare (fixnum high low)) + (if (zerop constant) + (<- reg) + (progn + (if (logbitp 15 low) (setq high (ldb (byte 16 0) (1+ high)))) + (if (and (eq vreg reg) (not (zerop high))) + (with-node-temps (vreg) (temp) + (! add-immediate temp reg high low) + (<- temp)) + (ensuring-node-target (target vreg) + (! add-immediate target reg high low)))))) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z) + (ensuring-node-target (target vreg) + (! fixnum-add target r1 r2))))) + (^))))) + +(defppc2 ppc2-%i- %i- (seg vreg xfer num1 num2 &optional overflow) + (when overflow + (let* ((type *ppc2-target-half-fixnum-type*)) + (when (and (ppc2-form-typep num1 type) + (ppc2-form-typep num2 type)) + (setq overflow nil)))) + (let* ((v1 (acode-fixnum-form-p num1)) + (v2 (acode-fixnum-form-p num2))) + (if (and v1 v2) + (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (%i- v1 v2)) + (if (and v2 (neq v2 most-negative-fixnum)) + (ppc2-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow) + (if (eq v2 0) + (ppc2-form seg vreg xfer num1) + (cond + ((null vreg) + (ppc2-form seg nil nil num1) + (ppc2-form seg nil xfer num2)) + (overflow + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z) + (ensuring-node-target (target vreg) + (if *ppc2-open-code-inline* + (! fixnum-sub-overflow-inline target r1 r2) + (progn + (! fixnum-sub-overflow-ool r1 r2) + (ppc2-copy-register seg target ($ ppc::arg_z))))) + (^))) + ((and v1 (<= (integer-length v1) (- 15 *ppc2-target-fixnum-shift*))) + (ensuring-node-target (target vreg) + (! fixnum-sub-from-constant target v1 (ppc2-one-untargeted-reg-form seg num2 ppc::arg_z))) + (^)) + (t + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z) + (ensuring-node-target (target vreg) + (! fixnum-sub target r1 r2)) + (^))))))))) + +(defppc2 ppc2-%i* %i* (seg vreg xfer num1 num2) + (if (null vreg) + (progn + (ppc2-form seg nil nil num1) + (ppc2-form seg nil xfer num2)) + (let* ((fix1 (acode-fixnum-form-p num1)) + (fix2 (acode-fixnum-form-p num2)) + (other (if (typep fix1 '(signed-byte 16)) num2 (if (typep fix2 '(signed-byte 16)) num1)))) + (if (and fix1 fix2) + (ppc2-lri seg vreg (ash (* fix1 fix2) *ppc2-target-fixnum-shift*)) + (if other + (! multiply-immediate vreg (ppc2-one-untargeted-reg-form seg other ppc::arg_z) (or fix1 fix2)) + (multiple-value-bind (rx ry) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z) + (ensuring-node-target (target vreg) + (! multiply-fixnums target rx ry))))) + (^)))) + +(defppc2 ppc2-nth-value nth-value (seg vreg xfer n form) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (let* ((nreg (ppc2-one-untargeted-reg-form seg n ppc::arg_z))) + (unless (acode-fixnum-form-p n) + (! trap-unless-fixnum nreg)) + (ppc2-vpush-register seg nreg)) + (ppc2-multiple-value-body seg form) ; sets nargs + (! nth-value ppc::arg_z)) + (<- ppc::arg_z) + (^)) + +(defppc2 ppc2-values values (seg vreg xfer forms) + (if (eq (list-length forms) 1) + (if (ppc2-cd-compound-p xfer) + (ppc2-form seg vreg xfer (%car forms)) + (progn + (ppc2-form seg vreg nil (%car forms)) + (^))) + (if (not (ppc2-mv-p xfer)) + (if forms + (ppc2-use-operator (%nx1-operator prog1) seg vreg xfer forms) + (ppc2-nil seg vreg xfer)) + (progn + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-set-nargs seg (ppc2-formlist seg forms nil))) + (let* ((*ppc2-returning-values* t)) + (^)))))) + +(defppc2 ppc2-base-char-p base-char-p (seg vreg xfer cc form) + (ppc2-char-p seg vreg xfer cc form)) + +(defun ppc2-char-p (seg vreg xfer cc form) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (! mask-base-char ppc::imm0 (ppc2-one-untargeted-reg-form seg form ppc::arg_z)) + (ppc2-test-reg-%izerop seg vreg xfer ppc::imm0 cr-bit true-p + (target-arch-case + (:ppc32 ppc32::subtag-character) + (:ppc64 ppc64::subtag-character)))))) + + +(defppc2 ppc2-let* let* (seg vreg xfer vars vals body p2decls &aux + (old-stack (ppc2-encode-stack))) + (ppc2-check-lcell-depth) + (with-ppc-p2-declarations p2decls + (ppc2-seq-bind seg vars vals) + (ppc2-undo-body seg vreg xfer body old-stack)) + (dolist (v vars) (ppc2-close-var seg v))) + +(defppc2 ppc2-multiple-value-bind multiple-value-bind (seg vreg xfer vars valform body p2decls) + (let* ((n (list-length vars)) + (vloc *ppc2-vstack*) + (nbytes (* n *ppc2-target-node-size*)) + (old-stack (ppc2-encode-stack))) + (with-ppc-p2-declarations p2decls + (ppc2-multiple-value-body seg valform) + (ppc2-lri seg ppc::imm0 nbytes) + (! fitvals) + (ppc2-set-vstack (%i+ vloc nbytes)) + (let* ((old-top *ppc2-top-vstack-lcell*) + (lcells (progn (ppc2-reserve-vstack-lcells n) (ppc2-collect-lcells :reserved old-top)))) + (dolist (var vars) + (let* ((lcell (pop lcells)) + (reg (ppc2-assign-register-var var))) + (if reg + (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) + (ppc2-bind-var seg var vloc lcell)) + (setq vloc (%i+ vloc *ppc2-target-node-size*))))) + (ppc2-undo-body seg vreg xfer body old-stack) + (dolist (var vars) + (ppc2-close-var seg var))))) + +(defppc2 ppc2-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 (ppc2-encode-stack)) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (vloc *ppc2-vstack*)) + (with-ppc-p2-declarations p2decls + (ppc2-bind-structured-lambda + seg + (ppc2-spread-lambda-list seg bindform whole req opt rest keys nil cdr-p) + vloc (ppc2-vloc-ea vloc) whole req opt rest keys auxen) + (ppc2-undo-body seg vreg xfer body old-stack) + (ppc2-close-structured-lambda seg whole req opt rest keys auxen)))) + +(defppc2 ppc2-multiple-value-prog1 multiple-value-prog1 (seg vreg xfer forms) + (if (or (not (ppc2-mv-p xfer)) (ppc2-single-valued-form-p (%car forms))) + (ppc2-use-operator (%nx1-operator prog1) seg vreg xfer forms) + (if (null (cdr forms)) + (ppc2-form seg vreg xfer(car forms)) + (progn + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-multiple-value-body seg (%car forms)) + (ppc2-open-undo $undostkblk) + (! save-values)) + (dolist (form (cdr forms)) + (ppc2-form seg nil nil form)) + (ppc2-set-nargs seg 0) + (! recover-values) + (ppc2-close-undo) + (let* ((*ppc2-returning-values* t)) + (^)))))) + +(defppc2 ppc2-not not (seg vreg xfer cc form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-compare-register-to-nil + seg + vreg + xfer + (ppc2-one-untargeted-reg-form seg form ppc::arg_z) + cr-bit + true-p))) + + +(defppc2 ppc2-%alloc-misc %make-uvector (seg vreg xfer element-count st &optional initval) + (if (null vreg) + (progn + (ppc2-form seg nil nil element-count) + (ppc2-form seg nil xfer st)) + (let* ((subtag (acode-fixnum-form-p st)) + (nelements (acode-fixnum-form-p element-count)) + (nbytes (if (and subtag nelements) (ppc2-misc-byte-count subtag nelements)))) + (if (and nbytes (null initval) + (< (logand + (lognot (1- (* 2 *ppc2-target-node-size*))) + (+ nbytes *ppc2-target-node-size* + (1- (* 2 *ppc2-target-node-size*)))) #x8000)) + (with-imm-temps () (header) + (ppc2-lri seg header (arch::make-vheader nelements subtag)) + (ensuring-node-target (target vreg) + (! %alloc-misc-fixed target header nbytes))) + (progn + (if initval + (progn + (ppc2-three-targeted-reg-forms seg element-count ($ ppc::arg_x) st ($ ppc::arg_y) initval ($ ppc::arg_z)) + (! misc-alloc-init) + (<- ($ ppc::arg_z))) + (progn + (ppc2-two-targeted-reg-forms seg element-count ($ ppc::arg_y) st ($ ppc::arg_z)) + (! misc-alloc) + (<- ($ ppc::arg_z)))))) + (^)))) + +(defppc2 ppc2-%iasr %iasr (seg vreg xfer form1 form2) + (if (null vreg) + (progn + (ppc2-form seg nil nil form1) + (ppc2-form seg vreg xfer form2)) + (let* ((count (acode-fixnum-form-p form1)) + (max (target-arch-case (:ppc32 31) (:ppc64 63)))) + (declare (fixnum max)) + (ensuring-node-target (target vreg) + (if count + (! %iasr-c target (if (> count max) max count) + (ppc2-one-untargeted-reg-form seg form2 ppc::arg_z)) + (multiple-value-bind (cnt src) (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::arg_z)) + (! %iasr target cnt src)))) + (^)))) + +(defppc2 ppc2-%ilsr %ilsr (seg vreg xfer form1 form2) + (if (null vreg) + (progn + (ppc2-form seg nil nil form1) + (ppc2-form seg vreg xfer form2)) + (let* ((count (acode-fixnum-form-p form1))) + (ensuring-node-target (target vreg) + (if count + (let ((src (ppc2-one-untargeted-reg-form seg form2 ($ ppc::arg_z)))) + (if (<= count 31) + (! %ilsr-c target count src) + (! lri target 0))) + (multiple-value-bind (cnt src) (ppc2-two-targeted-reg-forms seg form1 ($ ppc::arg_y) form2 ($ ppc::arg_z)) + (! %ilsr target cnt src)))) + (^)))) + + +(defppc2 ppc2-%i<> %i<> (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-compare seg vreg xfer form1 form2 cr-bit true-p))) + +(defppc2 ppc2-%natural<> %natural<> (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-natural-compare seg vreg xfer form1 form2 cr-bit true-p))) + +(defppc2 ppc2-double-float-compare double-float-compare (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (with-fp-target () (r1 :double-float) + (with-fp-target (r1) (r2 :double-float) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 r1 form2 r2) + (ppc2-compare-double-float-registers seg vreg xfer r1 r2 cr-bit true-p)))))) + +(defppc2 ppc2-short-float-compare short-float-compare (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (with-fp-target () (r1 :single-float) + (with-fp-target (r1) (r2 :single-float) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 r1 form2 r2) + (ppc2-compare-double-float-registers seg vreg xfer r1 r2 cr-bit true-p)))))) + +(eval-when (:compile-toplevel :execute) + (defmacro defppc2-df-op (fname opname vinsn) + `(defppc2 ,fname ,opname (seg vreg xfer f0 f1) + (if (null vreg) + (progn + (ppc2-form seg nil nil f0) + (ppc2-form seg vreg xfer f1)) + (with-fp-target () (r1 :double-float) + (with-fp-target (r1) (r2 :double-float) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg f0 r1 f1 r2) + (if (= (hard-regspec-class vreg) hard-reg-class-fpr) + (! ,vinsn vreg r1 r2) + (with-fp-target (r1 r2) (result :double-float) + (! ,vinsn result r1 r2) + (ensuring-node-target (target vreg) + (ppc2-copy-register seg target result)))) + (^))))))) + + (defmacro defppc2-sf-op (fname opname vinsn) + `(defppc2 ,fname ,opname (seg vreg xfer f0 f1) + (if (null vreg) + (progn + (ppc2-form seg nil nil f0) + (ppc2-form seg vreg xfer f1)) + (with-fp-target () (r1 :single-float) + (with-fp-target (r1) (r2 :single-float) + (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg f0 r1 f1 r2) + (if (= (hard-regspec-class vreg) hard-reg-class-fpr) + (! ,vinsn vreg r1 r2) + (with-fp-target (r1 r2) (result :single-float) + (! ,vinsn result r1 r2) + (ensuring-node-target (target vreg) + (ppc2-copy-register seg target result)))) + (^))))))) +) + +(defppc2-df-op ppc2-%double-float+-2 %double-float+-2 double-float+-2) +(defppc2-df-op ppc2-%double-float--2 %double-float--2 double-float--2) +(defppc2-df-op ppc2-%double-float*-2 %double-float*-2 double-float*-2) +(defppc2-df-op ppc2-%double-float/-2 %double-float/-2 double-float/-2) + +(defppc2-sf-op ppc2-%short-float+-2 %short-float+-2 single-float+-2) +(defppc2-sf-op ppc2-%short-float--2 %short-float--2 single-float--2) +(defppc2-sf-op ppc2-%short-float*-2 %short-float*-2 single-float*-2) +(defppc2-sf-op ppc2-%short-float/-2 %short-float/-2 single-float/-2) + +(defun ppc2-get-float (seg vreg xfer ptr offset double-p fp-reg) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (cond ((null vreg) + (ppc2-form seg nil nil ptr) + (ppc2-form seg nil xfer offset)) + (t + (let* ((fixoffset (acode-fixnum-form-p offset))) + (if (typep fixoffset '(unsigned-byte 15)) + (with-imm-target () (ptrreg :address) + (ppc2-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-imm-target (ptrreg) (offsetreg :s32) + (ppc2-two-targeted-reg-forms seg + ptr ptrreg + offset ($ ppc::arg_z)) + (! fixnum->signed-natural offsetreg ppc::arg_z) + (if double-p + (! mem-ref-double-float fp-reg ptrreg offsetreg) + (! mem-ref-single-float fp-reg ptrreg offsetreg))))) + (<- fp-reg)) + (^))))) + + +(defppc2 ppc2-%get-double-float %get-double-float (seg vreg xfer ptr offset) + (with-fp-target () (fp-reg :double-float) + (ppc2-get-float seg vreg xfer ptr offset t fp-reg))) + +(defppc2 ppc2-%get-single-float %get-single-float (seg vreg xfer ptr offset) + (with-fp-target () (fp-reg :single-float) + (ppc2-get-float seg vreg xfer ptr offset nil fp-reg))) + +(defun ppc2-set-float (seg vreg xfer ptr offset newval double-p fp-reg) + (with-ppc-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 + (ppc2-push-register + seg + (ppc2-one-untargeted-reg-form seg + ptr + ptr-reg)) + (ppc2-one-targeted-reg-form seg newval fp-reg) + (ppc2-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-imm-target (ptr-reg) (offset-reg :s32) + (ppc2-push-register + seg + (ppc2-one-untargeted-reg-form seg + ptr + ptr-reg)) + (ppc2-push-register + seg + (ppc2-one-untargeted-reg-form seg + offset + ppc::arg_z)) + (ppc2-one-targeted-reg-form seg newval fp-reg) + (ppc2-pop-register seg ppc::arg_z) + (ppc2-pop-register seg ptr-reg) + (! fixnum->signed-natural offset-reg ppc::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 ($ ppc::arg_z))) + (ppc2-push-register + seg + (ppc2-one-untargeted-reg-form seg + ptr + ptr-reg)) + (ppc2-one-targeted-reg-form seg newval rnew) + (ppc2-pop-register seg ptr-reg) + (with-imm-temps (ptr-reg) () + (ppc2-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 ($ ppc::arg_y)) + (rnew ($ ppc::arg_z))) + (ppc2-push-register + seg + (ppc2-one-untargeted-reg-form + seg + ptr ptr-reg)) + (ppc2-two-targeted-reg-forms seg + offset roffset + newval rnew) + (ppc2-pop-register seg ptr-reg) + (with-imm-target (ptr-reg) (offset-reg :s32) + (with-imm-temps (ptr-reg offset-reg) () + (! fixnum->signed-natural offset-reg roffset) + (ppc2-copy-register seg fp-reg rnew)) + (if double-p + (! mem-set-double-float fp-reg ptr-reg offset-reg) + (! mem-set-single-float fp-reg ptr-reg offset-reg)))))) + (<- ppc::arg_z))) + (^))))) + +(defppc2 ppc2-%set-double-float %set-double-float (seg vreg xfer ptr offset newval) + (with-fp-target () (fp-reg :double-float) + (ppc2-set-float seg vreg xfer ptr offset newval t fp-reg))) + +(defppc2 ppc2-%set-single-float %set-single-float (seg vreg xfer ptr offset newval) + (with-fp-target () (fp-reg :single-float) + (ppc2-set-float seg vreg xfer ptr offset newval nil fp-reg))) + +(defppc2 ppc2-immediate-get-ptr immediate-get-ptr (seg vreg xfer ptr offset) + (let* ((absptr (acode-absolute-ptr-p ptr)) + (triv-p (ppc2-trivial-p offset)) + (dest vreg) + (offval (acode-fixnum-form-p offset))) + (cond ((not vreg) + (ppc2-form seg nil nil ptr) + (ppc2-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) 15) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 15) (setq absptr nil)) + (target-arch-case + (:ppc32 (progn)) + (:ppc64 (progn + (and offval (logtest 3 offval) (setq offval nil)) + (and absptr (logtest 3 absptr) (setq absptr nil))))) + (if absptr + (! mem-ref-c-natural dest ppc::rzero absptr) + (if offval + (let* ((src (ppc2-macptr-arg-to-reg seg ptr ($ ppc::imm0 :mode :address)))) + (! mem-ref-c-natural dest src offval)) + (let* ((src (ppc2-macptr-arg-to-reg seg ptr ($ ppc::imm0 :mode :address)))) + (if triv-p + (with-imm-temps (src) (x) + (if (acode-fixnum-form-p offset) + (ppc2-lri seg x (acode-fixnum-form-p offset)) + (! fixnum->signed-natural x (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (! mem-ref-natural dest src x)) + (progn + (! temp-push-unboxed-word src) + (ppc2-open-undo $undostkblk) + (let* ((oreg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (with-imm-temps () (src x) + (! temp-pop-unboxed-word src) + (ppc2-close-undo) + (! fixnum->signed-natural x oreg) + (! mem-ref-natural dest src x)))))))) + (^))))) + +(defppc2 ppc2-get-bit %get-bit (seg vreg xfer ptr offset) + (if (null vreg) + (progn + (ppc2-form seg nil nil ptr) + (ppc2-form seg nil ptr nil)) + (let* ((offval (acode-fixnum-form-p offset)) + (byte-index (if offval (ash offval -3))) + (bit-shift (if (and byte-index (< byte-index #x8000)) + (logand 31 (+ 25 (logand offval 7)))))) + (if bit-shift + (with-imm-target () + (src-reg :address) + (ppc2-one-targeted-reg-form seg ptr src-reg) + (if (node-reg-p vreg) + (! mem-ref-c-bit-fixnum vreg src-reg byte-index (logand 31 (+ bit-shift + *ppc2-target-fixnum-shift*))) + (with-imm-target () ;OK if src-reg & dest overlap + (dest :u8) + (! mem-ref-c-bit dest src-reg byte-index bit-shift) + (<- dest)))) + (let* ((triv-p (ppc2-trivial-p offset)) + (offset-reg nil)) + (with-imm-target () + (src-reg :address) + (ppc2-one-targeted-reg-form seg ptr src-reg) + (unless triv-p + (! temp-push-unboxed-word src-reg) + (ppc2-open-undo $undostkblk)) + (setq offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z)) + (unless triv-p + (! temp-pop-unboxed-word src-reg) + (ppc2-close-undo)) + (if (node-reg-p vreg) + (! mem-ref-bit-fixnum vreg src-reg offset-reg) + (with-imm-target () + (dest :u8) + (! mem-ref-bit dest src-reg offset-reg) + (<- dest)))))))) + (^)) + + + +;;; This returns an unboxed object, unless the caller wants to box it. +(defppc2 ppc2-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 (ppc2-trivial-p offset)) + (offval (acode-fixnum-form-p offset))) + (declare (fixnum size)) + (cond ((null vreg) + (ppc2-form seg nil nil ptr) + (ppc2-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) 15) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 15) (setq absptr nil)) + (target-arch-case + (:ppc32 (progn)) + (:ppc64 (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 + (:ppc32 (! mem-ref-c-fullword dest ppc::rzero absptr)) + (:ppc64 (! mem-ref-c-doubleword dest ppc::rzero absptr)))) + (offval + (with-imm-target () (src-reg :address) + (ppc2-one-targeted-reg-form seg ptr src-reg) + (target-arch-case + (:ppc32 (! mem-ref-c-fullword dest src-reg offval)) + (:ppc64 (! mem-ref-c-doubleword dest src-reg offval))))) + (t + (with-imm-target () (src-reg :address) + (with-imm-target (src-reg) (offset-reg :signed-natural) + (ppc2-one-targeted-reg-form seg ptr src-reg) + (if triv-p + (if (acode-fixnum-form-p offset) + (ppc2-lri seg offset-reg (acode-fixnum-form-p offset)) + (! fixnum->signed-natural offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (progn + (! temp-push-unboxed-word src-reg) + (ppc2-open-undo $undostkblk) + (! fixnum->signed-natural offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z)) + (! temp-pop-unboxed-word src-reg) + (ppc2-close-undo))) + (target-arch-case + (:ppc32 (! mem-ref-fullword dest src-reg offset-reg)) + (:ppc64 (! 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-signed-doubleword dest ppc::rzero absptr)) + (4 (! mem-ref-c-signed-fullword dest ppc::rzero absptr)) + (2 (! mem-ref-c-s16 dest ppc::rzero absptr)) + (1 (! mem-ref-c-s8 dest ppc::rzero absptr)))) + (offval + (with-imm-target (dest) (src-reg :address) + (ppc2-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-imm-target (src-reg) (offset-reg :signed-natural) + (ppc2-one-targeted-reg-form seg ptr src-reg) + (if triv-p + (if (acode-fixnum-form-p offset) + (ppc2-lri seg offset-reg (acode-fixnum-form-p offset)) + (! fixnum->signed-natural offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (progn + (! temp-push-unboxed-word src-reg) + (ppc2-open-undo $undostkblk) + (! fixnum->signed-natural offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z)) + (! temp-pop-unboxed-word src-reg) + (ppc2-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 + (:ppc32 + (<- dest)) + (:ppc64 (! box-fixnum vreg dest)))) + (8 (<- dest))) + (<- dest)))) + (t + (with-imm-target () (dest :natural) + (cond + (absptr + (case size + (8 (! mem-ref-c-doubleword dest ppc::rzero absptr)) + (4 (! mem-ref-c-fullword dest ppc::rzero absptr)) + (2 (! mem-ref-c-u16 dest ppc::rzero absptr)) + (1 (! mem-ref-c-u8 dest ppc::rzero absptr)))) + (offval + (with-imm-target (dest) (src-reg :address) + (ppc2-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-imm-target () (src-reg :address) + (with-imm-target (src-reg) (offset-reg :signed-natural) + (ppc2-one-targeted-reg-form seg ptr src-reg) + (if triv-p + (if (acode-fixnum-form-p offset) + (ppc2-lri seg offset-reg (acode-fixnum-form-p offset)) + (! fixnum->signed-natural offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z))) + (progn + (! temp-push-unboxed-word src-reg) + (ppc2-open-undo $undostkblk) + (! fixnum->signed-natural offset-reg (ppc2-one-untargeted-reg-form seg offset ppc::arg_z)) + (! temp-pop-unboxed-word src-reg) + (ppc2-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)))))))) + (^))))) + +(defppc2 ppc2-let let (seg vreg xfer vars vals body p2decls) + (let* ((old-stack (ppc2-encode-stack)) + (val nil) + (bits nil) + (valcopy vals)) + (with-ppc-p2-declarations p2decls + (dolist (var vars) + (setq val (%car valcopy)) + (cond ((or (%ilogbitp $vbitspecial (setq bits (nx-var-bits var))) + (and (%ilogbitp $vbitreg bits) + (dolist (val (%cdr valcopy)) + (unless (ppc2-trivial-p val) (return t))))) + (let* ((pair (cons (ppc2-vloc-ea *ppc2-vstack*) nil))) + (%rplaca valcopy pair) + (if (and (%ilogbitp $vbitdynamicextent bits) + (progn + (setq val + (ppc2-dynamic-extent-form seg (ppc2-encode-stack) val)) + (ppc2-load-ea-p val))) + (progn + (%rplaca pair (ppc2-vloc-ea *ppc2-vstack*)) + (ppc2-vpush-register seg val :reserved)) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg val ppc::arg_z) :reserved)) + (%rplacd pair *ppc2-top-vstack-lcell*))) + (t (ppc2-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 + (ppc2-dbind seg (car val) (var-name var)) + (ppc2-set-var-ea seg var (ppc2-vloc-ea (- *ppc2-vstack* *ppc2-target-node-size*)))) + (ppc2-seq-bind-var seg var (car val))))) + (ppc2-undo-body seg vreg xfer body old-stack) + (dolist (var vars) + (ppc2-close-var seg var))))) + +(defppc2 ppc2-closed-function closed-function (seg vreg xfer afunc) + (ppc2-make-closure seg afunc nil) + (when vreg (<- ppc::arg_z)) + (^)) + +(defppc2 ppc2-flet flet (seg vreg xfer vars afuncs body p2decls) + (ppc2-seq-fbind seg vreg xfer vars afuncs body p2decls)) + +(defppc2 ppc2-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 2) + (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) + (ppc2-seq-fbind seg vreg xfer (nreverse real-vars) (nreverse real-funcs) body p2decls) + (let* ((old-stack (ppc2-encode-stack))) + (setq real-vars (nreverse real-vars) real-funcs (nreverse real-funcs)) + (with-ppc-p2-declarations p2decls + (dolist (var real-vars) + (ppc2-seq-bind-var seg var (nx1-afunc-ref (pop real-funcs)))) + (dolist (ref fwd-refs) + (let ((ea (var-ea (pop ref)))) + (ppc2-addrspec-to-reg seg ea ppc::temp0) + (dolist (r ref) + (let* ((v-ea (var-ea (cdr r)))) + (let* ((val-reg (if (eq v-ea ea) + ppc::temp0 + (progn + (ppc2-addrspec-to-reg seg v-ea ppc::temp1) + ppc::temp1)))) + (! misc-set-c-node val-reg ppc::temp0 (car r))))))) + (ppc2-undo-body seg vreg xfer body old-stack) + (dolist (var real-vars) + (ppc2-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.) +(defppc2 ppc2-with-downward-closures with-downward-closures (seg vreg xfer tempvars closures callform) + (let* ((old-stack (ppc2-encode-stack))) + (ppc2-seq-bind seg tempvars closures) + (ppc2-undo-body seg vreg xfer callform old-stack) + (dolist (v tempvars) (ppc2-close-var seg v)))) + + +(defppc2 ppc2-local-return-from local-return-from (seg vreg xfer blocktag value) + (declare (ignorable vreg xfer)) + (let* ((*ppc2-undo-count* *ppc2-undo-count*) + (tagdata (car blocktag)) + (cur-stack (ppc2-encode-stack)) + (dest-vd (caar tagdata)) + (dest-cd (cdar tagdata)) + (mv-p (ppc2-mvpass-p dest-cd)) + (dest-stack (cdr tagdata)) + (need-break (neq cur-stack dest-stack))) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (*ppc2-cstack* *ppc2-cstack*)) + (if + (or + (eq dest-cd $backend-return) + (and mv-p + (eq (ppc2-encoding-undo-count cur-stack) + (ppc2-encoding-undo-count dest-stack)) + (eq (ppc2-encoding-cstack-depth cur-stack) + (ppc2-encoding-cstack-depth dest-stack)))) + (ppc2-form seg dest-vd dest-cd value) + (if mv-p + (progn + (ppc2-multiple-value-body seg value) + (let* ((*ppc2-returning-values* :pass)) + (ppc2-nlexit seg dest-cd (%i- *ppc2-undo-count* (ppc2-encoding-undo-count dest-stack))) + (ppc2-branch seg dest-cd vreg))) + (progn + (ppc2-form + seg + (if need-break (if dest-vd ppc::arg_z) dest-vd) + (if need-break nil dest-cd) + value) + (when need-break + (ppc2-unwind-set seg dest-cd dest-stack) + (when dest-vd (ppc2-copy-register seg dest-vd ppc::arg_z)) + (ppc2-branch seg dest-cd dest-vd)))))) + (ppc2-unreachable-store))) + +(defppc2 ppc2-inherited-arg inherited-arg (seg vreg xfer arg) + (when vreg + (ppc2-addrspec-to-reg seg (ppc2-ea-open (var-ea arg)) vreg)) + (^)) + + +(defppc2 ppc2-%lisp-word-ref %lisp-word-ref (seg vreg xfer base offset) + (let* ((fixoffset (acode-fixnum-form-p offset))) + (cond ((null vreg) + (ppc2-form seg nil nil base) + (ppc2-form seg nil xfer offset)) + ((target-arch-case + (:ppc32 (typep fixoffset '(signed-byte 14))) + (:ppc64 (typep fixoffset '(signed-byte 13)))) + (ensuring-node-target (target vreg) + (! lisp-word-ref-c target + (ppc2-one-untargeted-reg-form seg base ppc::arg_z) + (ash fixoffset *ppc2-target-fixnum-shift*))) + (^)) + (t (multiple-value-bind (breg oreg) + (ppc2-two-untargeted-reg-forms seg base ppc::arg_y offset ppc::arg_z) + (ensuring-node-target (target vreg) + (! lisp-word-ref target breg oreg)) + (^)))))) + +(defppc2 ppc2-%fixnum-ref %fixnum-ref (seg vreg xfer base offset) + (let* ((fixoffset (acode-fixnum-form-p offset))) + (cond ((null vreg) + (ppc2-form seg nil nil base) + (ppc2-form seg nil xfer offset)) + ((typep fixoffset '(signed-byte 16)) + (ensuring-node-target (target vreg) + (! lisp-word-ref-c target + (ppc2-one-untargeted-reg-form seg base ppc::arg_z) + fixoffset)) + (^)) + (t (multiple-value-bind (breg oreg) + (ppc2-two-untargeted-reg-forms seg base ppc::arg_y offset ppc::arg_z) + (with-imm-target () (otemp :s32) + (! fixnum->signed-natural otemp oreg) + (ensuring-node-target (target vreg) + (! lisp-word-ref target breg otemp))) + (^)))))) + +(defppc2 ppc2-%fixnum-ref-natural %fixnum-ref-natural (seg vreg xfer base offset) + (let* ((fixoffset (acode-fixnum-form-p offset))) + (cond ((null vreg) + (ppc2-form seg nil nil base) + (ppc2-form seg nil xfer offset)) + ((typep fixoffset '(signed-byte 16)) + (with-imm-target () (val :natural) + (! lisp-word-ref-c val + (ppc2-one-untargeted-reg-form seg base ppc::arg_z) + fixoffset) + (<- val)) + (^)) + (t (multiple-value-bind (breg oreg) + (ppc2-two-untargeted-reg-forms seg base ppc::arg_y offset ppc::arg_z) + (with-imm-target () (otemp :s32) + (! fixnum->signed-natural otemp oreg) + (with-imm-target () (val :natural) + (! lisp-word-ref val breg otemp) + (<- val))) + (^)))))) + +(defppc2 ppc2-int>0-p int>0-p (seg vreg xfer cc form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc) + (ppc2-one-targeted-reg-form seg form ($ ppc::arg_z)) + (! integer-sign) + (ppc2-test-reg-%izerop seg vreg xfer ppc::imm0 cr-bit true-p 0))) + + +(defppc2 ppc2-throw throw (seg vreg xfer tag valform ) + (declare (ignorable vreg xfer)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg tag ppc::arg_z)) + (if (ppc2-trivial-p valform) + (progn + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg valform ppc::arg_z)) + (ppc2-set-nargs seg 1)) + (ppc2-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. +(defppc2 ppc2-catch catch (seg vreg xfer tag valform) + (let* ((tag-label (backend-get-next-label)) + (mv-pass (ppc2-mv-p xfer))) + (ppc2-one-targeted-reg-form seg tag ($ ppc::arg_z)) + (if mv-pass + (! mkcatchmv) + (! mkcatch1v)) + (! non-barrier-jump (aref *backend-labels* tag-label)) + (ppc2-open-undo) + (if mv-pass + (ppc2-multiple-value-body seg valform) + (ppc2-one-targeted-reg-form seg valform ($ ppc::arg_z))) + (ppc2-lri seg ppc::imm0 (ash 1 *ppc2-target-fixnum-shift*)) + (if mv-pass + (! nthrowvalues) + (! nthrow1value)) + (ppc2-close-undo) + (@ tag-label) + (unless mv-pass (if vreg (<- ppc::arg_z))) + (let* ((*ppc2-returning-values* mv-pass)) ; nlexit keeps values on stack + (^)))) + + +(defppc2 ppc2-fixnum-overflow fixnum-overflow (seg vreg xfer form) + (destructuring-bind (op n0 n1) (acode-unwrapped-form form) + (ppc2-use-operator op seg vreg xfer n0 n1 *nx-t*))) + + + +(defppc2 ppc2-%aref2 simple-typed-aref2 (seg vreg xfer typename arr i j &optional dim0 dim1) + (if (null vreg) + (progn + (ppc2-form seg nil nil arr) + (ppc2-form seg nil nil i) + (ppc2-form seg nil xfer j)) + (let* ((type-keyword (ppc2-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword )) + (safe (unless *ppc2-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1))) + (ppc2-aref2 seg vreg xfer arr i j safe type-keyword dim0 dim1)))) + + +(defppc2 ppc2-general-aref2 general-aref2 (seg vreg xfer arr i j) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims))) + (ppc2-aref2 seg + vreg + xfer + arr + i + j + (if *ppc2-reckless* + *nx-nil* + (nx-lookup-target-uvector-subtag keyword )) + keyword ;(make-acode (%nx1-operator immediate) ) + (if (typep dim0 'fixnum) dim0) (if (typep dim1 'fixnum) dim1)))) + (t + (ppc2-three-targeted-reg-forms seg + arr ($ ppc::arg_x) + i ($ ppc::arg_y) + j ($ ppc::arg_z)) + (ppc2-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SParef2))))) ) + + +(defppc2 ppc2-%aref3 simple-typed-aref3 (seg vreg xfer typename arr i j k &optional dim0 dim1 dim2) + (if (null vreg) + (progn + (ppc2-form seg nil nil arr) + (ppc2-form seg nil nil i) + (ppc2-form seg nil nil j) + (ppc2-form seg nil xfer k))) + (let* ((type-keyword (ppc2-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword )) + (safe (unless *ppc2-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1)) + (dim2 (acode-fixnum-form-p dim2))) + (ppc2-aref3 seg vreg xfer arr i j k safe type-keyword dim0 dim1 dim2))) + +(defppc2 ppc2-general-aref3 general-aref3 (seg vreg xfer arr i j k) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims)) + (dim2 (caddr dims))) + (ppc2-aref3 seg + vreg + xfer + arr + i + j + k + (if *ppc2-reckless* + *nx-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 + (ppc2-four-targeted-reg-forms seg + arr ($ ppc::temp0) + i ($ ppc::arg_x) + j ($ ppc::arg_y) + k ($ ppc::arg_z)) + (ppc2-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SParef3)))))) + +(defppc2 ppc2-%aset2 simple-typed-aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1) + (let* ((type-keyword (ppc2-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword )) + (safe (unless *ppc2-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1))) + (ppc2-aset2 seg vreg xfer arr i j new safe type-keyword dim0 dim1)) +) + +(defppc2 ppc2-general-aset2 general-aset2 (seg vreg xfer arr i j new) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims))) + (ppc2-aset2 seg + vreg + xfer + arr + i + j + new + (unless *ppc2-reckless* + (nx-lookup-target-uvector-subtag keyword )) + keyword + (if (typep dim0 'fixnum) dim0) + (if (typep dim1 'fixnum) dim1)))) + (t + (ppc2-four-targeted-reg-forms seg + arr ($ ppc::temp0) + i ($ ppc::arg_x) + j ($ ppc::arg_y) + new ($ ppc::arg_z)) + (ppc2-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SPaset2)))))) + + +(defppc2 ppc2-general-aset3 general-aset3 (seg vreg xfer arr i j k new) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims)) + (dim2 (caddr dims))) + (ppc2-aset3 seg + vreg + xfer + arr + i + j + k + new + (unless *ppc2-reckless* + (nx-lookup-target-uvector-subtag keyword )) + keyword + (if (typep dim0 'fixnum) dim0) + (if (typep dim1 'fixnum) dim1) + (if (typep dim2 'fixnum) dim2)))) + (t + (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg arr ($ ppc::arg_z))) + (ppc2-four-targeted-reg-forms seg + i ($ ppc::temp0) + j ($ ppc::arg_x) + k ($ ppc::arg_y) + new ($ ppc::arg_z)) + (ppc2-pop-register seg ($ ppc::temp1)) + (ppc2-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SPaset3)))))) + +(defppc2 ppc2-%aset3 simple-typed-aset3 (seg vreg xfer typename arr i j k new &optional dim0 dim1 dim2) + (let* ((type-keyword (ppc2-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword)) + (safe (unless *ppc2-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1)) + (dim2 (acode-fixnum-form-p dim2))) + (ppc2-aset3 seg vreg xfer arr i j k new safe type-keyword dim0 dim1 dim2))) + + + +(defppc2 ppc2-%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) + (ppc2-immediate-operand subtag))))) + (if type-keyword + (ppc2-vref seg vreg xfer type-keyword uvector index (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag type-keyword))) + (progn + (ppc2-three-targeted-reg-forms seg subtag ($ ppc::arg_x) uvector ($ ppc::arg_y) index ($ ppc::arg_z)) + (! subtag-misc-ref) + (when vreg (<- ($ ppc::arg_z))) + (^)) ))) + +(defppc2 ppc2-%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) + (ppc2-immediate-operand subtag))))) + (if type-keyword + (ppc2-vset seg vreg xfer type-keyword uvector index newval (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag type-keyword))) + (progn + (ppc2-four-targeted-reg-forms seg + subtag ($ ppc::temp0) + uvector ($ ppc::arg_x) + index ($ ppc::arg_y) + newval ($ ppc::arg_z)) + + (! subtag-misc-set) + (when vreg (<- ($ ppc::arg_z))) + (^))))) + +(defppc2 ppc2-%macptrptr% %macptrptr% (seg vreg xfer form) + (with-imm-target () (target :address) + (ppc2-one-targeted-reg-form seg form (or vreg target))) + (^)) + + +;;; cons a macptr, unless "vreg" is an immediate register of mode :address. +(defppc2 ppc2-%consmacptr% %consmacptr% (seg vreg xfer form) + (cond ((null vreg) (ppc2-form seg nil xfer form)) + ((eql (get-regspec-mode vreg) hard-reg-class-gpr-mode-address) + (ppc2-form seg vreg xfer form)) + (t + (with-imm-target () (temp :address) + (<- (ppc2-one-targeted-reg-form seg form temp)) + (^))))) + +(defppc2 ppc2-%immediate-ptr-to-int %immediate-ptr-to-int (seg vreg xfer form) + (if (null vreg) + (ppc2-form seg nil xfer form) + (with-imm-target () (address-reg :address) + (ppc2-form seg address-reg nil form) + (<- (set-regspec-mode address-reg (gpr-mode-name-value :natural))) + (^)))) + +(defppc2 ppc2-%immediate-int-to-ptr %immediate-int-to-ptr (seg vreg xfer form) + (if (null vreg) + (ppc2-form seg nil xfer form) + (progn + (unless (logbitp (hard-regspec-value vreg) ppc-imm-regs) + (compiler-bug "I give up. When will I get this right ?")) + (let* ((natural-reg (ppc2-one-targeted-reg-form seg + form + ($ vreg :mode :natural)))) + (<- natural-reg) + (^))))) + + +(defppc2 ppc2-%function %function (seg vreg xfer sym) + (when vreg + (let* ((symreg (ppc2-one-untargeted-reg-form seg (make-acode (%nx1-operator immediate) + (ppc2-symbol-entry-locative sym)) ppc::arg_z))) + (with-node-temps (vreg symreg) (val) + (! symbol-function val symreg) + (<- val)))) + (^)) + +(defppc2 ppc2-%unbound-marker %unbound-marker (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (ppc2-lri seg target (target-arch-case + (:ppc32 ppc32::unbound-marker) + (:ppc64 ppc64::unbound-marker))))) + (^)) + +(defppc2 ppc2-slot-unbound-marker %slot-unbound-marker (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (ppc2-lri seg target (target-arch-case + (:ppc32 ppc32::slot-unbound-marker) + (:ppc64 ppc64::slot-unbound-marker))))) + (^)) + +(defppc2 ppc2-illegal-marker %illegal-marker (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (ppc2-lri seg target (target-arch-case + (:ppc32 ppc32::illegal-marker) + (:ppc64 ppc64::illegal-marker))))) + (^)) + +(defppc2 ppc2-lambda-bind lambda-bind (seg vreg xfer vals req rest keys-p auxen body p2decls) + (let* ((old-stack (ppc2-encode-stack)) + (nreq (list-length req)) + (rest-arg (nthcdr nreq vals)) + (apply-body (ppc2-eliminate-&rest body rest keys-p auxen rest-arg))) + (ppc2-seq-bind seg req vals) + (when apply-body (setq rest nil body apply-body)) + (let* + ((vloc *ppc2-vstack*) + (restloc vloc) + (nvloc (progn (if (or rest keys-p) (ppc2-formlist seg rest-arg)) *ppc2-vstack*))) + (with-ppc-p2-declarations p2decls + (when rest + (when keys-p + (until (eq restloc nvloc) + (with-node-temps () (temp) + (ppc2-stack-to-register seg (ppc2-vloc-ea restloc) temp) + (ppc2-vpush-register seg temp)) + (setq restloc (%i+ restloc *ppc2-target-node-size*)))) + (ppc2-set-nargs seg (length rest-arg)) + (ppc2-set-vstack restloc) + (if (%ilogbitp $vbitdynamicextent (nx-var-bits rest)) + (progn + (! stack-cons-list) + (ppc2-open-undo $undostkblk)) + (! list)) + (ppc2-vpush-register seg ppc::arg_z)) + (when rest (ppc2-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))) + (ppc2-bind-var seg (%car vars) (%i+ vloc (* val *ppc2-target-node-size*)))) + (ppc2-seq-bind-var seg (%car vars) val))) + (setq vars (%cdr vars) inits (%cdr inits)))) + (ppc2-undo-body seg vreg xfer body old-stack) + (dolist (var req) (ppc2-close-var seg var)) + (when rest (ppc2-close-var seg rest)) + (dolist (var (%car auxen)) (ppc2-close-var seg var)))))) + +(macrolet + ((def-ppc2-require (function op &optional (vinsn op)) + `(defppc2 ,function ,op (seg vreg xfer val) + (let* ((val-reg (ppc2-one-untargeted-reg-form + seg + val + (if (eq vreg ppc::arg_z) ppc::arg_y ppc::arg_z)))) + (! ,vinsn val-reg) + (when vreg (<- val-reg)) + (^))))) + (def-ppc2-require ppc2-require-simple-vector require-simple-vector) + (def-ppc2-require ppc2-require-simple-string require-simple-string) + (def-ppc2-require ppc2-require-integer require-integer) + (def-ppc2-require ppc2-require-fixnum require-fixnum) + (def-ppc2-require ppc2-require-real require-real) + (def-ppc2-require ppc2-require-list require-list) + (def-ppc2-require ppc2-require-character require-character) + (def-ppc2-require ppc2-require-number require-number) + (def-ppc2-require ppc2-require-symbol require-symbol) + (def-ppc2-require ppc2-require-s8 require-s8) + (def-ppc2-require ppc2-require-s8 require-u8) + (def-ppc2-require ppc2-require-s8 require-s16) + (def-ppc2-require ppc2-require-s8 require-u16) + (def-ppc2-require ppc2-require-s8 require-s32) + (def-ppc2-require ppc2-require-s8 require-u32) + (def-ppc2-require ppc2-require-s8 require-s64) + (def-ppc2-require ppc2-require-s8 require-u64)) + +(defppc2 ppc2-%badarg2 %badarg2 (seg vreg xfer badthing goodthing) + (ppc2-two-targeted-reg-forms seg badthing ($ ppc::arg_y) goodthing ($ ppc::arg_z)) + (ppc2-lri seg ($ ppc::arg_x) (ash $XWRONGTYPE *ppc2-target-fixnum-shift*)) + (ppc2-set-nargs seg 3) + (! ksignalerr) + (<- nil) + (^)) + +(defppc2 ppc2-%set-sbchar %set-sbchar (seg vreg xfer string index value) + (ppc2-vset + seg + vreg + xfer + :simple-string + string + index + value + (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag :simple-string)))) + + +;;; If we didn't use this for stack consing, turn it into a call. Ugh. + +(defppc2 ppc2-make-list make-list (seg vreg xfer size initial-element) + (ppc2-form seg vreg xfer (make-acode (%nx1-operator call) + (make-acode (%nx1-operator immediate) 'make-list) + (list nil + (list initial-element + (make-acode (%nx1-operator immediate) + :initial-element) + size))))) + + +(defppc2 ppc2-setq-free setq-free (seg vreg xfer sym val) + (let* ((rsym ($ ppc::arg_y)) + (rval ($ ppc::arg_z))) + (ppc2-one-targeted-reg-form seg val rval) + (ppc2-immediate seg rsym nil (ppc2-symbol-value-cell sym)) + (! setqsym) + (<- rval) + (^))) + +(defppc2 ppc2-%setf-macptr %setf-macptr (seg vreg xfer x y) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg x ppc::arg_z)) + (with-imm-target () (src-reg :address) + (ppc2-one-targeted-reg-form seg y src-reg) + (ppc2-vpop-register seg ppc::arg_z) + (unless (or *ppc2-reckless* (ppc2-form-typep x 'macptr)) + (with-imm-temps (src-reg) () + (! trap-unless-macptr ppc::arg_z))) + (! set-macptr-address src-reg ppc::arg_z) + (<- ppc::arg_z) + (^))) + +(defppc2 ppc2-%setf-double-float %setf-double-float (seg vref xfer fnode fval) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg fnode ppc::arg_z)) + (let* ((target ($ ppc::fp1 :class :fpr :mode :double-float)) + (node ($ ppc::arg_z))) + (ppc2-one-targeted-reg-form seg fval target) + (ppc2-vpop-register seg node) + (unless (or *ppc2-reckless* (ppc2-form-typep fnode 'double-float)) + (! trap-unless-double-float node)) + (! store-double node target) + (<- node) + (^))) + +(defppc2 ppc2-%setf-short-float %setf-short-float (seg vreg xfer fnode fval) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg fnode ppc::arg_z)) + (let* ((target ($ ppc::fp1 :class :fpr :mode :single-float)) + (freg ($ ppc::arg_z))) + (ppc2-one-targeted-reg-form seg fval target) + (ppc2-vpop-register seg freg) + (unless (or *ppc2-reckless* (ppc2-form-typep fnode 'short-float)) + (! trap-unless-single-float freg)) + (! store-single freg target) + (<- freg) + (^))) + + + +(defppc2 ppc2-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 (ppc2-encode-stack)) + (ilevel '*interrupt-level*)) + (! nmkunwind) + (ppc2-open-undo $undointerruptlevel) + (ppc2-new-vstack-lcell :special-value *ppc2-target-lcell-size* 0 ilevel) + (ppc2-new-vstack-lcell :special *ppc2-target-lcell-size* (ash 1 $vbitspecial) ilevel) + (ppc2-new-vstack-lcell :special-link *ppc2-target-lcell-size* 0 ilevel) + (ppc2-adjust-vstack (* 3 *ppc2-target-node-size*)) + (! non-barrier-jump (aref *backend-labels* cleanup-label)) + (-> protform-label) + (@ cleanup-label) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (*ppc2-cstack* (%i+ *ppc2-cstack* (target-arch-case + (:ppc32 ppc32::lisp-frame.size) + (:ppc64 ppc64::lisp-frame.size))))) + (ppc2-open-undo $undostkblk) ; tsp frame created by nthrow. + (! save-cleanup-context) + (setq *ppc2-cstack* (%i+ *ppc2-cstack* + (target-arch-case + (:ppc32 ppc32::lisp-frame.size) + (:ppc64 ppc64::lisp-frame.size)))) ; the frame we just pushed + (ppc2-form seg nil nil cleanup-form) + (ppc2-close-undo) + (! restore-cleanup-context) + (! jump-return-pc)) ; blr + (ppc2-open-undo) + (@ protform-label) + (ppc2-new-vstack-lcell :special-value *ppc2-target-lcell-size* 0 ilevel) + (ppc2-new-vstack-lcell :special *ppc2-target-lcell-size* (ash 1 $vbitspecial) ilevel) + (ppc2-new-vstack-lcell :special-link *ppc2-target-lcell-size* 0 ilevel) + (ppc2-adjust-vstack (* 3 *ppc2-target-node-size*)) + + (ppc2-undo-body seg vreg xfer protected-form old-stack))) + +(defppc2 ppc2-progv progv (seg vreg xfer symbols values body) + (let* ((cleanup-label (backend-get-next-label)) + (protform-label (backend-get-next-label)) + (old-stack (ppc2-encode-stack))) + (ppc2-two-targeted-reg-forms seg symbols ($ ppc::arg_y) values ($ ppc::arg_z)) + (! progvsave) + (ppc2-open-undo $undostkblk) + (! mkunwind) + (! non-barrier-jump (aref *backend-labels* cleanup-label)) + (-> protform-label) + (@ cleanup-label) + (! progvrestore) + (ppc2-open-undo) + (@ protform-label) + (ppc2-undo-body seg vreg xfer body old-stack))) + +(defppc2 ppc2-%ptr-eql %ptr-eql (seg vreg xfer cc x y ) + (if (null vreg) + (progn + (ppc2-form seg nil nil x) + (ppc2-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-ppc-cr-bit cc) + (if other + (with-imm-target () (other-target :address) + (ppc2-one-targeted-reg-form seg other other-target) + (if (typep abs '(signed-byte 16)) + (ppc2-test-reg-%izerop seg vreg xfer other-target cr-bit true-p abs) + (with-imm-temps (other-target) ((abs-target :address)) + (use-imm-temp other-target) + (ppc2-lri seg abs-target abs) + (ppc2-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) + (ppc2-one-targeted-reg-form seg x target-a) + (! temp-push-unboxed-word target-a) + (ppc2-open-undo $undostkblk) + (ppc2-one-targeted-reg-form seg y target-a) + (with-imm-target (target-a) (target-b :address) + (! temp-pop-unboxed-word target-b) + (ppc2-close-undo) + (ppc2-compare-registers seg vreg xfer target-b target-a cr-bit true-p)))))))) + +(defppc2 ppc2-set-bit %set-bit (seg vreg xfer ptr offset newval) + (let* ((offval (acode-fixnum-form-p offset)) + (byte-index (if offval (ash offval -3))) + (bit-index (if (and byte-index (< byte-index #x8000)) + (logand offval #x7))) + (triv-offset (ppc2-trivial-p offset)) + (triv-val (ppc2-trivial-p newval))) + (with-imm-target () + (src :address) + (ppc2-one-targeted-reg-form seg ptr src) + (if bit-index + (let* ((mask-start (logand 31 (+ bit-index 25))) + (mask-end (logand 31 (+ bit-index 23))) + (mask (ash #x80 (- bit-index))) + (constval (acode-fixnum-form-p newval))) + (if constval + (progn + (if (eql constval 0) + (! mem-set-c-bit-0 src byte-index mask-start mask-end) + (! mem-set-c-bit-1 src byte-index mask)) + (when vreg + (ppc2-form seg vreg nil newval))) + (progn + (unless triv-val + (! temp-push-unboxed-word src) + (ppc2-open-undo $undostkblk)) + (let* ((target (ppc2-one-untargeted-reg-form seg newval ppc::arg_z))) + (unless triv-val + (! temp-pop-unboxed-word src) + (ppc2-close-undo)) + (! mem-set-c-bit src byte-index (+ 24 bit-index) target) + (<- target))))) + (progn + (unless (and triv-val triv-offset) + (! temp-push-unboxed-word src) + (ppc2-open-undo $undostkblk)) + (multiple-value-bind (idx-reg val-reg) + (ppc2-two-untargeted-reg-forms seg offset ppc::arg_y newval ppc::arg_z) + (unless (and triv-val triv-offset) + (! temp-pop-unboxed-word src) + (ppc2-close-undo )) + (! mem-set-bit src idx-reg val-reg) + (<- val-reg))))) + (^))) + +(defppc2 ppc2-%immediate-set-xxx %immediate-set-xxx (seg vreg xfer bits ptr offset val) + (ppc2-%immediate-store seg vreg xfer bits ptr offset val)) + + + +(defppc2 ppc2-%immediate-inc-ptr %immediate-inc-ptr (seg vreg xfer ptr by) + (let* ((triv-by (ppc2-trivial-p by)) + (fixnum-by (acode-fixnum-form-p by))) + (if (and fixnum-by (eql 0 fixnum-by)) + (ppc2-form seg vreg xfer ptr) + (with-imm-target (vreg) (ptr-reg :address) + (ppc2-one-targeted-reg-form seg ptr ptr-reg) + (if fixnum-by + (with-imm-target (vreg ptr-reg) (result :address) + (let* ((high (ldb (byte 16 16) fixnum-by)) + (low (ldb (byte 16 0) fixnum-by))) + (declare (type (unsigned-byte 16) high low)) + (if (logbitp 15 low) (incf high)) + (! add-immediate result ptr-reg high low) + (<- result))) + (progn + (unless triv-by + (! temp-push-unboxed-word ptr-reg) + (ppc2-open-undo $undostkblk)) + (with-imm-target (vreg ptr-reg) (by-reg :s32) + (ppc2-one-targeted-reg-form seg by by-reg) + (unless triv-by + (! temp-pop-unboxed-word ptr-reg) + (ppc2-close-undo)) + (with-imm-target (vreg ptr-reg by-reg) (result :address) + (! fixnum-add result ptr-reg by-reg) + (<- result))))) + (^))))) + + + +(defppc2 ppc2-multiple-value-call multiple-value-call (seg vreg xfer fn arglist) + (ppc2-mvcall seg vreg xfer fn arglist)) + + + +(defppc2 ppc2-eabi-syscall eabi-syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports) + (declare (ignore monitor-exception-ports)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (*ppc2-cstack* *ppc2-cstack*) + (nextarg 0)) + (declare (fixnum nextarg)) + (! alloc-eabi-c-frame (the fixnum (length argvals))) + (ppc2-open-undo $undo-ppc-c-frame) + ;; 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 + (ppc2-lri seg ptr absptr) + (ppc2-one-targeted-reg-form seg valform ptr)) + (! set-eabi-c-arg ptr nextarg))) + (t + (! set-eabi-c-arg + (with-imm-target () + (valreg :natural) + (ppc2-unboxed-integer-arg-to-reg seg valform valreg spec)) + nextarg))) + (incf nextarg))) + (ppc2-form seg ppc::arg_z nil idx) + (! eabi-syscall) + (ppc2-close-undo) + (when vreg + (if (eq resultspec :void) + (<- nil) + (<- (set-regspec-mode ppc::imm0 (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))))))) + (^))) + + +;;; Caller has allocated poweropen stack frame. +(defun ppc2-poweropen-foreign-args (seg argspecs argvals) + (with-ppc-local-vinsn-macros (seg) + (let* ((fp-loads ()) + (nextarg 0) + (return-registers nil)) + ;; 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) (if return-registers (ppc2-pop-register seg ($ ppc::arg_y)))) + (declare (list specs vals)) + (let* ((valform (car vals)) + (spec (car specs)) + (longval (ppc2-long-constant-p valform)) + (absptr (acode-absolute-ptr-p valform))) + (case spec + (:registers + (setq return-registers t) + (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg valform ppc::arg_z))) + ((:signed-doubleword :unsigned-doubleword :hybrid-int-float :hybrid-float-float :hybrid-float-int) + + (ppc2-one-targeted-reg-form seg valform ($ ppc::arg_z)) + (if (eq spec :signed-doubleword) + (! gets64) + (! getu64)) + (! set-c-arg ($ ppc::imm0) nextarg) + (target-arch-case + (:ppc32 + (incf nextarg) + (! set-c-arg ($ ppc::imm1) nextarg)) + (:ppc64 + (case spec + (:hybrid-int-float (push (cons :single-float nextarg) fp-loads)) + (:hybrid-float-int (push (cons :single-float-high nextarg) fp-loads)) + (:hybrid-float-float + (push (cons :single-float-high nextarg) fp-loads) + (push (cons :single-float nextarg) fp-loads)))))) + (:double-float + (let* ((df ($ ppc::fp1 :class :fpr :mode :double-float))) + (ppc2-one-targeted-reg-form seg valform df) + (! set-double-c-arg df nextarg) + (push (cons :double-float nextarg) fp-loads) + (target-word-size-case + (32 (incf nextarg)) + (64)))) + (:single-float + (let* ((sf ($ ppc::fp1 :class :fpr :mode :single-float))) + (ppc2-one-targeted-reg-form seg valform sf) + (! set-single-c-arg sf nextarg) + (push (cons :single-float nextarg) fp-loads))) + (:address + (with-imm-target () + (ptr :address) + (if absptr + (ppc2-lri seg ptr absptr) + (ppc2-one-targeted-reg-form seg valform ptr)) + (! set-c-arg ptr nextarg))) + (t + (if (typep spec 'unsigned-byte) + (progn + (with-imm-target () (ptr :address) + (ppc2-one-targeted-reg-form seg valform ptr) + (with-imm-temps (ptr) (r) + (dotimes (i spec) + (target-arch-case + (:ppc32 + (! mem-ref-c-fullword r ptr (ash i ppc32::word-shift))) + (:ppc64 + (! mem-ref-c-doubleword r ptr (ash i ppc64::word-shift)))) + (! set-c-arg r nextarg) + (incf nextarg)))) + (decf nextarg)) + (with-imm-target () + (valreg :natural) + (let* ((reg valreg)) + (if longval + (ppc2-lri seg valreg longval) + (setq reg (ppc2-unboxed-integer-arg-to-reg seg valform valreg spec))) + (! set-c-arg reg nextarg)))))) + (unless (eq spec :registers)(incf nextarg)))) + (do* ((fpreg ppc::fp1 (1+ fpreg)) + (reloads (nreverse fp-loads) (cdr reloads))) + ((or (null reloads) (= fpreg ppc::fp14))) + (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 from) + (if (eq size :single-float-high) + (! reload-single-c-arg-high fpreg from) + (! reload-single-c-arg fpreg from))))) + return-registers))) + +(defun ppc2-poweropen-foreign-return (seg vreg xfer resultspec) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ((eq resultspec :double-float) + (<- ($ ppc::fp1 :class :fpr :mode :double-float))) + ((eq resultspec :single-float) + (<- ($ ppc::fp1 :class :fpr :mode :single-float))) + ((eq resultspec :unsigned-doubleword) + (ensuring-node-target + (target vreg) + (! makeu64) + (ppc2-copy-register seg target ppc::arg_z))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target + (target vreg) + (! makes64) + (ppc2-copy-register seg target ppc::arg_z))) + (t + (<- (make-wired-lreg ppc::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)))))))) + + (^))) + +(defppc2 ppc2-poweropen-syscall poweropen-syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports) + (declare (ignore monitor-exception-ports)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (*ppc2-cstack* *ppc2-cstack*)) + (declare (fixnum nextarg)) + (! alloc-c-frame (the fixnum + (+ (the fixnum (length argvals)) + (the fixnnum + (let* ((n 0)) + (declare (fixnum n)) + (dolist (spec argspecs n) + (if (typep spec 'unsigned-byte) + (incf n (the fixnum + (1- (the fixnum spec)))))))) + (the fixnum + (count-if + #'(lambda (x) + (member x + '(:double-float + :unsigned-doubleword + :signed-doubleword))) + argspecs))))) + (ppc2-open-undo $undo-ppc-c-frame) + (ppc2-poweropen-foreign-args seg argspecs argvals) + (ppc2-form seg ppc::arg_z nil idx) + (if (eq resultspec :signed-doubleword) + (! poweropen-syscall-s64) + (! poweropen-syscall)) + (ppc2-close-undo) + (ppc2-poweropen-foreign-return seg vreg xfer resultspec))) + +(defun ppc2-identity (seg vreg xfer arg) + (with-ppc-local-vinsn-macros (seg vreg xfer) + (if (null vreg) + (ppc2-form seg vreg xfer arg) + (progn + (ensuring-node-target (target vreg) + (ppc2-one-targeted-reg-form seg arg target)) + (^))))) + +;;; Outgoing C stack frame will look like: +;;; backptr +;;; NIL ; marker to keep GC happy, make GDB unhappy. +;;; 8 words of GPR arg vals - will be loaded & popped by subprim +;;; N words of "other" (overflow) arguments +;;; F words of single-float values, to be loaded into FPR before subprim call +;;; D aligned doublewords of double-float values, to be loaded into FPR before call. +(defppc2 ppc2-eabi-ff-call eabi-ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor) + (declare (ignore monitor)) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (*ppc2-cstack* *ppc2-cstack*) + (gpr-offset 0) + (other-offset 8) + (single-float-offset 8) + (double-float-offset 8) + (nsingle-floats 0) ; F + (ndouble-floats 0) ; D + (nother-words 0) + (nfpr-args 0) + (ngpr-args 0) + (fp-loads ())) + (declare (fixnum nshort-floats ndouble-floats nfpr-args ngpr-args narg-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) + (progn + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2)))) + (:single-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf nsingle-floats) + (progn + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2)))) + ((:unsigned-doubleword :signed-doubleword) + (setq ngpr-args (logior 1 ngpr-args)) + (incf ngpr-args 2) + (when (> ngpr-args 9) + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2))) + (t (incf ngpr-args) + (if (> ngpr-args 8) + (incf nother-words))))) + (let* ((single-words (+ 8 nother-words nsingle-floats)) + (total-words (if (zerop ndouble-floats) + single-words + (+ (the fixnum (+ ndouble-floats ndouble-floats)) + (the fixnum (logand (lognot 1) (the fixnum (1+ single-words)))))))) + + (! alloc-eabi-c-frame total-words)) + (setq single-float-offset (+ other-offset nother-words)) + (setq double-float-offset + (logand (lognot 1) + (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats)))))) + (setq ngpr-args 0 nfpr-args 0) + (ppc2-open-undo $undo-ppc-c-frame) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg address ppc::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 + (:double-float + (let* ((df ($ ppc::fp1 :class :fpr :mode :double-float))) + (incf nfpr-args) + (ppc2-one-targeted-reg-form seg valform df ) + (cond ((<= nfpr-args 8) + (! set-double-eabi-c-arg df double-float-offset) + (push (cons :double-float double-float-offset) fp-loads) + (incf double-float-offset 2)) + (t + (setq other-offset (logand (lognot 1) (the fixnum (1+ other-offset)))) + (! set-double-eabi-c-arg df other-offset) + (incf other-offset 2))))) + (:single-float + (let* ((sf ($ ppc::fp1 :class :fpr :mode :single-float))) + (incf nfpr-args) + (ppc2-one-targeted-reg-form + seg valform sf) + (cond ((<= nfpr-args 8) + (! set-single-eabi-c-arg sf single-float-offset) + (push (cons :single-float single-float-offset) fp-loads) + (incf single-float-offset)) + (t + (setq other-offset (logand (lognot 1) (the fixnum (1+ other-offset)))) + (! set-double-eabi-c-arg sf other-offset) + (incf other-offset 2))))) + ((:signed-doubleword :unsigned-doubleword) + (ppc2-one-targeted-reg-form seg valform ($ ppc::arg_z)) + (if (eq spec :signed-doubleword) + (! gets64) + (! getu64)) + (if (oddp ngpr-args) + (incf ngpr-args)) + (incf ngpr-args 2) + (if (oddp gpr-offset) + (incf gpr-offset)) + (cond ((<= ngpr-args 8) + (! set-eabi-c-arg ($ ppc::imm0) gpr-offset) + (incf gpr-offset) + (! set-eabi-c-arg ($ ppc::imm1) gpr-offset) + (incf gpr-offset)) + (t + (if (oddp other-offset) + (incf other-offset)) + (! set-eabi-c-arg ($ ppc::imm0) other-offset) + (incf other-offset) + (! set-eabi-c-arg ($ ppc::imm1) other-offset) + (incf other-offset)))) + (:address + (with-imm-target () (ptr :address) + (if absptr + (ppc2-lri seg ptr absptr) + (ppc2-form seg ptr nil valform)) + (incf ngpr-args) + (cond ((<= ngpr-args 8) + (! set-eabi-c-arg ptr gpr-offset) + (incf gpr-offset)) + (t + (! set-eabi-c-arg ptr other-offset) + (incf other-offset))))) + (t + (with-imm-target () (valreg :natural) + (let* ((reg (ppc2-unboxed-integer-arg-to-reg seg valform valreg spec))) + (incf ngpr-args) + (cond ((<= ngpr-args 8) + (! set-eabi-c-arg reg gpr-offset) + (incf gpr-offset)) + (t + (! set-eabi-c-arg reg other-offset) + (incf other-offset))))))))) + (do* ((fpreg ppc::fp1 (1+ fpreg)) + (reloads (nreverse fp-loads) (cdr reloads))) + ((or (null reloads) (= fpreg ppc::fp14))) + (declare (list reloads) (fixnum fpreg)) + (let* ((reload (car reloads)) + (size (car reload)) + (from (cdr reload))) + (if (eq size :double-float) + (! reload-double-eabi-c-arg ($ fpreg :class :fpr :mode :double-float) from) + (! reload-single-eabi-c-arg ($ fpreg :class :fpr :mode :single-float) from)))) + (ppc2-vpop-register seg ($ ppc::arg_z)) + (! eabi-ff-call) + (ppc2-close-undo) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ((eq resultspec :double-float) + (<- ($ ppc::fp1 :class :fpr :mode :double-float))) + ((eq resultspec :single-float) + (<- ($ ppc::fp1 :class :fpr :mode :single-float))) + ((eq resultspec :unsigned-doubleword) + (ensuring-node-target (target vreg) + (! makeu64) + (ppc2-copy-register seg target ppc::arg_z))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target (target vreg) + (! makes64) + (ppc2-copy-register seg target ppc::arg_z))) + (t + (<- (make-wired-lreg ppc::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)))))))) + (^))) + +(defppc2 ppc2-poweropen-ff-call poweropen-ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor-exception-ports) + (let* ((*ppc2-vstack* *ppc2-vstack*) + (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*) + (*ppc2-cstack* *ppc2-cstack*) + (return-registers nil)) + (declare (fixnum nextarg)) + (! alloc-c-frame (the fixnum + (+ (the fixnum (length argvals)) + (the fixnnum + (let* ((n 0)) + (declare (fixnum n)) + (dolist (spec argspecs n) + (if (typep spec 'unsigned-byte) + (incf n (the fixnum + (1- (the fixnum spec)))))))) + (the fixnum + (count-if + #'(lambda (x) + (member x + '(:double-float + :unsigned-doubleword + :signed-doubleword))) + argspecs))))) + (ppc2-open-undo $undo-ppc-c-frame) + (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg address ppc::arg_z)) + (setq return-registers (ppc2-poweropen-foreign-args seg argspecs argvals)) + (ppc2-vpop-register seg ppc::arg_z) + (if return-registers + (! poweropen-ff-call-regs) + (if monitor-exception-ports + (! poweropen-ff-callX) + (! poweropen-ff-call))) + (ppc2-close-undo) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ((eq resultspec :double-float) + (<- (make-hard-fp-reg ppc::fp1 hard-reg-class-fpr-mode-double))) + ((eq resultspec :single-float) + (<- (make-hard-fp-reg ppc::fp1 hard-reg-class-fpr-mode-single))) + ((eq resultspec :unsigned-doubleword) + (ensuring-node-target + (target vreg) + (! makeu64) + (ppc2-copy-register seg target ppc::arg_z))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target + (target vreg) + (! makes64) + (ppc2-copy-register seg target ppc::arg_z))) + (t + (<- (set-regspec-mode ppc::imm0 (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)))))))) + (^))) + + + + +(defppc2 ppc2-%temp-list %temp-list (seg vreg xfer arglist) + (ppc2-use-operator (%nx1-operator list) seg vreg xfer arglist)) + +(defppc2 ppc2-%temp-cons %temp-cons (seg vreg xfer car cdr) + (ppc2-use-operator (%nx1-operator cons) seg vreg xfer car cdr)) + + +;;; Under MacsBug 5.3 (and some others ?), this'll do a low-level user +;;; break. If the debugger doesn't recognize the trap instruction, +;;; you'll have to manually advance the PC past it. "arg" winds up in the +;;; arg_z register; whatever's in arg_z on return is returned by +;;; the %debug-trap construct. + +(defppc2 ppc2-%debug-trap %debug-trap (seg vreg xfer arg) + (ppc2-one-targeted-reg-form seg arg ($ ppc::arg_z)) + (! %debug-trap) + (<- ($ ppc::arg_z)) + (^)) + +(defppc2 ppc2-%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) ppc::arg_z) ($ ppc::arg_y) ($ ppc::arg_z)))) + (ppc2-one-targeted-reg-form seg arg reg) + (! eep.address target reg))) + (^)) + +(defppc2 ppc2-%natural+ %natural+ (seg vreg xfer x y) + (if (null vreg) + (progn + (ppc2-form seg nil nil x) + (ppc2-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) + (ppc2-absolute-natural seg vreg xfer (+ fix-x fix-y)) + (let* ((u15x (and (typep fix-x '(unsigned-byte 15)) fix-x)) + (u15y (and (typep fix-y '(unsigned-byte 15)) fix-y))) + (if (not (or u15x u15y)) + (with-imm-target () (xreg :natural) + (with-imm-target (xreg) (yreg :natural) + (ppc2-two-targeted-reg-forms seg x xreg y yreg) + (! %natural+ xreg xreg yreg)) + (<- xreg)) + (let* ((other (if u15x y x))) + (with-imm-target () (other-reg :natural) + (ppc2-one-targeted-reg-form seg other other-reg) + (! %natural+-c other-reg other-reg (or u15x u15y)) + (<- other-reg)))) + (^)))))) + +(defppc2 ppc2-%natural- %natural- (seg vreg xfer x y) + (if (null vreg) + (progn + (ppc2-form seg nil nil x) + (ppc2-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) + (ppc2-absolute-natural seg vreg xfer (- fix-x fix-y)) + (let* ((u15y (and (typep fix-y '(unsigned-byte 15)) fix-y))) + (if (not u15y) + (with-imm-target () (xreg :natural) + (with-imm-target (xreg) (yreg :natural) + (ppc2-two-targeted-reg-forms seg x xreg y yreg) + (! %natural- xreg xreg yreg)) + (<- xreg)) + (progn + (with-imm-target () (xreg :natural) + (ppc2-one-targeted-reg-form seg x xreg) + (! %natural--c xreg xreg u15y) + (<- xreg)))) + (^)))))) + +(defppc2 ppc2-%natural-logior %natural-logior (seg vreg xfer x y) + (if (null vreg) + (progn + (ppc2-form seg nil nil x) + (ppc2-form seg nil xfer y)) + (let* ((naturalx (nx-natural-constant-p x)) + (naturaly (nx-natural-constant-p y))) + (if (and naturalx naturaly) + (ppc2-absolute-natural seg vreg xfer (logior 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-imm-target (xreg) (yreg :natural) + (ppc2-two-targeted-reg-forms seg x xreg y yreg) + (! %natural-logior xreg xreg yreg)) + (<- xreg)) + (let* ((other (if u32x y x)) + (high (ldb (byte 16 16) constant)) + (low (ldb (byte 16 0) constant))) + (with-imm-target () (other-reg :natural) + (ppc2-one-targeted-reg-form seg other other-reg) + (! %natural-logior-c other-reg other-reg high low) + (<- other-reg)))) + (^)))))) + +(defppc2 ppc2-%natural-logxor %natural-logxor (seg vreg xfer x y) + (if (null vreg) + (progn + (ppc2-form seg nil nil x) + (ppc2-form seg nil xfer y)) + (let* ((naturalx (nx-natural-constant-p x)) + (naturaly (nx-natural-constant-p y))) + (if (and naturalx naturaly) + (ppc2-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-imm-target (xreg) (yreg :natural) + (ppc2-two-targeted-reg-forms seg x xreg y yreg) + (! %natural-logxor xreg xreg yreg)) + (<- xreg)) + (let* ((other (if u32x y x)) + (high (ldb (byte 16 16) constant)) + (low (ldb (byte 16 0) constant))) + (with-imm-target () (other-reg :natural) + (ppc2-one-targeted-reg-form seg other other-reg) + (! %natural-logxor-c other-reg other-reg high low) + (<- other-reg)))) + (^)))))) + +(defppc2 ppc2-%natural-logand %natural-logand (seg vreg xfer x y) + (if (null vreg) + (progn + (ppc2-form seg nil nil x) + (ppc2-form seg nil xfer y)) + (let* ((naturalx (nx-natural-constant-p x)) + (naturaly (nx-natural-constant-p y))) + (if (and naturalx naturaly) + (ppc2-absolute-natural seg vreg xfer (logand 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-imm-target (xreg) (yreg :natural) + (ppc2-two-targeted-reg-forms seg x xreg y yreg) + (! %natural-logand xreg xreg yreg)) + (<- xreg)) + (let* ((other (if u32x y x))) + (with-imm-target () (other-reg :natural) + (ppc2-one-targeted-reg-form seg other other-reg) + (multiple-value-bind (start-bit stop-bit) + (ppc2-mask-bits constant) + (if start-bit + (! %natural-logand-mask-c other-reg other-reg start-bit stop-bit) + (let* ((high (ldb (byte 16 16) constant)) + (low (ldb (byte 16 0) constant))) + (declare (type (unsigned-byte 16) high low)) + (unless (and (= high #xffff) + (= low high)) + (if (= low 0) + (! %natural-logand-high-c other-reg other-reg high) + (if (= high 0) + (! %natural-logand-low-c other-reg other-reg low) + (with-imm-target (other-reg) (const-reg :natural) + (ppc2-absolute-natural seg const-reg nil constant) + (! %natural-logand other-reg other-reg const-reg)))))))) + (<- other-reg)))) + (^)))))) + +(defppc2 ppc2-natural-shift-right natural-shift-right (seg vreg xfer num amt) + (with-imm-target () (dest :natural) + (ppc2-one-targeted-reg-form seg num dest) + (! natural-shift-right dest dest (acode-fixnum-form-p amt)) + (<- dest) + (^))) + +(defppc2 ppc2-natural-shift-left natural-shift-left (seg vreg xfer num amt) + (with-imm-target () (dest :natural) + (ppc2-one-targeted-reg-form seg num dest) + (! natural-shift-left dest dest (acode-fixnum-form-p amt)) + (<- dest) + (^))) + +;;; This assumes that "global" variables are always boundp. +(defppc2 ppc2-global-ref global-ref (seg vreg xfer sym) + (when vreg + (ensuring-node-target (target vreg) + (with-node-temps () (symreg) + (setq symreg (or (ppc2-register-constant-p sym) + (ppc2-store-immediate seg sym symreg))) + (! node-slot-ref target symreg (target-arch-case + (:ppc32 ppc32::symbol.vcell-cell) + (:ppc64 ppc64::symbol.vcell-cell)))))) + (^)) + +(defppc2 ppc2-global-setq global-setq (seg vreg xfer sym val) + (ppc2-vset seg + vreg + xfer + :symbol + (make-acode (%nx1-operator immediate) sym) + (make-acode (%nx1-operator fixnum) + (target-arch-case (:ppc32 ppc32::symbol.vcell-cell) + (:ppc64 ppc64::symbol.vcell-cell))) + val + nil)) + +(defppc2 ppc2-%current-frame-ptr %current-frame-ptr (seg vreg xfer) + (cond ((ppc2-tailcallok xfer) + (ppc2-restore-nvrs seg *ppc2-register-restore-ea* *ppc2-register-restore-count*) + (ppc2-restore-full-lisp-context seg) + (! %current-frame-ptr ($ ppc::arg_z)) + (! jump-return-pc)) + (t + (when vreg + (ensuring-node-target (target vreg) + (! %current-frame-ptr target))) + (^)))) + +(defppc2 ppc2-%foreign-stack-pointer %foreign-stack-pointer (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (! %current-frame-ptr target))) + (^)) + +(defppc2 ppc2-%current-tcr %current-tcr (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (! %current-tcr target))) + (^)) + + + +(defppc2 ppc2-%interrupt-poll %interrupt-poll (seg vreg xfer) + (! event-poll) + (ppc2-nil seg vreg xfer)) + + +(defppc2 ppc2-with-c-frame with-c-frame (seg vreg xfer body &aux + (old-stack (ppc2-encode-stack))) + (ecase (backend-name *target-backend*) + (:linuxppc32 (! alloc-eabi-c-frame 0)) + ((:darwinppc32 :darwinppc64 :linuxppc64) (! alloc-c-frame 0))) + (ppc2-open-undo $undo-ppc-c-frame) + (ppc2-undo-body seg vreg xfer body old-stack)) + +(defppc2 ppc2-with-variable-c-frame with-variable-c-frame (seg vreg xfer size body &aux + (old-stack (ppc2-encode-stack))) + (let* ((reg (ppc2-one-untargeted-reg-form seg size ppc::arg_z))) + (ecase (backend-name *target-backend*) + (:linuxppc32 (! alloc-variable-eabi-c-frame reg)) + ((:darwinppc32 :darwinppc64 :linuxppc64) (! alloc-variable-c-frame reg))) + (ppc2-open-undo $undo-ppc-c-frame) + (ppc2-undo-body seg vreg xfer body old-stack))) + +(defppc2 ppc2-%symbol->symptr %symbol->symptr (seg vreg xfer sym) + (let* ((src (ppc2-one-untargeted-reg-form seg sym ppc::arg_z))) + (ensuring-node-target (target vreg) + (! %symbol->symptr target src)) + (^))) + +(defppc2 ppc2-%double-to-single %double-to-single (seg vreg xfer arg) + (if (null vreg) + (ppc2-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 (ppc2-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) + (ppc2-one-targeted-reg-form seg arg argreg) + (with-fp-target () (sreg :single-float) + (! double-to-single sreg argreg) + (<- sreg) + (^)))))) + +(defppc2 ppc2-%single-to-double %single-to-double (seg vreg xfer arg) + (if (null vreg) + (ppc2-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)) + (progn + (ppc2-one-untargeted-reg-form + seg arg + (make-wired-lreg (hard-regspec-value vreg) + :class hard-reg-class-fpr + :mode hard-reg-class-fpr-mode-single)) + (^)) + (with-fp-target () (sreg :single-float) + (ppc2-one-targeted-reg-form seg arg sreg) + (<- (set-regspec-mode sreg hard-reg-class-fpr-mode-double)) + (^))))) + +(defppc2 ppc2-%symptr->symvector %symptr->symvector (seg vreg xfer arg) + (ppc2-identity seg vreg xfer arg)) + +(defppc2 ppc2-%symvector->symptr %symvector->symptr (seg vreg xfer arg) + (ppc2-identity seg vreg xfer arg)) + +(defppc2 ppc2-%fixnum-to-double %fixnum-to-double (seg vreg xfer arg) + (with-fp-target () (dreg :double-float) + (let* ((r (ppc2-one-untargeted-reg-form seg arg ppc::arg_z))) + (unless (or (acode-fixnum-form-p arg) + *ppc2-reckless*) + (! trap-unless-fixnum r)) + (! fixnum->fpr dreg r) + (<- dreg) + (^)))) + +(defppc2 ppc2-%fixnum-to-single %fixnum-to-single (seg vreg xfer arg) + (with-fp-target () (dreg :double-float) + (let* ((r (ppc2-one-untargeted-reg-form seg arg ppc::arg_z))) + (unless (or (acode-fixnum-form-p arg) + *ppc2-reckless*) + (! trap-unless-fixnum r)) + (! fixnum->fpr dreg r) + (<- (set-regspec-mode dreg hard-reg-class-fpr-mode-single)) + (^)))) + +(defppc2 ppc2-%double-float %double-float (seg vreg xfer arg) + (let* ((real (or (acode-fixnum-form-p arg) + (let* ((form (acode-unwrapped-form arg))) + (if (and (acode-p form) + (eq (acode-operator form) + (%nx1-operator immediate)) + (typep (cadr form) 'real)) + (cadr form)))))) + (if real + (ppc2-immediate seg vreg xfer (float real 0.0d0)) + (if (ppc2-form-typep arg 'single-float) + (ppc2-use-operator (%nx1-operator %single-to-double) + seg + vreg + xfer + arg) + (if (ppc2-form-typep arg 'fixnum) + (ppc2-use-operator (%nx1-operator %fixnum-to-double) + seg + vreg + xfer + arg) + (ppc2-use-operator (%nx1-operator call) + seg + vreg + xfer + (make-acode (%nx1-operator immediate) + '%double-float) + (list nil (list arg)))))))) + +(defppc2 ppc2-%single-float %single-float (seg vreg xfer arg) + (let* ((real (or (acode-fixnum-form-p arg) + (let* ((form (acode-unwrapped-form arg))) + (if (and (acode-p form) + (eq (acode-operator form) + (%nx1-operator immediate)) + (typep (cadr form) 'real)) + (cadr form)))))) + (if real + (ppc2-immediate seg vreg xfer (float real 0.0f0)) + (if (ppc2-form-typep arg 'double-float) + (ppc2-use-operator (%nx1-operator %double-to-single) + seg + vreg + xfer + arg) + (if (ppc2-form-typep arg 'fixnum) + (ppc2-use-operator (%nx1-operator %fixnum-to-single) + seg + vreg + xfer + arg) + (ppc2-use-operator (%nx1-operator call) + seg + vreg + xfer + (make-acode (%nx1-operator immediate) + '%short-float) + (list nil (list arg)))))))) + +;------ + +#+not-yet +(progn + + +;Make a gcable macptr. +(defppc2 ppc2-%new-ptr %new-ptr (b vreg xfer size clear-p ) + (declare (ignore b vreg xfer size clear-p)) + (error "%New-ptr is a waste of precious silicon.")) + + + +) Index: /branches/experimentation/later/source/compiler/X86/.cvsignore =================================================================== --- /branches/experimentation/later/source/compiler/X86/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/compiler/X86/X8664/x8664-arch.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/X8664/x8664-arch.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/X8664/x8664-arch.lisp (revision 8058) @@ -0,0 +1,1319 @@ +;;;-*- Mode: Lisp; Package: (X8664 :use CL) -*- +;;; +;;; Copyright (C) 2005, Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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::*x86-registers*))) + (unless ,known-entry + (error "register ~a not defined" ',known)) + (setf (gethash ,(string alias) x86::*x86-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 imm2.l ecx) +(defx86reg nargs cx) +(defx86reg nargs.l ecx) +(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.) +;;; Using a boxed register for nargs is intended to keep both imm0 +;;; and imm1 free on function entry, to help with processing &optional/&key. +(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 nil-value (+ #x3000 fulltag-nil)) +(defconstant t-value (+ #x3020 fulltag-symbol)) +(defconstant misc-bias fulltag-misc) +(defconstant cons-bias fulltag-cons) +(defconstant t-offset (- t-value 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) 5)) + +) +(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 xcf 0 ;"exception callback frame" + backptr + return-address ; always 0 + nominal-function + relative-pc + containing-object + xp + ra0 + ) + +;;; 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 +) + +(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) + +#+x86-target +(defconstant yield-syscall + #+linux-target 24 + #+freebsd-target 321 + #+darwin-target #x100003d) + +(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 + allocate_tstack + allocate_vstack + register_cstack + raise-thread-interrupt + 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 +) + +(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 #x5000) + + +(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 .SPunused-6) + (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 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 (+ x8664::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 (+ x8664::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) + + +(provide "X8664-ARCH") Index: /branches/experimentation/later/source/compiler/X86/X8664/x8664-backend.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/X8664/x8664-backend.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/X8664/x8664-backend.lisp (revision 8058) @@ -0,0 +1,556 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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::*x8664-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::*x8664-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. + :lisp-context-register x8664::gs + )) + +#+freebsdx86-target +(defvar *freebsdx8664-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x8664-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 + )) + +#+(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) + +(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")))))) + (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))) + (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) + (progn + (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset + (incf memory-arg-offset (* 8 (ceiling bits 64))))))) + (dynamic-extent-names name)) + (progn + (rlets (list name (foreign-record-type-name argtype))) + (inits `(setf (%%get-unsigned-longlong ,name 0) + (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr))))) + (if second8 + (inits `(setf (%%get-unsigned-longlong ,name 8) + (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr))))))))) + (lets (list name + `(, + (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)))))))))))) + +(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/experimentation/later/source/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 8058) @@ -0,0 +1,4394 @@ +;;;-*- Mode: Lisp; Package: (X86 :use CL) -*- +;;; +;;; Copyright (C) 2005 Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict the preamble takes precedence. +;;; +;;; OpenMCL 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))) + + +(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 x8664::word-shift)) (:%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) + (xorw (:%w x8664::nargs ) (:%w x8664::nargs ))) + ((:not (:pred = n 0)) + (movw (:$w (:apply ash n x8664::word-shift)) (:%w x8664::nargs )))) + +(define-x8664-vinsn check-exact-nargs (() + ((n :u16const))) + :resume + ((:pred = n 0) + (testw (:%w x8664::nargs) (:%w x8664::nargs))) + ((:not (:pred = n 0)) + (cmpw (:$w (:apply ash n x8664::word-shift)) (:%w x8664::nargs))) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-wrong-number-of-args))) + +(define-x8664-vinsn check-min-nargs (() + ((n :u16const))) + :resume + (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift))) + (jb :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-too-few-args))) + +(define-x8664-vinsn check-max-nargs (() + ((n :u16const))) + :resume + (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift))) + (jg :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-too-many-args))) + + +(define-x8664-vinsn default-1-arg (() + ((min :u16const))) + (rcmpw (:%w x8664::nargs) (:$w (: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 x8664::nil-value) (:%q x8664::arg_z)) + :done) + + +(define-x8664-vinsn default-2-args (() + ((min :u16const))) + (rcmpw (:%w x8664::nargs ) (:$w (: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 x8664::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 x8664::nil-value) (:%q x8664::arg_z)) + :done) + +(define-x8664-vinsn default-3-args (() + ((min :u16const))) + (rcmpw (:%w x8664::nargs ) (:$w (:apply ash (:apply + 2 min) x8664::word-shift))) + (ja :done) + (je :two) + (rcmpw (:%w x8664::nargs ) (:$w (: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 x8664::nil-value) (:%l x8664::arg_x)) + :last-2 + (movl (:$l x8664::nil-value) (:%l x8664::arg_y)) + :last-1 + (movl (:$l x8664::nil-value) (:%l x8664::arg_z)) + :done) + + +(define-x8664-vinsn default-optionals (() + ((n :u16const)) + ((temp :u64))) + (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift))) + (movw (:%w x8664::nargs) (:%w temp)) + (jae :done) + :loop + (addw (:$w x8664::fixnumone) (:%w temp)) + (cmpw (:$w (:apply ash n x8664::word-shift)) (:%w temp)) + (pushq (:$l x8664::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))) + (movzwl (:%w 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))) + (movzwl (:%w 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 x8664::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 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 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)) + (jge :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 x8664::nil-value) (:%l dest))) + + +(define-x8664-vinsn (load-t :constant-ref) (((dest t)) + ()) + (movl(:$l x8664::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 x8664::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)) (:@ (:%seg :rcontext) x8664::tcr.save-allocptr)) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-allocptr) (:%q x8664::allocptr)) + (rcmpq (:%q x8664::allocptr) (:@ (:%seg :rcontext) x8664::tcr.save-allocbase)) + (:byte #x7f) (:byte #x02) ;(jg :no-trap) + (uuo-alloc) + :no-trap + (andb (:$b (lognot x8664::fulltagmask)) (:@ (:%seg :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)) + (je :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))) + +;;; 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.pt 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) (:@ (:%seg :rcontext) x8664::tcr.save-allocptr)) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-allocptr) (:%q freeptr)) + (rcmpq (:%q freeptr) (:@ (:%seg :rcontext) x8664::tcr.save-allocbase)) + (:byte #x7f) (:byte #x02) ;(jg :no-trap) + (uuo-alloc) + :no-trap + (movq (:%q header) (:@ x8664::misc-header-offset (:%q freeptr))) + (andb (:$b (lognot x8664::fulltagmask)) (:@ (:%seg :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) (() + ()) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (jz :done) + (rcmpw (:%w x8664::nargs) (:$w (* 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) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (jz :done) + (rcmpw (:%w x8664::nargs) (:$w (* 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) + (rcmpw (:%w x8664::nargs) (:$w (* 1 x8664::node-size))) + (jb :done) + (je :one) + (pushq (:%q x8664::arg_y)) + :one + (pushq (:%q x8664::arg_z)) + :done) + ((:pred = max 1) + (testw (:%w x8664::nargs) (:%w 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) + (xorq (:%q imm) (:%q imm))) + ((:not (:pred = n 0)) + (movw (:$w (:apply ash n x8664::fixnumshift)) (:%w imm))) + (subw (:%w x8664::nargs) (:%w imm)) + (jae :push-more) + (movswq (:%w imm) (:%q imm)) + (subq (:%q imm) (:%q x8664::rsp)) + (jmp :done) + :push-loop + (pushq (:$l x8664::nil-value)) + (addw (:$b x8664::node-size) (:%w x8664::nargs)) + (subw (:$b x8664::node-size) (:%w 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 (:@ (+ x8664::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 (:@ (+ x8664::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)) (:@ (:%seg :rcontext) x8664::tcr.next-tsp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.next-tsp) (:%q temp)) + (movapd (:%xmm x8664::fpzero) (:@ (:%q temp))) + (movapd (:%xmm x8664::fpzero) (:@ 16 (:%q temp))) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:%q temp) (:@ (:%seg :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)) + (:@ (:%seg :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)) + (:@ (:%seg :rcontext) x8664::tcr.next-tsp))) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%q tempb)) + (movq (:@ (:%seg :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 (:%q tempa) (:@ (:%seg :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 (() + () + ((temp :imm))) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%q temp)) + (movq (:@ (:%q temp)) (:%q temp)) + (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) + (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.next-tsp)) + ) + +(define-x8664-vinsn discard-c-frame (() + () + ((temp :imm))) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q temp)) + (movq (:@ (:%q temp)) (:%q temp)) + (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) + + +(define-x8664-vinsn vstack-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 (:@ (:%seg :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 (:@ (:%seg :rcontext) x8664::tcr.db-link)) + (movq (:$l 0) (:@ x8664::interrupt-level-binding-index (:%q temp))) + (movq (:%q x8664::rsp) (:@ (:%seg :rcontext) x8664::tcr.db-link)) + (jns.pt :done) + (btrq (:$ub 63) (:@ (:%seg :rcontext) x8664::tcr.interrupt-pending)) + (jae.pt :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 (:@ (:%seg :rcontext) x8664::tcr.tlb-pointer) (:%q temp)) + (pushq (:@ x8664::interrupt-level-binding-index (:%q temp))) + (pushq (:$b x8664::interrupt-level-binding-index)) + (pushq (:@ (:%seg :rcontext) x8664::tcr.db-link)) + (movq (:$l (ash -1 x8664::fixnumshift)) (:@ x8664::interrupt-level-binding-index (:%q temp))) + (movq (:%q x8664::rsp) (:@ (:%seg :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 (:@ (:%seg :rcontext) x8664::tcr.tlb-pointer) (:%q tlb)) + (movq (:@ (:%seg :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) (:@ (:%seg :rcontext) x8664::tcr.db-link)) + (jns.pt :done) + (testq (:%q oldval) (:%q oldval)) + (js.pt :done) + (btrq (:$ub 63) (:@ (:%seg :rcontext) x8664::tcr.interrupt-pending)) + (jae.pt :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 #x00516825) (:@ (+ 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) (:@ (:%seg :rcontext) x8664::tcr.tlb-limit)) + (movq (:@ (:%seg :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) (:@ (:%seg :rcontext) x8664::tcr.tlb-limit)) + (movq (:@ (:%seg :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 (:@ (:%seg :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 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))) + (setb (:%b temp)) + (negb (:%b temp)) + (andl (:$l x8664::fixnumone) (:%l temp)) + (movl (:%l temp) (:%l dest))) + +(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 (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:%q w) (:@ 8 (:%q x8664::ra0)))) + + +(define-x8664-vinsn (temp-push-node :push :word :tsp) + (() + ((w :lisp)) + ((temp :imm))) + (subq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.next-tsp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) + (movq (:@ (:%seg :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 (:%q temp) (:@ (:%seg :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 (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movsd (:%xmm f) (:@ 8 (:%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 (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:@ 8 (:%q x8664::ra0)) (:%q w)) + (addq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) + + +(define-x8664-vinsn (temp-pop-node :pop :word :tsp) + (((w :lisp)) + () + ((temp :imm))) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%q temp)) + (movq (:@ x8664::dnode-size (:%q temp)) (:%q w)) + (movq (:@ (:%q temp)) (:%q temp)) + (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) + (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.next-tsp))) + +(define-x8664-vinsn (temp-pop-double-float :pop :word :csp) + (((f :double-float)) + ()) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movsd (:@ 8 (:%q x8664::ra0)) (:%xmm f)) + (addq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) + + + +(define-x8664-vinsn macptr->stack (((dest :lisp)) + ((ptr :address))) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:$b (+ 16 x8664::macptr.size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (leaq (:@ (+ 16 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)) + (rcmpq (:%q temp) (:$l 63)) + (cmovbw (:%w temp) (:%w shiftcount)) + (movq (:%q src) (:%q temp)) + (jae :shift-max) + (sarq (:%shift x8664::cl) (:%q temp)) + (jmp :done) + :shift-max + (sarq (:$ub 63) (:%q temp)) + :done + (andb (:$b (lognot x8664::fixnummask)) (:%b 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)) + (rcmpq (:%q temp) (:$l 63)) + (cmovbw (:%w temp) (:%w shiftcount)) + (movq (:%q src) (:%q temp)) + (jae :shift-max) + (shrq (:%shift x8664::cl) (:%q temp)) + (jmp :done) + :shift-max + (shrq (:$ub 63) (:%q temp)) + :done + (andb (:$b (lognot x8664::fixnummask)) (:%b 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)) + (andb (:$b (lognot x8664::fixnummask)) (:%b 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))) + +(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.pt :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.pt :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.pt :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.pn :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) + (addw (:$w (:apply - (:apply ash nfixed x8664::word-shift))) (:%w x8664::nargs)))) + +(define-x8664-vinsn opt-supplied-p (() + ()) + (xorl (:%l x8664::imm1) (:%l x8664::imm1)) + (movl (:$l x8664::t-value) (:%l x8664::arg_y)) + :loop + (rcmpw (:%w x8664::imm1) (:%w x8664::nargs)) + (movl (:$l x8664::nil-value) (:%l x8664::arg_z)) + (cmovll (:%l x8664::arg_y) (:%l x8664::arg_z)) + (addl (:$b x8664::node-size) (:%l x8664::imm1)) + (cmpl (:%l x8664::imm1) (:%l x8664::imm0)) + (pushq (:%q x8664::arg_z)) + (jne :loop)) + +(define-x8664-vinsn one-opt-supplied-p (() + () + ((temp :u64))) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (setne (:%b temp)) + (negb (:%b temp)) + (andl (:$b x8664::t-offset) (:%l temp)) + (addl (:$l x8664::nil-value) (:%l temp)) + (pushq (:%q temp))) + +(define-x8664-vinsn two-opt-supplied-p (() + () + ((temp0 :u64) + (temp1 :u64))) + (rcmpw (:%w x8664::nargs) (:$w x8664::node-size)) + (setae (:%b temp0)) + (seta (:%b temp1)) + (negb (:%b temp0)) + (negb (:%b temp1)) + (andl (:$b x8664::t-offset) (:%l temp0)) + (andl (:$b x8664::t-offset) (:%l temp1)) + (addl (:$l x8664::nil-value) (:%l temp0)) + (addl (:$l x8664::nil-value) (:%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 + (cmpw (:$w (ash 2 x8664::word-shift)) (:%w 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 + (rcmpw (:%w x8664::nargs) (:$w (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) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (je :none) ; exactly zero + (rcmpw (:%w x8664::nargs) (:$w (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 + ) + (movzwl (:%w x8664::nargs) (:%l x8664::nargs)) + ((: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 (:@ (+ x8664::nil-value (x8664::%kernel-global 'x86::ret1valaddr))) + (:%q temp)) + (cmpq (:%q temp) + (:%q x8664::ra0)) + (je :multiple) + (pushq (:@ (+ x8664::nil-value (x8664::%kernel-global 'x86::lexpr-return1v)))) + (jmp :finish) + :multiple + (pushq (:@ (+ x8664::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 (:@ (:%seg :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 (+ x8664::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 11)) (:%l temp)) + (cmpl (:$b (ash #xd800 -11))(:%l temp)) + (movl (:$l x8664::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)) + (addb (:$b x8664::subtag-character) (:%b 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))) + (movzwl (:%w x8664::nargs) (:%l x8664::nargs)) + (leaq (:@ (:%q x8664::rsp) (:%q x8664::nargs)) (:%q imm0)) + (subq (:@ (:%q imm0)) (:%q x8664::nargs)) + (movl (:$l x8664::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 (:@ (:%seg :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)) (:@ (:%seg :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)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%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 (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:%q size) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))) + +(define-x8664-vinsn set-c-arg (() + ((arg :u64) + (offset :u32const))) + (movq (:@ (:%seg :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 (:@ (:%seg :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 (:@ (:%seg :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 (:@ (:%seg :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 (:@ (:%seg :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)) (:@ (:%seg :rcontext) x8664::tcr.next-tsp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) + (movq (:@ (:%seg :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 (:%q temp) (:@ (:%seg :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 (:@ (:%seg :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 (() + ()) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (je :done) + (rcmpw (:%w x8664::nargs) (:$w (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))) + (movsd (:%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) (:@ (:%seg :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 (() + () + ()) + (:align 4)) + +(queue-fixup + (fixup-x86-vinsn-templates + *x8664-vinsn-templates* + x86::*x86-64-opcode-template-lists*)) + +(provide "X8664-VINSNS") + Index: /branches/experimentation/later/source/compiler/X86/x86-arch.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x86-arch.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x86-arch.lisp (revision 8058) @@ -0,0 +1,202 @@ +;;;-*- Mode: Lisp; Package: (X86 :use CL) -*- +;;; +;;; Copyright (C) 2005 Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + bad-funcall ; pseudo-target for funcall + 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 + BAD-fpscr-save-high ; high word of FP reg used to save FPSCR + image-name ; current image name + initial-tcr ; initial thread's context record + )) + +;;; 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/experimentation/later/source/compiler/X86/x86-asm.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x86-asm.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x86-asm.lisp (revision 8058) @@ -0,0 +1,4697 @@ +;;;-*- Mode: Lisp; Package: (X86 :use CL) -*- +;;; +;;; Copyright (C) 2005 Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict the preamble takes precedence. +;;; +;;; OpenMCL 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+)) + + +;;; cpu feature flags +(defconstant +Cpu086+ #x1) ; Any old cpu will do 0 does the same +(defconstant +Cpu186+ #x2) ; i186 or better required +(defconstant +Cpu286+ #x4) ; i286 or better required +(defconstant +Cpu386+ #x8) ; i386 or better required +(defconstant +Cpu486+ #x10) ; i486 or better required +(defconstant +Cpu586+ #x20) ; i585 or better required +(defconstant +Cpu686+ #x40) ; i686 or better required +(defconstant +CpuP4+ #x80) ; Pentium4 or better required +(defconstant +CpuK6+ #x100) ; AMD K6 or better required +(defconstant +CpuAthlon+ #x200) ; AMD Athlon or better required +(defconstant +CpuSledgehammer+ #x400) ; Sledgehammer or better required +(defconstant +CpuMMX+ #x800) ; MMX support required +(defconstant +CpuMMX2+ #x1000) ; extended MMX support (with SSE or 3DNow!Ext) required +(defconstant +CpuSSE+ #x2000) ; Streaming SIMD extensions required +(defconstant +CpuSSE2+ #x4000) ; Streaming SIMD extensions 2 required +(defconstant +Cpu3dnow+ #x8000) ; 3dnow! support required +(defconstant +Cpu3dnowA+ #x10000) ; 3dnow!Extensions support required +(defconstant +CpuPNI+ #x20000) ; Prescott New Instructions required +(defconstant +CpuPadLock+ #x40000) ; VIA PadLock required +;;; These flags are set by gas depending on the flag-code. +(defconstant +Cpu64+ #x4000000) ; 64bit support required +(defconstant +CpuNo64+ #x8000000) ; Not supported in the 64bit mode +;;; The default value for unknown CPUs - enable all features to avoid problems. +(defconstant +CpuUnknownFlags+ (logior +Cpu086+ +Cpu186+ +Cpu286+ +Cpu386+ +Cpu486+ +Cpu586+ +Cpu686+ +CpuP4+ +CpuSledgehammer+ +CpuMMX+ +CpuMMX2+ +CpuSSE+ +CpuSSE2+ +CpuPNI+ +Cpu3dnow+ +Cpu3dnowA+ +CpuK6+ +CpuAthlon+ +CpuPadLock+)) + +(defparameter *cpu-feature-names* + `((:Cpu086 . #x1) ; Any old cpu will do 0 does the same + (:Cpu186 . #x2) ; i186 or better required + (:Cpu286 . #x4) ; i286 or better required + (:Cpu386 . #x8) ; i386 or better required + (:Cpu486 . #x10) ; i486 or better required + (:Cpu586 . #x20) ; i585 or better required + (:Cpu686 . #x40) ; i686 or better required + (:CpuP4 . #x80) ; Pentium4 or better required + (:CpuK6 . #x100) ; AMD K6 or better required + (:CpuAthlon . #x200) ; AMD Athlon or better required + (:CpuSledgehammer . #x400) ; Sledgehammer or better required + (:CpuMMX . #x800) ; MMX support required + (:CpuMMX2 . #x1000) ; extended MMX support (with SSE or 3DNow!Ext) required + (:CpuSSE . #x2000) ; Streaming SIMD extensions required + (:CpuSSE2 . #x4000) ; Streaming SIMD extensions 2 required + (:Cpu3dnow . #x8000) ; 3dnow! support required + (:Cpu3dnowA . #x10000) ; 3dnow!Extensions support required + (:CpuPNI . #x20000) ; Prescott New Instructions required + (:CpuPadLock . #x40000) ; VIA PadLock required + ;; These flags are set depending on the flag-code. + (:Cpu64 . #x4000000) ; 64bit support required + (:CpuNo64 . #x8000000))) ; Not supported in the 64bit mode + +(defun %encode-cpu-flags (flags) + (flet ((encode-atomic-cpu-flag (f) + (cdr (assoc f *cpu-feature-names* :test #'eq)))) + (if flags + (if (atom flags) + (encode-atomic-cpu-flag flags) + (let* ((k 0)) + (dolist (flag flags k) + (let* ((k0 (encode-atomic-cpu-flag flag))) + (if k0 + (setq k (logior k k0)) + (return)))))) + 1))) + + +;;; opcode-modifier bits: +(defconstant +opcode-modifier-W+ #x1) ; set if operands can be words or dwords encoded the canonical way +(defconstant +opcode-modifier-D+ #x2) ; D = 0 if Reg --> Regmem D = 1 if Regmem --> Reg: MUST BE #x2 +(defconstant +opcode-modifier-Modrm+ #x4) +(defconstant +opcode-modifier-FloatR+ #x8) ; src/dest swap for floats: MUST BE #x8 +(defconstant +opcode-modifier-ShortForm+ #x10) ; register is in low 3 bits of opcode +(defconstant +opcode-modifier-FloatMF+ #x20) ; FP insn memory format bit sized by #x4 +(defconstant +opcode-modifier-Jump+ #x40) ; special case for jump insns. +(defconstant +opcode-modifier-JumpDword+ #x80) ; call and jump +(defconstant +opcode-modifier-JumpByte+ #x100) ; loop and jecxz +(defconstant +opcode-modifier-JumpInterSegment+ #x200) ; special case for intersegment leaps/calls +(defconstant +opcode-modifier-FloatD+ #x400) ; direction for float insns: MUST BE #x400 +(defconstant +opcode-modifier-Seg2ShortForm+ #x800) ; encoding of load segment reg insns +(defconstant +opcode-modifier-Seg3ShortForm+ #x1000) ; fs/gs segment register insns. +(defconstant +opcode-modifier-Size16+ #x2000) ; needs size prefix if in 32-bit mode +(defconstant +opcode-modifier-Size32+ #x4000) ; needs size prefix if in 16-bit mode +(defconstant +opcode-modifier-Size64+ #x8000) ; needs size prefix if in 16-bit mode +(defconstant +opcode-modifier-IgnoreSize+ #x10000) ; instruction ignores operand size prefix +(defconstant +opcode-modifier-DefaultSize+ #x20000) ; default insn size depends on mode +(defconstant +opcode-modifier-No-bSuf+ #x40000) ; b suffix on instruction illegal +(defconstant +opcode-modifier-No-wSuf+ #x80000) ; w suffix on instruction illegal +(defconstant +opcode-modifier-No-lSuf+ #x100000) ; l suffix on instruction illegal +(defconstant +opcode-modifier-No-sSuf+ #x200000) ; s suffix on instruction illegal +(defconstant +opcode-modifier-No-qSuf+ #x400000) ; q suffix on instruction illegal +(defconstant +opcode-modifier-No-xSuf+ #x800000) ; x suffix on instruction illegal +(defconstant +opcode-modifier-FWait+ #x1000000) ; instruction needs FWAIT +(defconstant +opcode-modifier-IsString+ #x2000000) ; quick test for string instructions +(defconstant +opcode-modifier-regKludge+ #x4000000) ; fake an extra reg operand for clr imul +(defconstant +opcode-modifier-IsPrefix+ #x8000000) ; opcode is a prefix +(defconstant +opcode-modifier-ImmExt+ #x10000000) ; instruction has extension in 8 bit imm +(defconstant +opcode-modifier-NoRex64+ #x20000000) ; instruction don't need Rex64 prefix. +(defconstant +opcode-modifier-Rex64+ #x40000000) ; instruction require Rex64 prefix. +(defconstant +opcode-modifier-Ugh+ #x80000000) ; deprecated fp insn gets a warning + + +(defconstant +opcode-modifier-NoSuf+ (logior +opcode-modifier-No-bSuf+ + +opcode-modifier-No-wSuf+ + +opcode-modifier-No-lSuf+ + +opcode-modifier-No-sSuf+ + +opcode-modifier-No-xSuf+ + +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-b-Suf+ (logior +opcode-modifier-No-wSuf+ +opcode-modifier-No-lSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-w-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-lSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-l-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-wSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-q-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-wSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-lSuf+ +opcode-modifier-No-xSuf+)) +(defconstant +opcode-modifier-x-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-wSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-lSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-bw-Suf+ (logior +opcode-modifier-No-lSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-bl-Suf+ (logior +opcode-modifier-No-wSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-wl-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-wlq-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+)) +(defconstant +opcode-modifier-lq-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-wSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+)) +(defconstant +opcode-modifier-wq-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-lSuf+ +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+)) +(defconstant +opcode-modifier-sl-Suf+ (logior +opcode-modifier-No-bSuf+ +opcode-modifier-No-wSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-bwl-Suf+ (logior +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+ +opcode-modifier-No-qSuf+)) +(defconstant +opcode-modifier-bwlq-Suf+ (logior +opcode-modifier-No-sSuf+ +opcode-modifier-No-xSuf+)) +(defconstant +opcode-modifier-FP+ +opcode-modifier-NoSuf+) +(defconstant +opcode-modifier-l-FP+ +opcode-modifier-l-Suf+) +(defconstant +opcode-modifier-q-FP+ (logior +opcode-modifier-q-Suf+ +opcode-modifier-NoRex64+)) +(defconstant +opcode-modifier-x-FP+ (logior +opcode-modifier-x-Suf+ +opcode-modifier-FloatMF+)) +(defconstant +opcode-modifier-sl-FP+ (logior +opcode-modifier-sl-Suf+ +opcode-modifier-FloatMF+)) +;;; Someone forgot that the FloatR bit reverses the operation when not +;;; equal to the FloatD bit. ie. Changing only FloatD results in the +;;; destination being swapped *and* the direction being reversed. +(defconstant +opcode-modifier-FloatDR+ +opcode-modifier-FloatD+) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defparameter *opcode-modifier-names* + `((:w . ,+opcode-modifier-W+) + (:d . ,+opcode-modifier-D+) + (:modrm . ,+opcode-modifier-Modrm+) + (:shortform . ,+opcode-modifier-ShortForm+) + (:floatr . ,+opcode-modifier-FloatR+) + (:floatmf . ,+opcode-modifier-FloatMF+) + (:jump . ,+opcode-modifier-Jump+) + (:jumpdword . ,+opcode-modifier-JumpDword+) + (:jumpbyte . ,+opcode-modifier-JumpByte+) + (:jumpintersegment . ,+opcode-modifier-JumpInterSegment+) + (:floatd . ,+opcode-modifier-FloatD+) + (:seg2shortform . ,+opcode-modifier-Seg2ShortForm+) + (:seg3shortform . ,+opcode-modifier-Seg3ShortForm+) + (:size16 . ,+opcode-modifier-Size16+) + (:size32 . ,+opcode-modifier-Size32+) + (:size64 . ,+opcode-modifier-Size64+) + (:ignoresize . ,+opcode-modifier-IgnoreSize+) + (:no-bsuf . ,+opcode-modifier-No-bsuf+) + (:no-wsuf . ,+opcode-modifier-No-wsuf+) + (:no-lsuf . ,+opcode-modifier-No-lsuf+) + (:no-ssuf . ,+opcode-modifier-No-ssuf+) + (:no-qsuf . ,+opcode-modifier-No-qsuf+) + (:no-xsuf . ,+opcode-modifier-No-xsuf+) + (:defaultsize . ,+opcode-modifier-DefaultSize+) + (:fwait . ,+opcode-modifier-FWait+) + (:isstring . ,+opcode-modifier-IsString+) + (:regkludge . ,+opcode-modifier-regKludge+) + (:isprefix . ,+opcode-modifier-IsPrefix+) + (:immext . ,+opcode-modifier-ImmExt+) + (:norex64 . ,+opcode-modifier-NoRex64+) + (:rex64 . ,+opcode-modifier-Rex64+) + (:ugh . ,+opcode-modifier-Ugh+) + (:nosuf . ,+opcode-modifier-NoSuf+) + (:b-suf . ,+opcode-modifier-b-Suf+) + (:w-suf . ,+opcode-modifier-w-Suf+) + (:l-suf . ,+opcode-modifier-l-Suf+) + (:q-suf . ,+opcode-modifier-q-Suf+) + (:x-suf . ,+opcode-modifier-x-suf+) + (:wl-suf . ,+opcode-modifier-wl-Suf+) + (:wlq-suf . ,+opcode-modifier-wlq-Suf+) + (:lq-suf . ,+opcode-modifier-lq-Suf+) + (:wq-suf . ,+opcode-modifier-wq-Suf+) + (:sl-suf . ,+opcode-modifier-sl-Suf+) + (:bwl-suf . ,+opcode-modifier-bwl-Suf+) + (:bwlq-suf . ,+opcode-modifier-bwlq-Suf+) + (:fp . ,+opcode-modifier-FP+) + (:l-fp . ,+opcode-modifier-l-FP+) + (:q-fp . ,+opcode-modifier-q-FP+) + (:x-fp . ,+opcode-modifier-x-FP+) + (:sl-fp . ,+opcode-modifier-sl-FP+) + (:floatd . ,+opcode-modifier-FloatD+) + (:floatdr . ,+opcode-modifier-FloatDR+))) + + +;;; By default, this returns NIL if the modifier can't be encoded. +;;; That's an error, but the caller can provide better error context. +(defun %encode-opcode-modifier (mod &optional errorp) + (flet ((encode-atomic-opcode-modifier (m) + (if m + (cdr (assoc m *opcode-modifier-names*)) + 0))) + (or + (if (atom mod) + (encode-atomic-opcode-modifier mod) + (let* ((k 0)) + (dolist (m mod k) + (let* ((k0 (encode-atomic-opcode-modifier m))) + (if k0 + (setq k (logior k0 k)) + (return)))))) + (if errorp (error "Unknown x86 opcode modifier: ~s" mod))))) + +) +(defmacro encode-opcode-modifier (&rest mod) + (%encode-opcode-modifier mod 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) + +(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+) + )) + +(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 ; cpuflags + 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 + )) + +(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-modifier (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-x8664-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 *x8664-opcode-templates* + (vector + ;; adc + (def-x8664-opcode adcq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x11 #o300 #x48) + (def-x8664-opcode adcq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x13 #o000 #x48) + (def-x8664-opcode adcq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x11 #x00 #x48) + (def-x8664-opcode adcq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o320 #x48) + (def-x8664-opcode adcq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x15 nil #x48) + (def-x8664-opcode adcq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o320 #x48) + (def-x8664-opcode adcq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o020 #x48) + (def-x8664-opcode adcq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o020 #x48) + + (def-x8664-opcode adcl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x11 #o300 #x00) + (def-x8664-opcode adcl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x13 #o000 #x00) + (def-x8664-opcode adcl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x11 #x00 #x00) + (def-x8664-opcode adcl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o320 #x00) + (def-x8664-opcode adcl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x15 nil nil) + (def-x8664-opcode adcl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o320 #x00) + (def-x8664-opcode adcl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o020 #x00) + (def-x8664-opcode adcl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o020 #x00) + + (def-x8664-opcode adcw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x11 #o300 #x00 #x66) + (def-x8664-opcode adcw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x13 #o000 #x00 #x66) + (def-x8664-opcode adcw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x11 #x00 #x00 #x66) + (def-x8664-opcode adcw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o320 #x00 #x66) + (def-x8664-opcode adcw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x15 nil nil #x66) + (def-x8664-opcode adcw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o320 #x00 #x66) + (def-x8664-opcode adcw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o020 #x00 #x66) + (def-x8664-opcode adcw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o020 #x00 #x66) + + (def-x8664-opcode adcb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x10 #o300 #x00) + (def-x8664-opcode adcb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x12 #o000 #x00) + (def-x8664-opcode adcb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x10 #x00 #x00) + (def-x8664-opcode adcb ((:imm8 :insert-imm8) (:acc :insert-nothing)) + #x14 nil nil) + (def-x8664-opcode adcb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #x80 #o320 #x00) + (def-x8664-opcode adcb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #x80 #o320 #x00) + (def-x8664-opcode adcb ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x80 #o020 #x00) + + ;; add + (def-x8664-opcode addq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x01 #o300 #x48) + (def-x8664-opcode addq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x03 #o000 #x48) + (def-x8664-opcode addq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x01 #x00 #x48) + (def-x8664-opcode addq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o300 #x48) + (def-x8664-opcode addq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x05 nil #x48) + (def-x8664-opcode addq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o300 #x48) + (def-x8664-opcode addq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o000 #x48) + (def-x8664-opcode addq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o000 #x48) + + (def-x8664-opcode addl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x01 #o300 #x00) + (def-x8664-opcode addl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x03 #o000 #x00) + (def-x8664-opcode addl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x01 #x00 #x00) + (def-x8664-opcode addl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o300 #x00) + (def-x8664-opcode addl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x05 nil nil) + (def-x8664-opcode addl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o300 #x00) + (def-x8664-opcode addl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o000 #x00) + (def-x8664-opcode addl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o000 #x00) + + (def-x8664-opcode addw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x01 #o300 #x00 #x66) + (def-x8664-opcode addw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x03 #o000 #x00 #x66) + (def-x8664-opcode addw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x01 #x00 #x00 #x66) + (def-x8664-opcode addw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o300 #x00 #x66) + (def-x8664-opcode addw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x05 nil nil #x66) + (def-x8664-opcode addw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o300 #x00 #x66) + (def-x8664-opcode addw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o000 #x00 #x66) + (def-x8664-opcode addw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o000 #x00 #x66) + + (def-x8664-opcode addb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x00 #o300 #x00) + (def-x8664-opcode addb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x02 #o000 #x00) + (def-x8664-opcode addb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x00 #x00 #x00) + (def-x8664-opcode addb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x04 nil nil) + (def-x8664-opcode addb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o300 #x00) + (def-x8664-opcode addb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o000 #x00) + + ;; and + (def-x8664-opcode andq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x21 #o300 #x48) + (def-x8664-opcode andq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x23 #o000 #x48) + (def-x8664-opcode andq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x21 #x00 #x48) + (def-x8664-opcode andq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o340 #x48) + (def-x8664-opcode andq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x25 nil #x48) + (def-x8664-opcode andq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o340 #x48) + (def-x8664-opcode andq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o040 #x48) + (def-x8664-opcode andq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o040 #x48) + + (def-x8664-opcode andl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x21 #o300 #x00) + (def-x8664-opcode andl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x23 #o000 #x00) + (def-x8664-opcode andl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x21 #x00 #x00) + (def-x8664-opcode andl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o340 #x00) + (def-x8664-opcode andl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x25 nil nil) + (def-x8664-opcode andl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o340 #x00) + (def-x8664-opcode andl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o040 #x00) + (def-x8664-opcode andl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o040 #x00) + + (def-x8664-opcode andw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x21 #o300 #x00 #x66) + (def-x8664-opcode andw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x23 #o000 #x00 #x66) + (def-x8664-opcode andw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x21 #x00 #x00 #x66) + (def-x8664-opcode andw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o340 #x00 #x66) + (def-x8664-opcode andw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x25 nil nil #x66) + (def-x8664-opcode andw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o340 #x00 #x66) + (def-x8664-opcode andw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o040 #x00 #x66) + (def-x8664-opcode andw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o040 #x00 #x66) + + (def-x8664-opcode andb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x20 #o300 #x00) + (def-x8664-opcode andb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x22 #o000 #x00) + (def-x8664-opcode andb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x20 #o000 #x00) + (def-x8664-opcode andb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x24 nil nil) + (def-x8664-opcode andb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o340 #x00) + (def-x8664-opcode andb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o040 #x00) + + ;; bsf + (def-x8664-opcode bsfq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbc #o300 #x48) + (def-x8664-opcode bsfq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbc #o000 #x48) + + (def-x8664-opcode bsfl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbc #o300 #x00) + (def-x8664-opcode bsfl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbc #o000 #x00) + + (def-x8664-opcode bsfw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0fbc #o300 #x00 #x66) + (def-x8664-opcode bsfw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0fbc #o000 #x00 #x66) + + ;; bsr + (def-x8664-opcode bsrq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbd #o300 #x48) + (def-x8664-opcode bsrq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbd #o000 #x48) + + (def-x8664-opcode bsrl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbd #o300 #x00) + (def-x8664-opcode bsrl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbd #o000 #x00) + + (def-x8664-opcode bsrw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0fbd #o300 #x00 #x66) + (def-x8664-opcode bsrw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0fbd #o000 #x00 #x66) + + ;; bswap + (def-x8664-opcode bswapq ((:reg64 :insert-opcode-reg)) + #x0fc8 nil #x48) + + (def-x8664-opcode bswapl ((:reg64 :insert-opcode-reg)) + #x0fc8 nil #x00) + + ;; bt + (def-x8664-opcode btq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o340 #x48) + (def-x8664-opcode btq ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o040 #x48) + (def-x8664-opcode btq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa3 #o300 #x48) + (def-x8664-opcode btq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa3 #o000 #x48) + + (def-x8664-opcode btl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o340 #x00) + (def-x8664-opcode btl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o040 #x00) + (def-x8664-opcode btl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fa3 #o300 #x00) + (def-x8664-opcode btl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa3 #o000 #x00) + + (def-x8664-opcode btw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o340 #x00 #x66) + (def-x8664-opcode btw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o040 #x00 #x66) + (def-x8664-opcode btw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fa3 #o300 #x00 #x66) + (def-x8664-opcode btw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa3 #o000 #x00 #x66) + + ;; btc + (def-x8664-opcode btcq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o370 #x48) + (def-x8664-opcode btcq ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o070 #x48) + (def-x8664-opcode btcq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fbb #o300 #x48) + (def-x8664-opcode btcq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fbb #o000 #x48) + + (def-x8664-opcode btcl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o370 #x00) + (def-x8664-opcode btcl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o070 #x00) + (def-x8664-opcode btcl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fbb #o300 #x00) + (def-x8664-opcode btcl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fbb #o000 #x00) + + (def-x8664-opcode btcw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o370 #x00 #x66) + (def-x8664-opcode btcw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o070 #x00 #x66) + (def-x8664-opcode btcw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fbb #o300 #x00 #x66) + (def-x8664-opcode btcw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fbb #o000 #x00 #x66) + + ;; btr + (def-x8664-opcode btrq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o360 #x48) + (def-x8664-opcode btrq ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o060 #x48) + (def-x8664-opcode btrq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fb3 #o300 #x48) + (def-x8664-opcode btrq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb3 #o000 #x48) + + (def-x8664-opcode btrl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o360 #x00) + (def-x8664-opcode btrl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o060 #x00) + (def-x8664-opcode btrl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fb3 #o300 #x00) + (def-x8664-opcode btrl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb3 #o000 #x00) + + (def-x8664-opcode btrw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o360 #x00 #x66) + (def-x8664-opcode btrw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o060 #x00 #x66) + (def-x8664-opcode btrw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fb3 #o300 #x00 #x66) + (def-x8664-opcode btrw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb3 #o000 #x00 #x66) + + ;; bts + (def-x8664-opcode btsq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o350 #x48) + (def-x8664-opcode btsq ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o050 #x48) + (def-x8664-opcode btsq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fab #o300 #x48) + (def-x8664-opcode btsq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fab #o000 #x48) + + (def-x8664-opcode btsl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o350 #x00) + (def-x8664-opcode btsl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o050 #x00) + (def-x8664-opcode btsl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fab #o300 #x00) + (def-x8664-opcode btsl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fab #o000 #x00) + + (def-x8664-opcode btsw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o350 #x00 #x66) + (def-x8664-opcode btsw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o050 #x00 #x66) + (def-x8664-opcode btsw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fab #o300 #x00 #x66) + (def-x8664-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-x8664-opcode call ((:label :insert-label)) + #xe8 nil nil) + + (def-x8664-opcode call ((:reg64 :insert-modrm-rm)) + #xff #o320 #x0) + + (def-x8664-opcode call ((:anymem :insert-memory)) + #xff #o020 #x0) + + ;; cbtw + (def-x8664-opcode cbtw () + #x98 nil nil #x66) + + ;; clc + (def-x8664-opcode clc () + #xf8 nil nil) + + ;; cld + (def-x8664-opcode cld () + #xfc nil nil) + + ;; cltd + (def-x8664-opcode cltd () + #x99 nil nil) + + + ;; cltq + (def-x8664-opcode cltq () + #x98 nil #x48) + + ;; cmc + (def-x8664-opcode cmc () + #xf5 nil nil) + + ;; cmovCC + (def-x8664-opcode cmovccq + ((:imm8 :insert-cc) (:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f40 #o300 #x48) + (def-x8664-opcode cmovccq + ((:imm8 :insert-cc) (:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f40 #o000 #x48) + (def-x8664-opcode cmovccl + ((:imm8 :insert-cc) (:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f40 #o300 #x00) + (def-x8664-opcode cmovccl + ((:imm8 :insert-cc) (:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f40 #o000 #x00) + (def-x8664-opcode cmovccw + ((:imm8 :insert-cc) (:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f40 #o300 #x00 #x66) + (def-x8664-opcode cmovccw + ((:imm8 :insert-cc) (:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f40 #o000 #x00 #x66) + + (def-x8664-opcode cmovoq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f40 #o300 #x48) + (def-x8664-opcode cmovoq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f40 #o000 #x48) + (def-x8664-opcode cmovol ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f40 #o300 #x00) + (def-x8664-opcode cmovol ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f40 #o000 #x00) + (def-x8664-opcode cmovow ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f40 #o300 #x00 #x66) + (def-x8664-opcode cmovow ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f40 #o000 #x00 #x66) + + (def-x8664-opcode cmovnoq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f41 #o300 #x48) + (def-x8664-opcode cmovnoq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f41 #o000 #x48) + (def-x8664-opcode cmovnol ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f41 #o300 #x00) + (def-x8664-opcode cmovnol ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f41 #o000 #x00) + (def-x8664-opcode cmovnow ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f41 #o300 #x00 #x66) + (def-x8664-opcode cmovnow ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f41 #o000 #x00 #x66) + + (def-x8664-opcode cmovbq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f42 #o300 #x48) + (def-x8664-opcode cmovbq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f42 #o000 #x48) + (def-x8664-opcode cmovbl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f42 #o300 #x00) + (def-x8664-opcode cmovbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f42 #o000 #x00) + (def-x8664-opcode cmovbw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f42 #o300 #x00 #x66) + (def-x8664-opcode cmovbw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f42 #o000 #x00 #x66) + + (def-x8664-opcode cmovaeq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f43 #o300 #x48) + (def-x8664-opcode cmovaeq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f43 #o000 #x48) + (def-x8664-opcode cmovael ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f43 #o300 #x00) + (def-x8664-opcode cmovael ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f43 #o000 #x00) + (def-x8664-opcode cmovaew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f43 #o300 #x00 #x66) + (def-x8664-opcode cmovaew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f43 #o000 #x00 #x66) + + (def-x8664-opcode cmoveq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f44 #o300 #x48) + (def-x8664-opcode cmoveq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f44 #o000 #x48) + (def-x8664-opcode cmovel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f44 #o300 #x00) + (def-x8664-opcode cmovel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f44 #o000 #x00) + (def-x8664-opcode cmovew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f44 #o300 #x00 #x66) + (def-x8664-opcode cmovew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f44 #o000 #x00 #x66) + + (def-x8664-opcode cmovneq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f45 #o300 #x48) + (def-x8664-opcode cmovneq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f45 #o000 #x48) + (def-x8664-opcode cmovnel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f45 #o300 #x00) + (def-x8664-opcode cmovnel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f45 #o000 #x00) + (def-x8664-opcode cmovnew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f45 #o300 #x00 #x66) + (def-x8664-opcode cmovnew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f45 #o000 #x00 #x66) + + (def-x8664-opcode cmovbeq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f46 #o300 #x48) + (def-x8664-opcode cmovbeq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f46 #o000 #x48) + (def-x8664-opcode cmovbel ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-reg)) + #x0f46 #o300 #x00) + (def-x8664-opcode cmovbel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f46 #o000 #x00) + (def-x8664-opcode cmovbew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f46 #o300 #x00 #x66) + (def-x8664-opcode cmovbew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f46 #o000 #x00 #x66) + + (def-x8664-opcode cmovaq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f47 #o300 #x48) + (def-x8664-opcode cmovaq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f47 #o000 #x48) + (def-x8664-opcode cmoval ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f47 #o300 #x00) + (def-x8664-opcode cmoval ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f47 #o000 #x00) + (def-x8664-opcode cmovaw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f47 #o300 #x00 #x66) + (def-x8664-opcode cmovaw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f47 #o000 #x00 #x66) + + (def-x8664-opcode cmovsq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f48 #o300 #x48) + (def-x8664-opcode cmovsq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f48 #o000 #x48) + (def-x8664-opcode cmovsl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f48 #o300 #x00) + (def-x8664-opcode cmovsl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f48 #o000 #x00) + (def-x8664-opcode cmovsw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f48 #o300 #x00 #x66) + (def-x8664-opcode cmovsw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f48 #o000 #x00 #x66) + + (def-x8664-opcode cmovnsq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f49 #o300 #x48) + (def-x8664-opcode cmovnsq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f49 #o000 #x48) + (def-x8664-opcode cmovnsl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f49 #o300 #x00) + (def-x8664-opcode cmovnsl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f49 #o000 #x00) + (def-x8664-opcode cmovnsw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f49 #o300 #x00 #x66) + (def-x8664-opcode cmovnsw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f49 #o000 #x00 #x66) + + (def-x8664-opcode cmovpeq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4a #o300 #x48) + (def-x8664-opcode cmovpeq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4a #o000 #x48) + (def-x8664-opcode cmovpel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4a #o300 #x00) + (def-x8664-opcode cmovpel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4a #o000 #x00) + (def-x8664-opcode cmovpew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4a #o300 #x00 #x66) + (def-x8664-opcode cmovpew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4a #o000 #x00 #x66) + + (def-x8664-opcode cmovpoq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4b #o300 #x48) + (def-x8664-opcode cmovpoq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4b #o000 #x48) + (def-x8664-opcode cmovpol ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4b #o300 #x00) + (def-x8664-opcode cmovpol ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4b #o000 #x00) + (def-x8664-opcode cmovpow ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4b #o300 #x00 #x66) + (def-x8664-opcode cmovpow ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4b #o000 #x00 #x66) + + (def-x8664-opcode cmovlq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4c #o300 #x48) + (def-x8664-opcode cmovlq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4c #o000 #x48) + (def-x8664-opcode cmovll ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4c #o300 #x00) + (def-x8664-opcode cmovll ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4c #o000 #x00) + (def-x8664-opcode cmovlw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4c #o300 #x00 #x66) + (def-x8664-opcode cmovlw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4c #o000 #x00 #x66) + + (def-x8664-opcode cmovgeq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4d #o300 #x48) + (def-x8664-opcode cmovgeq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4d #o000 #x48) + (def-x8664-opcode cmovgel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4d #o300 #x00) + (def-x8664-opcode cmovgel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4d #o000 #x00) + (def-x8664-opcode cmovgew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4d #o300 #x00 #x66) + (def-x8664-opcode cmovgew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4d #o000 #x00 #x66) + + (def-x8664-opcode cmovleq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4e #o300 #x48) + (def-x8664-opcode cmovleq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4e #o000 #x48) + (def-x8664-opcode cmovlel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4e #o300 #x00) + (def-x8664-opcode cmovlel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4e #o000 #x00) + (def-x8664-opcode cmovlew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4e #o300 #x00 #x66) + (def-x8664-opcode cmovlew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4e #o000 #x00 #x66) + + (def-x8664-opcode cmovgq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4f #o300 #x48) + (def-x8664-opcode cmovgq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4f #o000 #x48) + (def-x8664-opcode cmovgl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4f #o300 #x00) + (def-x8664-opcode cmovgl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4f #o000 #x00) + (def-x8664-opcode cmovgw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4f #o300 #x00 #x66) + (def-x8664-opcode cmovgw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4f #o000 #x00 #x66) + + + ;; cmp + + (def-x8664-opcode cmpq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x39 #o300 #x48) + (def-x8664-opcode rcmpq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x39 #o300 #x48) + (def-x8664-opcode cmpq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x3b #o000 #x48) + (def-x8664-opcode rcmpq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x3b #o000 #x48) + (def-x8664-opcode cmpq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x39 #x00 #x48) + (def-x8664-opcode rcmpq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x39 #x00 #x48) + (def-x8664-opcode cmpq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o370 #x48) + (def-x8664-opcode rcmpq ((:reg64 :insert-modrm-rm) (:imm8s :insert-imm8s)) + #x83 #o370 #x48) + (def-x8664-opcode cmpq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x3d nil #x48) + (def-x8664-opcode rcmpq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x3d nil #x48) + (def-x8664-opcode cmpq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o370 #x48) + (def-x8664-opcode rcmpq ((:reg64 :insert-modrm-rm) (:imm32s :insert-imm32s)) + #x81 #o370 #x48) + (def-x8664-opcode cmpq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o070 #x48) + (def-x8664-opcode rcmpq ((:anymem :insert-memory) (:imm8s :insert-imm8s)) + #x83 #o070 #x48) + (def-x8664-opcode cmpq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o070 #x48) + (def-x8664-opcode rcmpq ((:anymem :insert-memory) (:imm32s :insert-imm32s)) + #x81 #o070 #x48) + + (def-x8664-opcode cmpl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x39 #o300 #x00) + (def-x8664-opcode rcmpl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x39 #o300 #x00) + (def-x8664-opcode cmpl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x3b #o000 #x00) + (def-x8664-opcode rcmpl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x3b #o000 #x00) + (def-x8664-opcode cmpl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x39 #x00 #x00) + (def-x8664-opcode rcmpl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x39 #x00 #x00) + (def-x8664-opcode cmpl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o370 #x00) + (def-x8664-opcode rcmpl ((:reg32 :insert-modrm-rm) (:imm8s :insert-imm8s)) + #x83 #o370 #x00) + (def-x8664-opcode cmpl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x3d nil nil) + (def-x8664-opcode rcmpl ((:acc :insert-nothing) (:imm32s :insert-imm32s)) + #x3d nil nil) + (def-x8664-opcode cmpl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o370 #x00) + (def-x8664-opcode rcmpl ((:reg32 :insert-modrm-rm) (:imm32s :insert-imm32s)) + #x81 #o370 #x00) + (def-x8664-opcode cmpl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o070 #x00) + (def-x8664-opcode rcmpl ((:anymem :insert-memory) (:imm8s :insert-imm8s)) + #x83 #o070 #x00) + (def-x8664-opcode cmpl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o070 #x00) + (def-x8664-opcode rcmpl ((:anymem :insert-memory) (:imm32s :insert-imm32s)) + #x81 #o070 #x00) + + (def-x8664-opcode cmpw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x39 #o300 #x00 #x66) + (def-x8664-opcode rcmpw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x39 #o300 #x00 #x66) + (def-x8664-opcode cmpw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x3b #o000 #x00 #x66) + (def-x8664-opcode rcmpw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x3b #o000 #x00 #x66) + (def-x8664-opcode cmpw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x39 #x00 #x00 #x66) + (def-x8664-opcode rcmpw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x39 #x00 #x00 #x66) + (def-x8664-opcode cmpw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o370 #x00 #x66) + (def-x8664-opcode rcmpw ((:reg16 :insert-modrm-rm) (:imm8s :insert-imm8s)) + #x83 #o370 #x00 #x66) + (def-x8664-opcode cmpw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x3d nil nil #x66) + (def-x8664-opcode rcmpw ((:acc :insert-nothing) (:imm16 :insert-imm16)) + #x3d nil nil #x66) + (def-x8664-opcode cmpw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o370 #x00 #x66) + (def-x8664-opcode rcmpw ((:reg16 :insert-modrm-rm) (:imm16 :insert-imm16)) + #x81 #o370 #x00 #x66) + (def-x8664-opcode cmpw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o070 #x00 #x66) + (def-x8664-opcode rcmpw ((:anymem :insert-memory) (:imm8s :insert-imm8s)) + #x83 #o070 #x00 #x66) + (def-x8664-opcode cmpw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o070 #x00 #x66) + (def-x8664-opcode rcmpw ((:anymem :insert-memory) (:imm16 :insert-imm16)) + #x81 #o070 #x00 #x66) + + (def-x8664-opcode cmpb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x38 #o300 #x00) + (def-x8664-opcode rcmpb ((:reg8 :insert-modrm-rm) (:reg8 :insert-modrm-reg)) + #x38 #o300 #x00) + (def-x8664-opcode cmpb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x3a #o000 #x00) + (def-x8664-opcode rcmpb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x3a #o000 #x00) + (def-x8664-opcode cmpb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x38 #x00 #x00) + (def-x8664-opcode rcmpb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x38 #x00 #x00) + (def-x8664-opcode cmpb (((:imm8s :imm8) :insert-imm8s) (:acc :insert-nothing)) + #x3c nil nil) + (def-x8664-opcode rcmpb ((:acc :insert-nothing) ((:imm8s :imm8) :insert-imm8s)) + #x3c nil nil) + (def-x8664-opcode cmpb (((:imm8s :imm8) :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o370 #x00) + (def-x8664-opcode rcmpb ((:reg8 :insert-modrm-rm) ((:imm8s :imm8) :insert-imm8s)) + #x80 #o370 #x00) + (def-x8664-opcode cmpb (((:imm8s :imm8) :insert-imm8s) (:anymem :insert-memory)) + #x80 #o070 #x00) + (def-x8664-opcode rcmpb ((:anymem :insert-memory) ((:imm8s :imm8) :insert-imm8s)) + #x80 #o070 #x00) + + ;; cmps + (def-x8664-opcode cmpsq () + #xa7 nil #x48) + + (def-x8664-opcode cmpsl () + #xa7 nil nil) + + (def-x8664-opcode cmpsw () + #xa7 nil nil #x66) + + (def-x8664-opcode cmpsb () + #xa6 nil nil) + + ;; cmpxchg + (def-x8664-opcode cmpxchgq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fb1 #o300 #x48) + (def-x8664-opcode cmpxchgq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb1 #o000 #x48) + + (def-x8664-opcode cmpxchgl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fb1 #o300 #x00) + (def-x8664-opcode cmpxchgl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb1 #o000 #x00) + + (def-x8664-opcode cmpxchgw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fb1 #o300 #x00 #x66) + (def-x8664-opcode cmpxchgw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb1 #o000 #x00 #x66) + + (def-x8664-opcode cmpxchgb ((:reg8 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fb0 #o300 #x00) + (def-x8664-opcode cmpxchgb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb0 #o000 #x00) + + ;; cpuid + (def-x8664-opcode cpuid () + #x0fa2 nil nil) + + ;; cqto + (def-x8664-opcode cqto () + #x99 nil #x48) + + ;; cwtd + (def-x8664-opcode cwtd () + #x99 nil nil #x66) + + ;; cwtl + (def-x8664-opcode cwtl () + #x98 nil nil) + + ;; dec (not the 1-byte form). This exists on x8664, but gas doesn't + ;; know that. + (def-x8664-opcode decq ((:reg64 :insert-modrm-rm)) + #xff #o310 #x48) + (def-x8664-opcode decq ((:anymem :insert-memory)) + #xff #o010 #x48) + + (def-x8664-opcode decl ((:reg32 :insert-modrm-rm)) + #xff #o310 #x00) + (def-x8664-opcode decl ((:anymem :insert-memory)) + #xff #o010 #x00) + + (def-x8664-opcode decw ((:reg16 :insert-modrm-rm)) + #xff #o310 #x00 #x66) + (def-x8664-opcode decw ((:anymem :insert-memory)) + #xff #o010 #x00 #x66) + + (def-x8664-opcode decb ((:reg8 :insert-modrm-rm)) + #xfe #o310 #x00) + (def-x8664-opcode decb ((:anymem :insert-memory)) + #xfe #o010 #x00) + + ;; div + (def-x8664-opcode divq ((:reg64 :insert-modrm-rm)) + #xf7 #o360 #x48) + (def-x8664-opcode divq ((:anymem :insert-memory)) + #xf7 #o060 #x48) + + (def-x8664-opcode divl ((:reg32 :insert-modrm-rm)) + #xf7 #o360 #x00) + (def-x8664-opcode divl ((:anymem :insert-memory)) + #xf7 #o060 #x00) + + (def-x8664-opcode divw ((:reg16 :insert-modrm-rm)) + #xf7 #o360 #x00 #x66) + (def-x8664-opcode divw ((:anymem :insert-memory)) + #xf7 #o060 #x00 #x66) + + (def-x8664-opcode divb ((:reg8 :insert-modrm-rm)) + #xf6 #o360 #x00) + (def-x8664-opcode divl ((:anymem :insert-memory)) + #xf6 #o060 #x00) + + ;; enter. + + (def-x8664-opcode enter ((:imm16 :insert-imm16) (:imm8 :insert-extra)) + #xc8 nil nil) + + ;; hlt + (def-x8664-opcode hlt () + #xf4 nil nil) + + ;; idiv. Note that GAS doesn't know about newer(?) idiv forms + (def-x8664-opcode idivq ((:reg64 :insert-modrm-rm)) + #xf7 #o370 #x48) + (def-x8664-opcode idivq ((:anymem :insert-memory)) + #xf7 #o070 #x48) + + (def-x8664-opcode idivl ((:reg32 :insert-modrm-rm)) + #xf7 #o370 #x00) + (def-x8664-opcode idivl ((:anymem :insert-memory)) + #xf7 #o070 #x00) + + (def-x8664-opcode idivw ((:reg16 :insert-modrm-rm)) + #xf7 #o370 #x00 #x66) + (def-x8664-opcode idivw ((:anymem :insert-memory)) + #xf7 #o070 #x00 #x66) + + (def-x8664-opcode idivb ((:reg8 :insert-modrm-rm)) + #xf6 #o370 #x00) + (def-x8664-opcode idivl ((:anymem :insert-memory)) + #xf6 #o070 #x00) + + ;; imul + (def-x8664-opcode imulq ((:reg64 :insert-modrm-rm)) + #xf7 #o350 #x48) + (def-x8664-opcode imulq ((:anymem :insert-memory)) + #xf7 #o050 #x48) + + (def-x8664-opcode imulq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x6b #o300 #x48) + (def-x8664-opcode imulq ((:imm8s :insert-imm8s) (:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x6b #o000 #x48) + (def-x8664-opcode imulq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x69 #o300 #x48) + (def-x8664-opcode imulq ((:imm32s :insert-imm32s) (:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x69 #o000 #x48) + (def-x8664-opcode imulq ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0faf #o300 #x48) + (def-x8664-opcode imulq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0faf #o000 #x48) + + + (def-x8664-opcode imull ((:reg32 :insert-modrm-rm)) + #xf7 #o350 #x00) + (def-x8664-opcode imull ((:anymem :insert-memory)) + #xf7 #o050 #x00) + + (def-x8664-opcode imull ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x6b #o300 #x00) + (def-x8664-opcode imull ((:imm8s :insert-imm8s) (:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x6b #o000 #x00) + (def-x8664-opcode imull ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x69 #o300 #x00) + (def-x8664-opcode imull ((:imm32s :insert-imm32s) (:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x69 #o000 #x00) + (def-x8664-opcode imull ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0faf #o300 #x00) + (def-x8664-opcode imull ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0faf #o000 #x00) + + (def-x8664-opcode imulw ((:reg16 :insert-modrm-rm)) + #xf7 #o350 #x00 #x66) + (def-x8664-opcode imulw ((:anymem :insert-memory)) + #xf7 #o050 #x00 #x66) + + (def-x8664-opcode imulw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x6b #o300 #x00 #x66) + (def-x8664-opcode imulw ((:imm8s :insert-imm8s) (:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x6b #o000 #x00 #x66) + (def-x8664-opcode imulw ((:imm32s :insert-imm32s) (:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x69 #o300 #x00 #x66) + (def-x8664-opcode imulw ((:imm32s :insert-imm32s) (:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x69 #o000 #x00 #x66) + (def-x8664-opcode imulw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0faf #o300 #x00 #x66) + (def-x8664-opcode imulw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0faf #o000 #x00 #x66) + + (def-x8664-opcode imulb ((:reg8 :insert-modrm-rm)) + #xf6 #o350 #x00) + (def-x8664-opcode imulb ((:anymem :insert-memory)) + #xf6 #o050 #x00) + + ;; inc (but not the one-byte form) is available on x86-64. + (def-x8664-opcode incq ((:reg64 :insert-modrm-rm)) + #xff #o300 #x48) + (def-x8664-opcode incq ((:anymem :insert-memory)) + #xff #o000 #x48) + + (def-x8664-opcode incl ((:reg32 :insert-modrm-rm)) + #xff #o300 #x00) + (def-x8664-opcode incl ((:anymem :insert-memory)) + #xff #o000 #x00) + + (def-x8664-opcode incw ((:reg16 :insert-modrm-rm)) + #xff #o300 #x00 #x66) + (def-x8664-opcode incw ((:anymem :insert-memory)) + #xff #o000 #x00 #x66) + + (def-x8664-opcode incb ((:reg8 :insert-modrm-rm)) + #xfe #o300 #x00) + (def-x8664-opcode incb ((:anymem :insert-memory)) + #xfe #o000 #x00) + + ;; int. See also UUOs. + (def-x8664-opcode int ((:imm8 :insert-imm8-for-int)) + #xcd nil nil) + + ;; Jcc. Generate the short form here; maybe relax later. + (def-x8664-opcode (jcc :jump) ((:imm8 :insert-cc) (:label :insert-label)) + #x70 nil nil) + (def-x8664-opcode (jcc.pt :jump) ((:imm8 :insert-cc) (:label :insert-label)) + #x70 nil nil #x3e) + (def-x8664-opcode (jcc.pn :jump) ((:imm8 :insert-cc) (:label :insert-label)) + #x70 nil nil #x2e) + + (def-x8664-opcode (jo :jump) ((:label :insert-label)) + #x70 nil nil) + (def-x8664-opcode (jo.pt :jump) ((:label :insert-label)) + #x70 nil nil #x3e) + (def-x8664-opcode (jo.pn :jump) ((:label :insert-label)) + #x70 nil nil #x2e) + (def-x8664-opcode (jno :jump) ((:label :insert-label)) + #x71 nil nil) + (def-x8664-opcode (jno.pt :jump) ((:label :insert-label)) + #x71 nil nil #x3e) + (def-x8664-opcode (jno.pn :jump) ((:label :insert-label)) + #x71 nil nil #x2e) + (def-x8664-opcode (jb :jump) ((:label :insert-label)) + #x72 nil nil) + (def-x8664-opcode (jb.pt :jump) ((:label :insert-label)) + #x72 nil nil #x3e) + (def-x8664-opcode (jb.pn :jump) ((:label :insert-label)) + #x72 nil nil #x2e) + (def-x8664-opcode (jae :jump) ((:label :insert-label)) + #x73 nil nil) + (def-x8664-opcode (jae.pt :jump) ((:label :insert-label)) + #x73 nil nil #x3e) + (def-x8664-opcode (jae.pn :jump) ((:label :insert-label)) + #x73 nil nil #x2e) + (def-x8664-opcode (je :jump) ((:label :insert-label)) + #x74 nil nil) + (def-x8664-opcode (je.pt :jump) ((:label :insert-label)) + #x74 nil nil #x3e) + (def-x8664-opcode (je.pn :jump) ((:label :insert-label)) + #x74 nil nil #x2e) + (def-x8664-opcode (jz :jump) ((:label :insert-label)) + #x74 nil nil) + (def-x8664-opcode (jz.pt :jump) ((:label :insert-label)) + #x74 nil nil #x3e) + (def-x8664-opcode (jz.pn :jump) ((:label :insert-label)) + #x74 nil nil #x2e) + (def-x8664-opcode (jne :jump) ((:label :insert-label)) + #x75 nil nil) + (def-x8664-opcode (jne.pt :jump) ((:label :insert-label)) + #x75 nil nil #x3e) + (def-x8664-opcode (jne.pn :jump) ((:label :insert-label)) + #x75 nil nil #x2e) + (def-x8664-opcode (jnz :jump) ((:label :insert-label)) + #x75 nil nil) + (def-x8664-opcode (jnz.pt :jump) ((:label :insert-label)) + #x75 nil nil #x3e) + (def-x8664-opcode (jnz.pn :jump) ((:label :insert-label)) + #x75 nil nil #x2e) + (def-x8664-opcode (jbe :jump) ((:label :insert-label)) + #x76 nil nil) + (def-x8664-opcode (jbe.pt :jump) ((:label :insert-label)) + #x76 nil nil #x3e) + (def-x8664-opcode (jbe.pn :jump) ((:label :insert-label)) + #x76 nil nil #x2e) + (def-x8664-opcode (ja :jump) ((:label :insert-label)) + #x77 nil nil) + (def-x8664-opcode (ja.pt :jump) ((:label :insert-label)) + #x77 nil nil #x3e) + (def-x8664-opcode (ja.pn :jump) ((:label :insert-label)) + #x77 nil nil #x2e) + (def-x8664-opcode (js :jump) ((:label :insert-label)) + #x78 nil nil) + (def-x8664-opcode (js.pt :jump) ((:label :insert-label)) + #x78 nil nil #x3e) + (def-x8664-opcode (js.pn :jump) ((:label :insert-label)) + #x78 nil nil #x2e) + (def-x8664-opcode (jns :jump) ((:label :insert-label)) + #x79 nil nil) + (def-x8664-opcode (jns.pt :jump) ((:label :insert-label)) + #x79 nil nil #x3e) + (def-x8664-opcode (jns.pn :jump) ((:label :insert-label)) + #x79 nil nil #x2e) + (def-x8664-opcode (jpe :jump) ((:label :insert-label)) + #x7a nil nil) + (def-x8664-opcode (jpe.pt :jump) ((:label :insert-label)) + #x7a nil nil #x3e) + (def-x8664-opcode (jpe.pn :jump) ((:label :insert-label)) + #x7a nil nil #x2e) + (def-x8664-opcode (jpo :jump) ((:label :insert-label)) + #x7b nil nil) + (def-x8664-opcode (jpo.pt :jump) ((:label :insert-label)) + #x7b nil nil #x3e) + (def-x8664-opcode (jpo.pn :jump) ((:label :insert-label)) + #x7b nil nil #x2e) + (def-x8664-opcode (jl :jump) ((:label :insert-label)) + #x7c nil nil) + (def-x8664-opcode (jl.pt :jump) ((:label :insert-label)) + #x7c nil nil #x3e) + (def-x8664-opcode (jl.pn :jump) ((:label :insert-label)) + #x7c nil nil #x2e) + (def-x8664-opcode (jge :jump) ((:label :insert-label)) + #x7d nil nil) + (def-x8664-opcode (jge.pt :jump) ((:label :insert-label)) + #x7d nil nil #x3e) + (def-x8664-opcode (jge.pn :jump) ((:label :insert-label)) + #x7d nil nil #x2e) + (def-x8664-opcode (jle :jump) ((:label :insert-label)) + #x7e nil nil) + (def-x8664-opcode (jle.pt :jump) ((:label :insert-label)) + #x7e nil nil #x3e) + (def-x8664-opcode (jle.pn :jump) ((:label :insert-label)) + #x7e nil nil #x2e) + (def-x8664-opcode (jg :jump) ((:label :insert-label)) + #x7f nil nil) + (def-x8664-opcode (jg.pt :jump) ((:label :insert-label)) + #x7f nil nil #x3e) + (def-x8664-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. + (def-x8664-opcode (jmp :jump) ((:label :insert-label)) + #xeb nil nil) + + (def-x8664-opcode jmp ((:reg64 :insert-modrm-rm)) + #xff #o340 #x0) + + (def-x8664-opcode jmp ((:anymem :insert-memory)) + #xff #o040 #x0) + + ;; lea + (def-x8664-opcode leaq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x8d 0 #x48) + + (def-x8664-opcode leal ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x8d 0 #x00) + + (def-x8664-opcode leaw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x8d 0 #x00 #x66) + + ;; leave + (def-x8664-opcode leave () + #xc9 nil nil) + + ;; lock + (def-x8664-opcode lock () + #xf0 nil nil) + + ;; lods + (def-x8664-opcode lodsq () + #xac nil #x48) + + (def-x8664-opcode lodsl () + #xac nil nil) + + ;; loop + (def-x8664-opcode loopq ((:label :insert-label)) + #xe2 nil #x48) + + (def-x8664-opcode loopl ((:label :insert-label)) + #xe2 nil nil) + + (def-x8664-opcode loopzq ((:label :insert-label)) + #xe1 nil #x48) + + (def-x8664-opcode loopzl ((:label :insert-label)) + #xe1 nil nil) + + (def-x8664-opcode loopnzq ((:label :insert-label)) + #xe0 nil #x48) + + (def-x8664-opcode loopnzl ((:label :insert-label)) + #xe0 nil nil) + + ;; mov, including the MMX/XMM variants. + (def-x8664-opcode movq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0f6f #o300 0) + (def-x8664-opcode movq ((:regmmx :insert-mmx-reg) (:anymem :insert-memory)) + #x0f7f #o0 0) + (def-x8664-opcode movq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0f6f #o0 0) + (def-x8664-opcode movq ((:regxmm :insert-xmm-reg) (:regxmm :insert-xmm-rm)) + #x0f7e #o300 0 #xf3) + (def-x8664-opcode movq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f7e #o000 0 #xf3) + (def-x8664-opcode movq ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0fd6 #o000 0 #x66) + + (def-x8664-opcode movq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x89 #o300 #x48) + (def-x8664-opcode movq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x8b #o0 #x48) + (def-x8664-opcode movq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x89 #o0 #x48) + (def-x8664-opcode movq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #xc7 #o300 #x48) + (def-x8664-opcode movq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xc7 #o000 #x48) + (def-x8664-opcode movq ((:imm64 :insert-imm64) (:reg64 :insert-opcode-reg)) + #xb8 nil #x48) + + (def-x8664-opcode movl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x89 #o300 #x00) + (def-x8664-opcode movl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x8b #o0 #x00) + (def-x8664-opcode movl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x89 #o0 #x00) + (def-x8664-opcode movl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #xc7 #o300 #x00) + (def-x8664-opcode movl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xc7 #o000 #x00) + + + (def-x8664-opcode movw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x89 #o300 #x00 #x66) + (def-x8664-opcode movw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x8b #o0 #x00 #x66) + (def-x8664-opcode movw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x89 #o0 #x00 #x66) + (def-x8664-opcode movw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #xc7 #o300 #x00 #x66) + (def-x8664-opcode movw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #xc7 #o000 #x00 #x66) + + (def-x8664-opcode movb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x88 #o300 0) + (def-x8664-opcode movb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x8a #o0 0) + (def-x8664-opcode movb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x88 #o0 0) + (def-x8664-opcode movb ((:imm8s :insert-imm8s) (:reg8 :insert-opcode-reg)) + #xb0 nil 0) + (def-x8664-opcode movb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #xc6 #o000 0) + + ;; movd + (def-x8664-opcode movd ((:reg64 :insert-modrm-rm) (:regmmx :insert-mmx-reg)) + #x0f6e #o300 #x48) + (def-x8664-opcode movd ((:reg32 :insert-modrm-rm) (:regmmx :insert-mmx-reg)) + #x0f6e #o300 0) + (def-x8664-opcode movd ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0f6e #o000 0) + (def-x8664-opcode movd ((:regmmx :insert-mmx-reg) (:reg64 :insert-modrm-rm)) + #x0f7e #o300 #x48) + (def-x8664-opcode movd ((:regmmx :insert-mmx-reg) (:reg32 :insert-modrm-rm)) + #x0f7e #o300 #x0) + (def-x8664-opcode movd ((:regmmx :insert-mmx-reg) (:anymem :insert-memory)) + #x0f7e #o000 #x0) + + (def-x8664-opcode movd ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f6e #o300 #x48 #x66) + (def-x8664-opcode movd ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f6e #o300 0 #x66) + (def-x8664-opcode movd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f6e #o000 0 #x66) + (def-x8664-opcode movd ((:regxmm :insert-xmm-reg) (:reg64 :insert-modrm-rm)) + #x0f7e #o300 #x48 #x66) + (def-x8664-opcode movd ((:regxmm :insert-xmm-reg) (:reg32 :insert-modrm-rm)) + #x0f7e #o300 #x0 #x66) + (def-x8664-opcode movd ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f7e #o000 #x0 #x66) + + ;; sign-extending mov + (def-x8664-opcode movsbl ((:reg8 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbe #o300 0) + (def-x8664-opcode movsbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbe #o000 0) + (def-x8664-opcode movsbw ((:reg8 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fbe #o300 0 #x66) + (def-x8664-opcode movsbw ((:anymem :insert-memory) (:reg16 :insert-modrm-rm)) + #x0fbe #o300 0 #x66) + (def-x8664-opcode movsbq ((:reg8 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbe #o300 #x48) + (def-x8664-opcode movsbq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbe #o000 #x48) + (def-x8664-opcode movswl ((:reg16 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbf #o300 0) + (def-x8664-opcode movswl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbf #o000 0) + (def-x8664-opcode movswq ((:reg16 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbf #o300 #x48) + (def-x8664-opcode movswq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbf #o000 #x48) + (def-x8664-opcode movslq ((:reg32 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x63 #o300 #x48) + (def-x8664-opcode movslq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x63 #o000 #x48) + + ;; zero-extending MOVs + (def-x8664-opcode movzbl ((:reg8 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fb6 #o300 0) + (def-x8664-opcode movzbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fb6 #o000 0) + (def-x8664-opcode movzbw ((:reg8 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0fb6 #o300 0 #x66) + (def-x8664-opcode movzbw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0fb6 #o300 0 #x66) + (def-x8664-opcode movzwl ((:reg16 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fb7 #o300 0) + (def-x8664-opcode movzwl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fb7 #o000 0) + (def-x8664-opcode movzbq ((:reg8 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fb6 #o300 #x48) + (def-x8664-opcode movzbq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fb6 #o000 #x48) + (def-x8664-opcode movzwq ((:reg16 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fb7 #o300 #x48) + (def-x8664-opcode movzwq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fb7 #o000 #x48) + + ;; mul + (def-x8664-opcode mulq ((:reg64 :insert-modrm-rm)) + #xf7 #o340 #x48) + (def-x8664-opcode mulq ((:anymem :insert-memory)) + #xf7 #o040 #x48) + + (def-x8664-opcode mull ((:reg32 :insert-modrm-rm)) + #xf7 #o340 #x00) + (def-x8664-opcode mull ((:anymem :insert-memory)) + #xf7 #o040 #x00) + + (def-x8664-opcode mulw ((:reg16 :insert-modrm-rm)) + #xf7 #o340 #x00 #x66) + (def-x8664-opcode mulw ((:anymem :insert-memory)) + #xf7 #o040 #x00 #x66) + + (def-x8664-opcode mulb ((:reg8 :insert-modrm-rm)) + #xf6 #o340 #x00) + (def-x8664-opcode mull ((:anymem :insert-memory)) + #xf6 #o040 #x00) + + ;; neg + (def-x8664-opcode negq ((:reg64 :insert-modrm-rm)) + #xf7 #o330 #x48) + (def-x8664-opcode negq ((:anymem :insert-memory)) + #xf7 #o030 #x48) + + (def-x8664-opcode negl ((:reg32 :insert-modrm-rm)) + #xf7 #o330 #x00) + (def-x8664-opcode negl ((:anymem :insert-memory)) + #xf7 #o030 #x00) + + (def-x8664-opcode negw ((:reg16 :insert-modrm-rm)) + #xf7 #o330 #x00 #x66) + (def-x8664-opcode negw ((:anymem :insert-memory)) + #xf7 #o030 #x00 #x66) + + (def-x8664-opcode negb ((:reg8 :insert-modrm-rm)) + #xf6 #o330 #x00) + (def-x8664-opcode negb ((:anymem :insert-memory)) + #xf6 #o030 #x00) + + ;; nop + (def-x8664-opcode nop () + #x90 nil nil) + + ;; not + (def-x8664-opcode notq ((:reg64 :insert-modrm-rm)) + #xf7 #o320 #x48) + (def-x8664-opcode notq ((:anymem :insert-memory)) + #xf7 #o020 #x48) + (def-x8664-opcode notl ((:reg32 :insert-modrm-rm)) + #xf7 #o320 #x0) + (def-x8664-opcode notl ((:anymem :insert-memory)) + #xf7 #o020 #x0) + (def-x8664-opcode notw ((:reg16 :insert-modrm-rm)) + #xf7 #o320 #x0 #x66) + (def-x8664-opcode notw ((:anymem :insert-memory)) + #xf7 #o020 #x0 #x66) + (def-x8664-opcode notb ((:reg8 :insert-modrm-rm)) + #xf6 #o320 #x0) + (def-x8664-opcode notb ((:anymem :insert-memory)) + #xf6 #o020 #x0) + + ;; or + (def-x8664-opcode orq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x09 #o300 #x48) + (def-x8664-opcode orq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0b #o000 #x48) + (def-x8664-opcode orq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x09 #x00 #x48) + (def-x8664-opcode orq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o310 #x48) + (def-x8664-opcode orq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x0d nil #x48) + (def-x8664-opcode orq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o310 #x48) + (def-x8664-opcode orq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o010 #x48) + (def-x8664-opcode orq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o010 #x48) + + (def-x8664-opcode orl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x09 #o300 #x00) + (def-x8664-opcode orl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0b #o000 #x00) + (def-x8664-opcode orl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x09 #x00 #x00) + (def-x8664-opcode orl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o310 #x00) + (def-x8664-opcode orl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x0d nil nil) + (def-x8664-opcode orl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o310 #x00) + (def-x8664-opcode orl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o010 #x00) + (def-x8664-opcode orl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o010 #x00) + + (def-x8664-opcode orw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x09 #o300 #x00 #x66) + (def-x8664-opcode orw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0b #o000 #x00 #x66) + (def-x8664-opcode orw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x09 #x00 #x00 #x66) + (def-x8664-opcode orw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o310 #x00 #x66) + (def-x8664-opcode orw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x0d nil nil #x66) + (def-x8664-opcode orw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o310 #x00 #x66) + (def-x8664-opcode orw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o010 #x00 #x66) + (def-x8664-opcode orw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o010 #x00 #x66) + + (def-x8664-opcode orb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x08 #o300 #x00) + (def-x8664-opcode orb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x0a #o000 #x00) + (def-x8664-opcode orb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x08 #x00 #x00) + (def-x8664-opcode orb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x0c nil nil) + (def-x8664-opcode orb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o310 #x00) + (def-x8664-opcode orb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o310 #x00) + (def-x8664-opcode orb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o010 #x00) + + ;; pop + (def-x8664-opcode popq ((:reg64 :insert-opcode-reg)) + #x58 nil #x0) + (def-x8664-opcode popq ((:anymem :insert-memory)) + #x8f #o000 #x0) + (def-x8664-opcode popw ((:reg16 :insert-opcode-reg)) + #x58 nil #x0 #x66) + (def-x8664-opcode popw ((:anymem :insert-memory)) + #x8f #o000 #x0 #x66) + + ;; popf + (def-x8664-opcode popfq () + #x9d nil #x48) + (def-x8664-opcode popfl () + #x9d nil nil) + + ;; push . It's not clear how "pushw $imm16" is encoded. + (def-x8664-opcode pushq ((:reg64 :insert-opcode-reg)) + #x50 nil #x0) + (def-x8664-opcode pushq ((:anymem :insert-memory)) + #xff #o060 #x0) + (def-x8664-opcode pushq ((:imm8s :insert-imm8s)) + #x6a nil nil) + (def-x8664-opcode pushq ((:imm32s :insert-imm32s)) + #x68 nil nil) + + (def-x8664-opcode pushw ((:reg16 :insert-opcode-reg)) + #x50 nil 0 #x66) + (def-x8664-opcode pushw ((:anymem :insert-memory)) + #xff #o060 #x0 #x66) + + ;; pushf + (def-x8664-opcode pushfq () + #x9c nil nil) + (def-x8664-opcode pushfw () + #x9c nil nil #x66) + + ;; rcl. Note that the :ShiftCount operand type only matches %cl. + (def-x8664-opcode rclq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o320 #x48) + (def-x8664-opcode rclq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o020 #x48) + (def-x8664-opcode rclq ((:reg64 :insert-modrm-rm)) + #xd1 #o320 #x48) + (def-x8664-opcode rclq ((:anymem :insert-memory)) + #xd1 #o020 #x48) + (def-x8664-opcode rclq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o320 #x48) + (def-x8664-opcode rclq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o320 #x48) + + (def-x8664-opcode rcll ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o320 #x0) + (def-x8664-opcode rcll ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o020 #x0) + (def-x8664-opcode rcll ((:reg32 :insert-modrm-rm)) + #xd1 #o320 #x0) + (def-x8664-opcode rcll ((:anymem :insert-memory)) + #xd1 #o020 #x0) + (def-x8664-opcode rcll ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o320 #x0) + (def-x8664-opcode rcll ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o320 #x0) + + (def-x8664-opcode rclw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o320 #x0 #x66) + (def-x8664-opcode rclw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o020 #x0 #x66) + (def-x8664-opcode rclw ((:reg16 :insert-modrm-rm)) + #xd1 #o320 #x0 #x66) + (def-x8664-opcode rclw ((:anymem :insert-memory)) + #xd1 #o020 #x0 #x66) + (def-x8664-opcode rclw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o320 #x0 #x66) + (def-x8664-opcode rclw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o320 #x0 #x66) + + (def-x8664-opcode rclb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o320 #x0) + (def-x8664-opcode rclb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o020 #x0) + (def-x8664-opcode rclb ((:reg8 :insert-modrm-rm)) + #xd0 #o320 #x0) + (def-x8664-opcode rclb ((:anymem :insert-memory)) + #xd0 #o020 #x0) + (def-x8664-opcode rclb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o320 #x0) + (def-x8664-opcode rclb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o320 #x0) + + ;; rcr + (def-x8664-opcode rcrq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o330 #x48) + (def-x8664-opcode rcrq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o030 #x48) + (def-x8664-opcode rcrq ((:reg64 :insert-modrm-rm)) + #xd1 #o330 #x48) + (def-x8664-opcode rcrq ((:anymem :insert-memory)) + #xd1 #o030 #x48) + (def-x8664-opcode rcrq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o330 #x48) + (def-x8664-opcode rcrq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o330 #x48) + + (def-x8664-opcode rcrl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o330 #x0) + (def-x8664-opcode rcrl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o030 #x0) + (def-x8664-opcode rcrl ((:reg32 :insert-modrm-rm)) + #xd1 #o330 #x0) + (def-x8664-opcode rcrl ((:anymem :insert-memory)) + #xd1 #o030 #x0) + (def-x8664-opcode rcrl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o330 #x0) + (def-x8664-opcode rcrl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o330 #x0) + + (def-x8664-opcode rcrw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o330 #x0 #x66) + (def-x8664-opcode rcrw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o030 #x0 #x66) + (def-x8664-opcode rcrw ((:reg16 :insert-modrm-rm)) + #xd1 #o330 #x0 #x66) + (def-x8664-opcode rcrw ((:anymem :insert-memory)) + #xd1 #o030 #x0 #x66) + (def-x8664-opcode rcrw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o330 #x0 #x66) + (def-x8664-opcode rcrw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o330 #x0 #x66) + + (def-x8664-opcode rcrb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o330 #x0) + (def-x8664-opcode rcrb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o030 #x0) + (def-x8664-opcode rcrb ((:reg8 :insert-modrm-rm)) + #xd0 #o330 #x0) + (def-x8664-opcode rcrb ((:anymem :insert-memory)) + #xd0 #o030 #x0) + (def-x8664-opcode rcrb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o330 #x0) + (def-x8664-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-x8664-opcode repe () + #xf3 nil nil) + + (def-x8664-opcode repne () + #xf2 nil nil) + + ;; ret + (def-x8664-opcode ret () + #xc3 nil nil) + + (def-x8664-opcode ret ((:imm16 :insert-imm16)) + #xc2 nil nil) + + ;; rol + (def-x8664-opcode rolq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o300 #x48) + (def-x8664-opcode rolq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o000 #x48) + (def-x8664-opcode rolq ((:reg64 :insert-modrm-rm)) + #xd1 #o300 #x48) + (def-x8664-opcode rolq ((:anymem :insert-memory)) + #xd1 #o000 #x48) + (def-x8664-opcode rolq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o300 #x48) + (def-x8664-opcode rolq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o300 #x48) + + (def-x8664-opcode roll ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o300 #x0) + (def-x8664-opcode roll ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o000 #x0) + (def-x8664-opcode roll ((:reg32 :insert-modrm-rm)) + #xd1 #o300 #x0) + (def-x8664-opcode roll ((:anymem :insert-memory)) + #xd1 #o000 #x0) + (def-x8664-opcode roll ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o300 #x0) + (def-x8664-opcode roll ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o300 #x0) + + (def-x8664-opcode rolw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o300 #x0 #x66) + (def-x8664-opcode rolw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o000 #x0 #x66) + (def-x8664-opcode rolw ((:reg16 :insert-modrm-rm)) + #xd1 #o300 #x0 #x66) + (def-x8664-opcode rolw ((:anymem :insert-memory)) + #xd1 #o000 #x0 #x66) + (def-x8664-opcode rolw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o300 #x0 #x66) + (def-x8664-opcode rolw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o300 #x0 #x66) + + (def-x8664-opcode rolb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o300 #x0) + (def-x8664-opcode rolb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o000 #x0) + (def-x8664-opcode rolb ((:reg8 :insert-modrm-rm)) + #xd0 #o300 #x0) + (def-x8664-opcode rolb ((:anymem :insert-memory)) + #xd0 #o000 #x0) + (def-x8664-opcode rolb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o300 #x0) + (def-x8664-opcode rolb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o300 #x0) + + ;; ror + (def-x8664-opcode rorq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o310 #x48) + (def-x8664-opcode rorq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o010 #x48) + (def-x8664-opcode rorq ((:reg64 :insert-modrm-rm)) + #xd1 #o310 #x48) + (def-x8664-opcode rorq ((:anymem :insert-memory)) + #xd1 #o010 #x48) + (def-x8664-opcode rorq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o310 #x48) + (def-x8664-opcode rorq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o310 #x48) + + (def-x8664-opcode rorl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o310 #x0) + (def-x8664-opcode rorl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o010 #x0) + (def-x8664-opcode rorl ((:reg32 :insert-modrm-rm)) + #xd1 #o310 #x0) + (def-x8664-opcode rorl ((:anymem :insert-memory)) + #xd1 #o010 #x0) + (def-x8664-opcode rorl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o310 #x0) + (def-x8664-opcode rorl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o310 #x0) + + (def-x8664-opcode rorw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o310 #x0 #x66) + (def-x8664-opcode rorw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o010 #x0 #x66) + (def-x8664-opcode rorw ((:reg16 :insert-modrm-rm)) + #xd1 #o310 #x0 #x66) + (def-x8664-opcode rorw ((:anymem :insert-memory)) + #xd1 #o010 #x0 #x66) + (def-x8664-opcode rorw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o310 #x0 #x66) + (def-x8664-opcode rorw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o310 #x0 #x66) + + (def-x8664-opcode rorb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o310 #x0) + (def-x8664-opcode rorb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o010 #x0) + (def-x8664-opcode rorb ((:reg8 :insert-modrm-rm)) + #xd0 #o310 #x0) + (def-x8664-opcode rorb ((:anymem :insert-memory)) + #xd0 #o010 #x0) + (def-x8664-opcode rorb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o310 #x0) + (def-x8664-opcode rorb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o310 #x0) + + ;; sar + (def-x8664-opcode sarq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o370 #x48) + (def-x8664-opcode sarq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o070 #x48) + (def-x8664-opcode sarq ((:reg64 :insert-modrm-rm)) + #xd1 #o370 #x48) + (def-x8664-opcode sarq ((:anymem :insert-memory)) + #xd1 #o070 #x48) + (def-x8664-opcode sarq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o370 #x48) + (def-x8664-opcode sarq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o370 #x48) + + (def-x8664-opcode sarl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o370 #x0) + (def-x8664-opcode sarl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o070 #x0) + (def-x8664-opcode sarl ((:reg32 :insert-modrm-rm)) + #xd1 #o370 #x0) + (def-x8664-opcode sarl ((:anymem :insert-memory)) + #xd1 #o070 #x0) + (def-x8664-opcode sarl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o370 #x0) + (def-x8664-opcode sarl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o370 #x0) + + (def-x8664-opcode sarw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o370 #x0 #x66) + (def-x8664-opcode sarw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o070 #x0 #x66) + (def-x8664-opcode sarw ((:reg16 :insert-modrm-rm)) + #xd1 #o370 #x0 #x66) + (def-x8664-opcode sarw ((:anymem :insert-memory)) + #xd1 #o070 #x0 #x66) + (def-x8664-opcode sarw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o370 #x0 #x66) + (def-x8664-opcode sarw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o370 #x0 #x66) + + (def-x8664-opcode sarb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o370 #x0) + (def-x8664-opcode sarb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o070 #x0) + (def-x8664-opcode sarb ((:reg8 :insert-modrm-rm)) + #xd0 #o370 #x0) + (def-x8664-opcode sarb ((:anymem :insert-memory)) + #xd0 #o070 #x0) + (def-x8664-opcode sarb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o370 #x0) + (def-x8664-opcode sarb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o370 #x0) + + ;; sbb + (def-x8664-opcode sbbq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x19 #o300 #x48) + (def-x8664-opcode sbbq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x1b #o000 #x48) + (def-x8664-opcode sbbq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x19 #x00 #x48) + (def-x8664-opcode sbbq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o330 #x48) + (def-x8664-opcode sbbq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x1d nil #x48) + (def-x8664-opcode sbbq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o330 #x48) + (def-x8664-opcode sbbq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o030 #x48) + (def-x8664-opcode sbbq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o030 #x48) + + (def-x8664-opcode sbbl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x19 #o300 #x00) + (def-x8664-opcode sbbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x1b #o000 #x00) + (def-x8664-opcode sbbl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x19 #x00 #x00) + (def-x8664-opcode sbbl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o330 #x00) + (def-x8664-opcode sbbl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x1d nil nil) + (def-x8664-opcode sbbl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o330 #x00) + (def-x8664-opcode sbbl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o030 #x00) + (def-x8664-opcode sbbl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o030 #x00) + + (def-x8664-opcode sbbw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x19 #o300 #x00 #x66) + (def-x8664-opcode sbbw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x1b #o000 #x00 #x66) + (def-x8664-opcode sbbw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x19 #x00 #x00 #x66) + (def-x8664-opcode sbbw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o330 #x00 #x66) + (def-x8664-opcode sbbw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x1d nil nil #x66) + (def-x8664-opcode sbbw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o330 #x00 #x66) + (def-x8664-opcode sbbw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o030 #x00 #x66) + (def-x8664-opcode sbbw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o030 #x00 #x66) + + (def-x8664-opcode sbbb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x18 #o300 #x00) + (def-x8664-opcode sbbb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x1a #o000 #x00) + (def-x8664-opcode sbbb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x18 #x00 #x00) + (def-x8664-opcode sbbb ((:imm8 :insert-imm8) (:acc :insert-nothing)) + #x1c nil nil) + (def-x8664-opcode sbbb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o330 #x00) + (def-x8664-opcode sbbb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o330 #x00) + (def-x8664-opcode sbbb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o030 #x00) + + ;; scas + (def-x8664-opcode scasq () + #xaf nil #x48) + (def-x8664-opcode scasl () + #xaf nil nil) + (def-x8664-opcode scasw () + #xaf nil nil #x66) + (def-x8664-opcode scasb () + #xae nil nil) + + + ;; setcc + (def-x8664-opcode setcc ((:imm8 :insert-cc) (:reg8 :insert-modrm-rm)) + #x0f90 #o300 0) + (def-x8664-opcode seto ((:reg8 :insert-modrm-rm)) + #x0f90 #o300 0) + (def-x8664-opcode seto ((:anymem :insert-memory)) + #x0f90 #o000 0) + (def-x8664-opcode setno ((:reg8 :insert-modrm-rm)) + #x0f91 #o300 0) + (def-x8664-opcode setno ((:anymem :insert-memory)) + #x0f91 #o000 0) + (def-x8664-opcode setb ((:reg8 :insert-modrm-rm)) + #x0f92 #o300 0) + (def-x8664-opcode setb ((:anymem :insert-memory)) + #x0f92 #o000 0) + (def-x8664-opcode setc ((:reg8 :insert-modrm-rm)) + #x0f92 #o300 0) + (def-x8664-opcode setc ((:anymem :insert-memory)) + #x0f92 #o000 0) + (def-x8664-opcode setae ((:reg8 :insert-modrm-rm)) + #x0f93 #o300 0) + (def-x8664-opcode setae ((:anymem :insert-memory)) + #x0f93 #o000 0) + (def-x8664-opcode sete ((:reg8 :insert-modrm-rm)) + #x0f94 #o300 0) + (def-x8664-opcode sete ((:anymem :insert-memory)) + #x0f94 #o000 0) + (def-x8664-opcode setne ((:reg8 :insert-modrm-rm)) + #x0f95 #o300 0) + (def-x8664-opcode setne ((:anymem :insert-memory)) + #x0f95 #o000 0) + (def-x8664-opcode setbe ((:reg8 :insert-modrm-rm)) + #x0f96 #o300 0) + (def-x8664-opcode setbe ((:anymem :insert-memory)) + #x0f96 #o000 0) + (def-x8664-opcode seta ((:reg8 :insert-modrm-rm)) + #x0f97 #o300 0) + (def-x8664-opcode seta ((:anymem :insert-memory)) + #x0f97 #o000 0) + (def-x8664-opcode sets ((:reg8 :insert-modrm-rm)) + #x0f98 #o300 0) + (def-x8664-opcode sets ((:anymem :insert-memory)) + #x0f98 #o000 0) + (def-x8664-opcode setns ((:reg8 :insert-modrm-rm)) + #x0f99 #o300 0) + (def-x8664-opcode setns ((:anymem :insert-memory)) + #x0f99 #o000 0) + (def-x8664-opcode setpe ((:reg8 :insert-modrm-rm)) + #x0f9a #o300 0) + (def-x8664-opcode setpe ((:anymem :insert-memory)) + #x0f9a #o000 0) + (def-x8664-opcode setpo ((:reg8 :insert-modrm-rm)) + #x0f9b #o300 0) + (def-x8664-opcode setpo ((:anymem :insert-memory)) + #x0f9b #o000 0) + (def-x8664-opcode setl ((:reg8 :insert-modrm-rm)) + #x0f9c #o300 0) + (def-x8664-opcode setl ((:anymem :insert-memory)) + #x0f9c #o000 0) + (def-x8664-opcode setge ((:reg8 :insert-modrm-rm)) + #x0f9d #o300 0) + (def-x8664-opcode setge ((:anymem :insert-memory)) + #x0f9d #o000 0) + (def-x8664-opcode setle ((:reg8 :insert-modrm-rm)) + #x0f9e #o300 0) + (def-x8664-opcode setle ((:anymem :insert-memory)) + #x0f9e #o000 0) + (def-x8664-opcode setg ((:reg8 :insert-modrm-rm)) + #x0f9f #o300 0) + (def-x8664-opcode setg ((:anymem :insert-memory)) + #x0f9f #o000 0) + + ;; shl + (def-x8664-opcode shlq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o340 #x48) + (def-x8664-opcode shlq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o040 #x48) + (def-x8664-opcode shlq ((:reg64 :insert-modrm-rm)) + #xd1 #o340 #x48) + (def-x8664-opcode shlq ((:anymem :insert-memory)) + #xd1 #o040 #x48) + (def-x8664-opcode shlq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o340 #x48) + (def-x8664-opcode shlq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o340 #x48) + + (def-x8664-opcode shll ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o340 #x0) + (def-x8664-opcode shll ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o040 #x0) + (def-x8664-opcode shll ((:reg32 :insert-modrm-rm)) + #xd1 #o340 #x0) + (def-x8664-opcode shll ((:anymem :insert-memory)) + #xd1 #o040 #x0) + (def-x8664-opcode shll ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o340 #x0) + (def-x8664-opcode shll ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o340 #x0) + + (def-x8664-opcode shlw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o340 #x0 #x66) + (def-x8664-opcode shlw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o040 #x0 #x66) + (def-x8664-opcode shlw ((:reg16 :insert-modrm-rm)) + #xd1 #o340 #x0 #x66) + (def-x8664-opcode shlw ((:anymem :insert-memory)) + #xd1 #o040 #x0 #x66) + (def-x8664-opcode shlw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o340 #x0 #x66) + (def-x8664-opcode shlw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o340 #x0 #x66) + + (def-x8664-opcode shlb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o340 #x0) + (def-x8664-opcode shlb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o040 #x0) + (def-x8664-opcode shlb ((:reg8 :insert-modrm-rm)) + #xd0 #o340 #x0) + (def-x8664-opcode shlb ((:anymem :insert-memory)) + #xd0 #o040 #x0) + (def-x8664-opcode shlb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o340 #x0) + (def-x8664-opcode shlb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o340 #x0) + + ;; shld + (def-x8664-opcode shldq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa4 #o300 #x48) + (def-x8664-opcode shldq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa4 #o000 #x48) + (def-x8664-opcode shldq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x48) + (def-x8664-opcode shldq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x48) + (def-x8664-opcode shldq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x48) + (def-x8664-opcode shldq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x48) + + (def-x8664-opcode shldl ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa4 #o300 #x0) + (def-x8664-opcode shldl ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa4 #o000 #x0) + (def-x8664-opcode shldl ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x0) + (def-x8664-opcode shldl ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0) + (def-x8664-opcode shldl ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x0) + (def-x8664-opcode shldl ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0) + + (def-x8664-opcode shldw ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa4 #o300 #x0 #x66) + (def-x8664-opcode shldw ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa4 #o000 #x0 #x66) + (def-x8664-opcode shldw ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x0 #x66) + (def-x8664-opcode shldw ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0 #x66) + (def-x8664-opcode shldw ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x0 #x66) + (def-x8664-opcode shldw ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0 #x66) + + ;; shr + (def-x8664-opcode shrq ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o350 #x48) + (def-x8664-opcode shrq ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o050 #x48) + (def-x8664-opcode shrq ((:reg64 :insert-modrm-rm)) + #xd1 #o350 #x48) + (def-x8664-opcode shrq ((:anymem :insert-memory)) + #xd1 #o050 #x48) + (def-x8664-opcode shrq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o350 #x48) + (def-x8664-opcode shrq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o350 #x48) + + (def-x8664-opcode shrl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o350 #x0) + (def-x8664-opcode shrl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o050 #x0) + (def-x8664-opcode shrl ((:reg32 :insert-modrm-rm)) + #xd1 #o350 #x0) + (def-x8664-opcode shrl ((:anymem :insert-memory)) + #xd1 #o050 #x0) + (def-x8664-opcode shrl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o350 #x0) + (def-x8664-opcode shrl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o350 #x0) + + (def-x8664-opcode shrw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o350 #x0 #x66) + (def-x8664-opcode shrw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o050 #x0 #x66) + (def-x8664-opcode shrw ((:reg16 :insert-modrm-rm)) + #xd1 #o350 #x0 #x66) + (def-x8664-opcode shrw ((:anymem :insert-memory)) + #xd1 #o050 #x0 #x66) + (def-x8664-opcode shrw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o350 #x0 #x66) + (def-x8664-opcode shrw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o350 #x0 #x66) + + (def-x8664-opcode shrb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o350 #x0) + (def-x8664-opcode shrb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o050 #x0) + (def-x8664-opcode shrb ((:reg8 :insert-modrm-rm)) + #xd0 #o350 #x0) + (def-x8664-opcode shrb ((:anymem :insert-memory)) + #xd0 #o050 #x0) + (def-x8664-opcode shrb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o350 #x0) + (def-x8664-opcode shrb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o350 #x0) + + ;; shrd + (def-x8664-opcode shrdq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fac #o300 #x48) + (def-x8664-opcode shrdq ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fac #o000 #x48) + (def-x8664-opcode shrdq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x48) + (def-x8664-opcode shrdq ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x48) + (def-x8664-opcode shrdq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x48) + (def-x8664-opcode shrdq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x48) + + (def-x8664-opcode shrdl ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fac #o300 #x0) + (def-x8664-opcode shrdl ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fac #o000 #x0) + (def-x8664-opcode shrdl ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x0) + (def-x8664-opcode shrdl ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0) + (def-x8664-opcode shrdl ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x0) + (def-x8664-opcode shrdl ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0) + + (def-x8664-opcode shrdw ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fac #o300 #x0 #x66) + (def-x8664-opcode shrdw ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fac #o000 #x0 #x66) + (def-x8664-opcode shrdw ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x0 #x66) + (def-x8664-opcode shrdw ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0 #x66) + (def-x8664-opcode shrdw ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x0 #x66) + (def-x8664-opcode shrdw ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0 #x66) + + ;; stc + (def-x8664-opcode stc () + #xf9 nil nil) + + ;; std + (def-x8664-opcode std () + #xfd nil nil) + + ;; sub + (def-x8664-opcode subq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x29 #o300 #x48) + (def-x8664-opcode subq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x2b #o000 #x48) + (def-x8664-opcode subq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x29 #x00 #x48) + (def-x8664-opcode subq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o350 #x48) + (def-x8664-opcode subq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x2d nil #x48) + (def-x8664-opcode subq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o350 #x48) + (def-x8664-opcode subq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o050 #x48) + (def-x8664-opcode subq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o050 #x48) + + (def-x8664-opcode subl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x29 #o300 #x00) + (def-x8664-opcode subl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x2b #o000 #x00) + (def-x8664-opcode subl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x29 #x00 #x00) + (def-x8664-opcode subl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o350 #x00) + (def-x8664-opcode subl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x2d nil nil) + (def-x8664-opcode subl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o350 #x00) + (def-x8664-opcode subl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o050 #x00) + (def-x8664-opcode subl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o050 #x00) + + (def-x8664-opcode subw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x29 #o300 #x00 #x66) + (def-x8664-opcode subw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x2b #o000 #x00 #x66) + (def-x8664-opcode subw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x29 #x00 #x00 #x66) + (def-x8664-opcode subw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o350 #x00 #x66) + (def-x8664-opcode subw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x2d nil nil #x66) + (def-x8664-opcode subw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o350 #x00 #x66) + (def-x8664-opcode subw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o050 #x00 #x66) + (def-x8664-opcode subw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o050 #x00 #x66) + + (def-x8664-opcode subb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x28 #o300 #x00) + (def-x8664-opcode subb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x2a #o000 #x00) + (def-x8664-opcode subb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x2a #x00 #x00) + (def-x8664-opcode subb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x2c nil nil) + (def-x8664-opcode subb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o350 #x00) + (def-x8664-opcode subb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o350 #x00) + (def-x8664-opcode subb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o050 #x00) + + ;; syscall + (def-x8664-opcode syscall () + #x0f0f nil nil) + + ;; test + (def-x8664-opcode testq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x85 #o300 #x48) + (def-x8664-opcode testq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x85 #o000 #x48) + (def-x8664-opcode testq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x87 #o000 #x48) + (def-x8664-opcode testq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #xa9 nil #x48) + (def-x8664-opcode testq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #xf7 #o300 #x48) + (def-x8664-opcode testq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xf7 #o000 #x48) + + (def-x8664-opcode testl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x85 #o300 #x00) + (def-x8664-opcode testl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x85 #o000 #x00) + (def-x8664-opcode testl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x87 #o000 #x00) + (def-x8664-opcode testl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #xa9 nil #x00) + (def-x8664-opcode testl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #xf7 #o300 #x00) + (def-x8664-opcode testl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xf7 #o000 #x00) + + + (def-x8664-opcode testw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x85 #o300 #x00 #x66) + (def-x8664-opcode testw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x85 #o000 #x00 #x66) + (def-x8664-opcode testw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x87 #o000 #x00 #x66) + (def-x8664-opcode testw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #xa9 nil #x00 #x66) + (def-x8664-opcode testw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #xf7 #o300 #x00 #x66) + (def-x8664-opcode testw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #xf7 #o000 #x00 #x66) + + + (def-x8664-opcode testb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x84 #o300 #x00) + (def-x8664-opcode testb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x84 #o000 #x00) + (def-x8664-opcode testb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x86 #o000 #x00) + (def-x8664-opcode testb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #xa8 nil #x00) + (def-x8664-opcode testb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #xf6 #o300 #x00) + (def-x8664-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-x8664-opcode ud2a () + #x0f0b nil nil) + + (def-x8664-opcode ud2b () + #x0fb9 nil nil) + + ;; xadd + (def-x8664-opcode xaddq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fc1 #o300 #x48) + (def-x8664-opcode xaddq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc1 #o000 #x48) + + (def-x8664-opcode xaddl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fc1 #o300 #x00) + (def-x8664-opcode xaddl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc1 #o000 #x00) + + (def-x8664-opcode xaddw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fc1 #o300 #x00 #x66) + (def-x8664-opcode xaddw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc1 #o000 #x00 #x66) + + (def-x8664-opcode xaddb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x0fc0 #o300 #x00) + (def-x8664-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-x8664-opcode xchgq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x87 #o300 #x48) + (def-x8664-opcode xchgq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x87 #o000 #x48) + (def-x8664-opcode xchgq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x89 #o000 #x48) + + (def-x8664-opcode xchgl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x87 #o300 #x00) + (def-x8664-opcode xchgl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x87 #o000 #x00) + (def-x8664-opcode xchgl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x89 #o000 #x00) + + (def-x8664-opcode xchgw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x87 #o300 #x00 #x66) + (def-x8664-opcode xchgw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x87 #o000 #x00 #x66) + (def-x8664-opcode xchgw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x89 #o000 #x00 #x66) + + (def-x8664-opcode xchgl ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x86 #o300 #x00) + (def-x8664-opcode xchgl ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x86 #o000 #x00) + (def-x8664-opcode xchgl ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x88 #o000 #x00) + + ;; xlat + + (def-x8664-opcode xlatb () + #xd7 nil nil) + + ;; xor + (def-x8664-opcode xorq ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x31 #o300 #x48) + (def-x8664-opcode xorq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x33 #o000 #x48) + (def-x8664-opcode xorq ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x31 #x00 #x48) + (def-x8664-opcode xorq ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o360 #x48) + (def-x8664-opcode xorq ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x35 nil #x48) + (def-x8664-opcode xorq ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o360 #x48) + (def-x8664-opcode xorq ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o060 #x48) + (def-x8664-opcode xorq ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o060 #x48) + + (def-x8664-opcode xorl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x31 #o300 #x00) + (def-x8664-opcode xorl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x33 #o000 #x00) + (def-x8664-opcode xorl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x31 #x00 #x00) + (def-x8664-opcode xorl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o360 #x00) + (def-x8664-opcode xorl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x35 nil nil) + (def-x8664-opcode xorl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o360 #x00) + (def-x8664-opcode xorl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o060 #x00) + (def-x8664-opcode xorl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o060 #x00) + + (def-x8664-opcode xorw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x31 #o300 #x00 #x66) + (def-x8664-opcode xorw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x33 #o000 #x00 #x66) + (def-x8664-opcode xorw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x31 #x00 #x00 #x66) + (def-x8664-opcode xorw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o360 #x00 #x66) + (def-x8664-opcode xorw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x35 nil nil #x66) + (def-x8664-opcode xorw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o360 #x00 #x66) + (def-x8664-opcode xorw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o060 #x00 #x66) + (def-x8664-opcode xorw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o060 #x00 #x66) + + (def-x8664-opcode xorb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x30 #o300 #x00) + (def-x8664-opcode xorb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x32 #o000 #x00) + (def-x8664-opcode xorb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x30 #x00 #x00) + (def-x8664-opcode xorb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x34 nil nil) + (def-x8664-opcode xorb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o360 #x00) + (def-x8664-opcode xorb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o360 #x00) + (def-x8664-opcode xorb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o060 #x00) + + ;; fxsave + (def-x8664-opcode fxsaveq ((:anymem :insert-memory)) + #x0fae #o000 0) + + ;; fxrstor + (def-x8664-opcode fxrstor ((:anymem :insert-memory)) + #x0fae #o010 0) + + ;; clflush + (def-x8664-opcode clflush ((:anymem :insert-memory)) + #x0fae #o070 0) + + ;; lfence + (def-x8664-opcode lfence () + #x0fae #xe8 nil) + + ;; mfence + (def-x8664-opcode mfence () + #x0fae #xf0 nil) + + ;; pause + (def-x8664-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-x8664-opcode emms () + #x0f77 nil nil) + + ;; addsd + (def-x8664-opcode addsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f58 #o000 #x0 #xf2) + (def-x8664-opcode addsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f58 #o300 #x0 #xf2) + + ;; addss + (def-x8664-opcode addss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f58 #o000 #x0 #xf3) + (def-x8664-opcode addss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f58 #o300 #x0 #xf3) + + ;; subsd + (def-x8664-opcode subsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5c #o000 #x0 #xf2) + (def-x8664-opcode subsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5c #o300 #x0 #xf2) + + ;; subss + (def-x8664-opcode subss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5c #o000 #x0 #xf3) + (def-x8664-opcode subss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5c #o300 #x0 #xf3) + + ;; movapd + (def-x8664-opcode movapd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f28 #o300 #x0 #x66) + (def-x8664-opcode movapd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f28 #o000 #x0 #x66) + (def-x8664-opcode movapd ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f29 #o000 #x0 #x66) + + ;; mulsd + (def-x8664-opcode mulsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f59 #o000 #x0 #xf2) + (def-x8664-opcode mulsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f59 #o300 #x0 #xf2) + + ;; mulss + (def-x8664-opcode mulss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f59 #o000 #x0 #xf3) + (def-x8664-opcode mulss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f59 #o300 #x0 #xf3) + + ;; divsd + (def-x8664-opcode divsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5e #o000 #x0 #xf2) + (def-x8664-opcode divsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5e #o300 #x0 #xf2) + + ;; divss + (def-x8664-opcode divss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5e #o000 #x0 #xf3) + (def-x8664-opcode divss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5e #o300 #x0 #xf3) + + + ;; sqrtsd + (def-x8664-opcode sqrtsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f51 #o000 #x0 #xf2) + (def-x8664-opcode sqrtsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f51 #o300 #x0 #xf2) + + ;; sqrtss + (def-x8664-opcode sqrtss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f51 #o000 #x0 #xf3) + (def-x8664-opcode sqrtss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f51 #o300 #x0 #xf3) + + ;; comisd + (def-x8664-opcode comisd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2f #o000 #x0 #x66) + (def-x8664-opcode comisd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2f #o300 #x0 #x66) + + ;; ucomisd + (def-x8664-opcode ucomisd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2e #o000 #x0 #x66) + (def-x8664-opcode comisd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2e #o300 #x0 u#x66) + + + ;; comiss + (def-x8664-opcode comiss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2f #o000 #x0) + (def-x8664-opcode comiss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2f #o300 #x0) + + ;; ucomiss + (def-x8664-opcode ucomiss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2e #o000 #x0) + (def-x8664-opcode ucomiss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2e #o300 #x0) + + ;; movsd + (def-x8664-opcode movsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf2) + (def-x8664-opcode movsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf2) + (def-x8664-opcode movsd ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f11 #o000 #x0 #xf2) + + + + ;; movss + (def-x8664-opcode movss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf3) + (def-x8664-opcode movss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf3) + (def-x8664-opcode movss ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f11 #o000 #x0 #xf3) + + + ;;; cvtsd2si. This does rounding (as opposed to truncation). + (def-x8664-opcode cvtsd2siq ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2d #o300 #x48 #xf2) + (def-x8664-opcode cvtsd2siq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2d #o000 #x48 #xf2) + (def-x8664-opcode cvtsd2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2d #o300 #x00 #xf2) + (def-x8664-opcode cvtsd2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2d #o000 #x00 #xf2) + + ;;; cvtss2si. This does rounding (as opposed to truncation). + (def-x8664-opcode cvtss2siq ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2d #o300 #x48 #xf3) + (def-x8664-opcode cvtss2siq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2d #o000 #x48 #xf3) + (def-x8664-opcode cvtss2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2d #o300 #x00 #xf3) + (def-x8664-opcode cvtss2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2d #o000 #x00 #xf3) + + ;;; cvttsd2si. This does truncation (as opposed to rounding). + (def-x8664-opcode cvttsd2siq ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2c #o300 #x48 #xf2) + (def-x8664-opcode cvttsd2siq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2c #o000 #x48 #xf2) + (def-x8664-opcode cvttsd2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2c #o300 #x00 #xf2) + (def-x8664-opcode cvtsd2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2c #o000 #x00 #xf2) + + ;;; cvtss2si. This does rounding (as opposed to truncation). + (def-x8664-opcode cvttss2siq ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2c #o300 #x48 #xf3) + (def-x8664-opcode cvttss2siq ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2c #o000 #x48 #xf3) + (def-x8664-opcode cvttss2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2d #o300 #x00 #xf3) + (def-x8664-opcode cvttss2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2c #o000 #x00 #xf3) + + ;; cvtsi2sd + (def-x8664-opcode cvtsi2sdq ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x48 #xf2) + (def-x8664-opcode cvtsi2sdq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x48 #xf2) + (def-x8664-opcode cvtsi2sdl ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x00 #xf2) + (def-x8664-opcode cvtsi2sdl ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x00 #xf2) + + ;; cvtsd2ss + (def-x8664-opcode cvtsd2ss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5a #o300 #x0 #xf2) + (def-x8664-opcode cvtsd2ss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5a #o000 #x0 #xf2) + + ;; cvtsi2sd + (def-x8664-opcode cvtsi2sdq ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x48 #xf2) + (def-x8664-opcode cvtsi2sdq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x48 #xf2) + (def-x8664-opcode cvtsi2sdl ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x00 #xf2) + (def-x8664-opcode cvtsi2sdl ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x00 #xf2) + + ;; cvtsi2ss + (def-x8664-opcode cvtsi2ssq ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x48 #xf3) + (def-x8664-opcode cvtsi2ssq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x48 #xf3) + (def-x8664-opcode cvtsi2ssl ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x00 #xf3) + (def-x8664-opcode cvtsi2ssl ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x00 #xf3) + + ;;; cvtss2sd + (def-x8664-opcode cvtss2sd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5a #o300 #x0 #xf3) + (def-x8664-opcode cvtss2sd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5a #o000 #x0 #xf3) + + ;; pand + (def-x8664-opcode pand ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fdb #o300 #x0) + (def-x8664-opcode pand ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fdb #o000 #x0) + (def-x8664-opcode pand ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fef #o300 #x0 #x66) + (def-x8664-opcode pand ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fdb #o000 #x0 #x66) + + ;; pandn + (def-x8664-opcode pandn ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fdf #o300 #x0) + (def-x8664-opcode pandn ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fdf #o000 #x0) + (def-x8664-opcode pandn ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fdf #o300 #x0 #x66) + (def-x8664-opcode pandn ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fdf #o000 #x0 #x66) + + ;; por + (def-x8664-opcode por ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0feb #o300 #x0) + (def-x8664-opcode por ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0feb #o000 #x0) + (def-x8664-opcode por ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0feb #o300 #x0 #x66) + (def-x8664-opcode por ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0feb #o000 #x0 #x66) + + ;; pxor + (def-x8664-opcode pxor ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fef #o300 #x0) + (def-x8664-opcode pxor ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fef #o000 #x0) + (def-x8664-opcode pxor ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fef #o300 #x0 #x66) + (def-x8664-opcode pxor ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fef #o000 #x0 #x66) + + ;; psllq + (def-x8664-opcode psllq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0ff3 #o300 #x0) + (def-x8664-opcode psllq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0ff3 #o000 #x0) + (def-x8664-opcode psllq ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0ff3 #o300 #x0 #x66) + (def-x8664-opcode psllq ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0ff3 #o000 #x0 #x66) + (def-x8664-opcode psllq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o360 #o0 #x66) + + ;; psllw + + ;; pslld + + ;; pslldq + (def-x8664-opcode pslldq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o370 #x0 #x66) + + ;; psrlq + (def-x8664-opcode psrlq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fd3 #o300 #x0) + (def-x8664-opcode psrlq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fd3 #o000 #x0) + (def-x8664-opcode psrlq ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fd3 #o300 #x0 #x66) + (def-x8664-opcode psrlq ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fd3 #o000 #x0 #x66) + (def-x8664-opcode psrlq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o320 #o0 #x66) + + ;; psrld + + ;; psrldq + (def-x8664-opcode psrldq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o330 #x0 #x66) + + ;; psrlw + + ;;; End of list of useful mmx instructions + (def-x8664-opcode ldmxcsr ((:anymem :insert-memory)) + #x0fae #o020 nil) + + (def-x8664-opcode stmxcsr ((:anymem :insert-memory)) + #x0fae #o030 nil) + + ;; UUOs. Expect lots more, some of which may take pseudo-operands. + (def-x8664-opcode uuo-error-slot-unbound ((:reg64 :insert-opcode-reg4) + (:reg64 :insert-reg4-pseudo-rm-high) + (:reg64 :insert-reg4-pseudo-rm-low)) + #xcd70 0 nil) + + ;;; DON'T use #xcd8x: doing so will make Mach angry and confused. + + (def-x8664-opcode uuo-error-unbound ((:reg64 :insert-opcode-reg4)) + #xcd90 nil 0) + + (def-x8664-opcode uuo-error-udf ((:reg64 :insert-opcode-reg4)) + #xcda0 nil 0) + + (def-x8664-opcode uuo-error-reg-not-type ((:reg64 :insert-opcode-reg4) (:imm8 :insert-imm8)) + #xcdb0 nil 0) + + (def-x8664-opcode uuo-error-too-few-args () + #xcdc0 nil nil) + (def-x8664-opcode uuo-error-too-many-args () + #xcdc1 nil nil) + (def-x8664-opcode uuo-error-wrong-number-of-args () + #xcdc2 nil nil) + (def-x8664-opcode uuo-error-array-rank ((:reg64 :insert-reg4-pseudo-rm-high) + (:reg64 :insert-reg4-pseudo-rm-low)) + #xcdc3 0 nil) + + (def-x8664-opcode uuo-gc-trap () + #xcdc4 nil nil) + (def-x8664-opcode uuo-alloc () + #xcdc5 nil nil) + (def-x8664-opcode uuo-error-not-callable () + #xcdc6 nil nil) + (def-x8664-opcode uuo-error-udf-call () + #xcdc7 nil nil) + + (def-x8664-opcode uuo-error-vector-bounds ((:reg64 :insert-reg4-pseudo-rm-high) (:reg64 :insert-reg4-pseudo-rm-low)) + #xcdc8 0 nil) + + (def-x8664-opcode uuo-error-call-macro-or-special-operator () + #xcdc9 nil nil) + + (def-x8664-opcode uuo-error-debug-trap () + #xcdca nil nil) + + (def-x8664-opcode uuo-error-array-bounds ((:reg64 :insert-reg4-pseudo-rm-high) (:reg64 :insert-reg4-pseudo-rm-low)) + #xcdcb 0 nil) + + (def-x8664-opcode uuo-error-eep-unresolved ((:reg64 :insert-reg4-pseudo-rm-high) + (:reg64 :insert-reg4-pseudo-rm-low)) + #xcdcc 0 nil) + + (def-x8664-opcode uuo-error-debug-trap-with-string () + #xcdcd nil nil) + + (def-x8664-opcode uuo-error-reg-not-tag ((:reg64 :insert-opcode-reg4) (:imm8 :insert-imm8)) + #xcdd0 nil 0) + (def-x8664-opcode uuo-error-reg-not-list ((:reg64 :insert-opcode-reg4)) + #xcde0 nil 0) + (def-x8664-opcode uuo-error-reg-not-fixnum ((:reg64 :insert-opcode-reg4)) + #xcdf0 nil 0) + + )) + +(dotimes (i (length *x8664-opcode-templates*)) + (setf (x86-opcode-template-ordinal (svref *x8664-opcode-templates* i)) i)) + + + +(defparameter *x86-32-opcode-template-lists* + (make-hash-table :test #'equalp)) + + +(defparameter *x86-64-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)))))) + #+notyet + (setup-templates-hash + *x86-32-opcode-template-lists* + *x8632-opcode-templates*) + (setup-templates-hash + *x86-64-opcode-template-lists* + *x8664-opcode-templates*) + #+x8664-target + (when (fboundp 'ccl::fixup-x86-vinsn-templates) + (ccl::fixup-x86-vinsn-templates + (ccl::backend-p2-vinsn-templates ccl::*target-backend*) + *x86-64-opcode-template-lists*)) + t)) + +(defparameter *x86-opcode-template-lists* ()) + +(defvar *x8632-registers* (make-hash-table :test #'equalp)) +(defvar *x8664-registers* (make-hash-table :test #'equalp)) +(defvar *x86-registers* nil) + +(defparameter *x86-32-operand-insert-functions* + #(tbd)) + +(defparameter *x86-64-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)) + +(defvar *x86-operand-insert-functions* ()) + +(defun setup-x86-assembler (&optional (cpu :x86-64)) + (initialize-x86-opcode-templates) + (ecase cpu + (:x86-32 (setq *x86-opcode-template-lists* + *x86-32-opcode-template-lists* + *x86-registers* *x8632-registers* + *x86-operand-insert-functions* + *x86-32-operand-insert-functions* + )) + (:x86-64 (setq *x86-opcode-template-lists* + *x86-64-opcode-template-lists* + *x86-registers* *x8664-registers* + *x86-operand-insert-functions* + *x86-64-operand-insert-functions*))) + t) + +(setup-x86-assembler :x86-64) + + + +;;; 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 () + (flet ((hash-registers (vector hash 64p) + (dotimes (i (length vector)) + (let* ((entry (svref vector i))) + (if (or 64p (not (logtest (reg-entry-reg-flags entry) +regrex+))) + (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 (logtest +regrex+ (reg-entry-reg-flags entry)) + #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))) + +(defparameter *x8664-register-entries* + (flet ((register-entry (name) + (let* ((r (gethash name *x86-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 +x86-64-bit-register+ #x00) +(defconstant +x86-32-bit-register+ #x10) +(defconstant +x86-16-bit-register+ #x20) +(defconstant +x86-8-bit-register+ #x30) +(defconstant +x86-xmm-register-offset+ #x40) +(defconstant +x86-mmx-register-offset+ #x50) +(defconstant +x86-fpu-register-offset+ #x58) +(defconstant +x86-segment-register-offset+ #x60) + +(defun x86-segment-register (i) + (if (and (typep i 'unsigned-byte) + (< i 6)) + (svref *x8664-register-entries* (+ +x86-segment-register-offset+ i)))) + +(defun x86-xmm-register (i) + (if (typep i '(mod 16)) + (svref *x8664-register-entries* (+ +x86-xmm-register-offset+ i)))) + +(defun x86-mmx-register (i) + (if (typep i '(mod 8)) + (svref *x8664-register-entries* (+ +x86-mmx-register-offset+ i)))) + + +(defun gpr-ordinal (r) + (or + (etypecase r + ((mod 64) r) + ((or string symbol) + (let* ((entry (gethash r *x86-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) + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x86-8-bit-register+))) + +(defun x86-reg16 (r) + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x86-16-bit-register+))) + +(defun x86-reg32 (r) + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x86-32-bit-register+))) + +(defun x86-reg64 (r) + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x86-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) + (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))))))))))))))) + +(defun match-template (template parsed-operands) + (apply #'match-template-types template (mapcar #'x86-operand-type parsed-operands))) + + + +(provide "X86-ASM") Index: /branches/experimentation/later/source/compiler/X86/x86-backend.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x86-backend.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x86-backend.lisp (revision 8058) @@ -0,0 +1,372 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + (:%q (x86::encode-operand-type :reg64)) + (:%l (x86::encode-operand-type :reg32)) + (:%w (x86::encode-operand-type :reg16)) + (:%b (x86::encode-operand-type :reg8)) + (:%xmm (x86::encode-operand-type :regxmm)) + (:%mmx (x86::encode-operand-type :regmmx)) + (:@ (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)))))) + +(defun lookup-x86-opcode (form backend) + (when (consp form) + (let* ((name (string (car form))) + (templates (gethash name x86::*x86-opcode-template-lists*))) + (declare (fixnum node-size)) + (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) + (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) + (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) + (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) + (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) + (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))) + 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" 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" op)))))))) + (simplify-operand (op) + (cond ((atom op) + (simplify-simple-operand op)) + ((eq (car op) :@) + (cons :@ + (simplify-memory-operand (cdr op)))) + ((member (car op) + '(:% :%q :%l :%w :%b :$ :$1 :$b :$ub :$w :$l + :$ul :$q :%mmx :%xmm :%shift)) + (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/experimentation/later/source/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x86-disassemble.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x86-disassemble.lisp (revision 8058) @@ -0,0 +1,2819 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005, Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (format stream "~a" (x86-di-mnemonic xdi)))) + +(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 (the fixnum (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 (the fixnum (ash high 16)) low))) + +(defun x86-ds-next-u64 (ds) + (let* ((low (x86-ds-next-u32 ds)) + (high (x86-ds-next-u32 ds))) + (logior (the fixnum (ash high 32)) low))) + +(defun x86-ds-next-s64 (ds) + (let* ((low (x86-ds-next-u32 ds)) + (high (x86-ds-next-s32 ds))) + (logior (the fixnum (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 OpenMCL +;;; 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 seen 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 (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)) + (cond ((and (>= intop #x70) (< intop #x80)) + (setq stop nil) + (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 #xf) :%)) + (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 #xf) :%)))) + ((< intop #xb0) + (setf (x86-di-mnemonic instruction) + "uuo-error-udf" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%)))) + + ((< 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 #xf) :%)) + (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 #xf) :%)) + (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 #xf) :%)))) + (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 #xf) :%))))) + 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. + (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 6)))))) + (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) + x8664::*x8664-subprims* + :key #'subprimitive-info-offset))) + (when info (setf (x86::x86-memory-operand-disp op0) + (subprimitive-info-name info))))))) + + ))) + 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 unparse-x86-lap-operand ((x x86::x86-memory-operand) 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)) + (val nil)) + (if (and base + (eq (x86::x86-register-operand-entry base) + (if (x86-ds-mode-64 ds) + (x86::x86-reg64 13) + (x86::x86-reg32 6))) + (null index) + (or (eql scale 0) (null scale)) + (and (if (typep disp 'constant-x86-lap-expression) + (+ (x86-ds-entry-point ds) + (constant-x86-lap-expression-value disp)) + (unless (typep disp 'x86-lap-expression) + (setq val (if disp + (+ (x86-ds-entry-point ds) + disp))))) + (>= val (x86-ds-code-limit ds)))) + (let* ((diff (- val (x86-ds-code-limit ds))) + (constant (uvref (x86-ds-constants-vector ds) + (1+ (ash diff -3))))) + `(@ ',constant ,(unparse-x86-lap-operand base ds))) + (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 x86-print-disassembled-instruction (ds instruction seq) + (let* ((addr (x86-di-address instruction)) + (entry (x86-ds-entry-point ds))) + (when (x86-di-labeled instruction) + (format t "~&L~d~&" (- addr entry)) + (setq seq 0)) + (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 + (format t " ~a" (unparse-x86-lap-operand op0 ds)) + (when op1 + (format t " ~a" (unparse-x86-lap-operand op1 ds)) + (when op2 + (format t " ~a" (unparse-x86-lap-operand op2 ds)))))) + (format t ")") + (unless (zerop seq) ;(when (oddp seq) + (format t "~50t;[~d]" (- addr entry))) + (format t "~%") + (1+ seq))) + + +(defun x8664-disassemble-xfunction (xfunction &key (symbolic-names + x8664::*x8664-symbolic-register-names*) (collect-function #'x86-print-disassembled-instruction)) + (check-type xfunction xfunction) + (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*))) + (let* ((ds (make-x86-disassembly-state + :code-vector (uvref xfunction 0) + :constants-vector xfunction + :entry-point 7 + :code-pointer 0 ; for next-u32 below + :symbolic-names symbolic-names + :pending-labels (list 7))) + (blocks (x86-ds-blocks ds))) + (setf (x86-ds-code-limit ds) + (ash (x86-ds-next-u32 ds) 3)) + (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)))) + (let* ((seq 0)) + (do-dll-nodes (block blocks) + (do-dll-nodes (instruction (x86-dis-block-instructions block)) + (setq seq (funcall collect-function ds instruction seq))))))) + +#+x8664-target +(defun x8664-xdisassemble (function &optional (collect-function #'x86-print-disassembled-instruction )) + (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 x8664::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) + (x8664-disassemble-xfunction xfunction :collect-function collect-function)) + (declare (fixnum j k)) + (setf (uvref xfunction j) (uvref fv k))))) + +(defun disassemble-list (function) + (collect ((instructions)) + (x8664-xdisassemble + function + #'(lambda (ds instruction seq) + (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))))) + (instructions))) + + + + + + + + + + + Index: /branches/experimentation/later/source/compiler/X86/x86-lap.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x86-lap.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x86-lap.lisp (revision 8058) @@ -0,0 +1,1439 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005, Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + +(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* 15) +(defparameter *x86-lap-fixed-code-words* nil) +(defvar *x86-lap-macros* (make-hash-table :test #'equalp)) +(defvar *x86-lap-lfun-bits* 0) + + + +(defun x86-lap-macro-function (name) + (gethash (string name) #|(backend-lap-macros *target-backend*)|# + *x86-lap-macros*)) + +(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 *x86-lap-macros* #|(backend-lap-macros *x86-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))) + +;;; 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* ((r (typecase regname + (symbol (or (gethash (string regname) x86::*x86-registers*) + (if (eq regname :rcontext) + (svref x86::*x8664-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 x86::*x8664-register-entries*)) + (svref x86::*x8664-register-entries* val)))))) + (string (gethash regname x86::*x86-registers*)) + (fixnum (if (and (typep regname 'fixnum) + (>= regname 0) + (< regname (length x86::*x8664-register-entries*))) + (svref x86::*x8664-register-entries* regname)))))) + + (when r + (if (eq designator :%) + r + (let* ((regtype (x86::reg-entry-reg-type r))) + (unless (logtest regtype (x86::encode-operand-type :reg8 :reg16 :reg32 :reg64)) + (error "Designator ~a can't be used with register ~a" + designator (x86::reg-entry-reg-name r))) + (case designator + (:%b (x86::x86-reg8 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 + (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))))) + + +;;; 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 3 #|x8664::fixnumshift|#)) + (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" 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 "~& not expected in ~s" head form))))))))) + + + + +;;; Operand syntax: +;;; (% x) -> register +;;; ($ x) -> immediate +;;; (@ x) -> memory operand +;;; 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)))) + (x86::make-x86-immediate-operand :type type + :value expr)))) + ((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) (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)))))) + + + + + + +(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)) + (opcode-modifier (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-modifier :jump) opcode-modifier) + ;; 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) + (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))))) + +(defun x86-lap-directive (frag-list directive arg) + (if (eq directive :tra) + (progn + (finish-frag-for-align frag-list 3) + (x86-lap-directive frag-list :long `(:^ ,arg)) + (emit-x86-lap-label frag-list arg)) + (if (eq directive :fixed-constants) + (dolist (constant arg) + (ensure-x86-lap-constant-label constant)) + (if (eq directive :arglist) + (setq *x86-lap-lfun-bits* (encode-lambda-list arg)) + (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))))) + nil))))) + + +(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) + (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) + (if (typep (car form) 'keyword) + (destructuring-bind (op arg) form + (x86-lap-directive frag-list op arg)) + (case (car form) + (progn + (dolist (f (cdr form)) + (x86-lap-form f frag-list instruction))) + (let + (destructuring-bind (equates &body body) + (cdr form) + (x86-lap-equate-form equates frag-list instruction body))) + (t + (parse-x86-instruction form instruction) + (x86-generate-instruction-code frag-list instruction))))))))) + +(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 8)) + (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))))))))))))) + + +(defun frag-emit-nops (frag count) + (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) + (let* ((symbols (mapcar #'(lambda (x) + (let* ((name (car x))) + (or + (and name + (symbolp name) + (not (constant-symbol-p name)) + (or (not (gethash (string name) + x86::*x86-registers*)) + (error "Symbol ~s already names and 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) + (x86-lap-form form fraglist instruction))))) + +(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))) + (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))) + (declare (fixnum num-constants code-bytes code-words)) + (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))) + (%function-vector-to-function function-vector)))) + + + +(defun %define-x86-lap-function (name forms &optional (bits 0)) + (let* ((*x86-lap-labels* ()) + (*x86-lap-constants* ()) + (*x86-lap-fixed-code-words* nil) + (*x86-lap-lfun-bits* bits) + (end-code-tag (gensym)) + (entry-code-tag (gensym)) + (instruction (x86::make-x86-instruction)) + (frag-list (make-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) + (dolist (f forms) + (x86-lap-form f frag-list instruction)) + (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))) + + +(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)) + #-x86-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))))) + #+x86-target ; just shorthand for defun + (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))) Index: /branches/experimentation/later/source/compiler/X86/x86-lapmacros.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x86-lapmacros.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x86-lapmacros.lisp (revision 8058) @@ -0,0 +1,360 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005, Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 clrq (reg) + `(xorq (% ,reg) (% ,reg))) + +(defx86lapmacro set-nargs (n) + (if (eql n 0) + `(xorw (% nargs) (% nargs)) + `(movw ($ ',n) (% nargs)))) + +(defx86lapmacro check-nargs (min &optional (max min)) + (let* ((ok (gensym))) + (if (and max (= max min)) + `(progn + (rcmp (% nargs) ($ ',min)) + (je.pt ,ok) + (uuo-error-wrong-number-of-args) + ,ok) + (if (null max) + (unless (zerop min) + `(progn + (rcmp (% nargs) ($ ',min)) + (jae.pt ,ok) + (uuo-error-too-few-args) + ,ok)) + (if (zerop min) + `(progn + (rcmp (% nargs) ($ ',max)) + (jb.pt ,ok) + (uuo-error-too-many-args) + ,ok) + (let* ((sofar (gensym))) + `(progn + (rcmp (% nargs) ($ ',min)) + (jae.pt ,sofar) + (uuo-error-too-few-args) + ,sofar + (rcmp (% nargs) ($ ',max)) + (jbe.pt ,ok) + (uuo-error-too-many-args) + ,ok))))))) + + + +(defx86lapmacro extract-lisptag (node dest) + `(progn + (movb ($ x8664::tagmask) (%b ,dest)) + (andb (%b ,node) (%b ,dest)))) + +(defx86lapmacro extract-fulltag (node dest) + `(progn + (movb ($ x8664::fulltagmask) (%b ,dest)) + (andb (%b ,node) (%b ,dest)))) + +(defx86lapmacro extract-subtag (node dest) + `(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))) + `(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* ((ok (gensym))) + `(progn + (extract-typecode ,node ,immreg) + (cmpb ($ ,tag) (%b ,immreg)) + (je.pt ,ok) + (uuo-error-reg-not-tag (% ,node) ($ ,tag)) + ,ok))) + +(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))) + `(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. (That probably won't be +;;; true on x8632.) +(defx86lapmacro cmp-reg-to-nil (reg) + `(cmpb ($ (logand #xff x8664::nil-value)) (%b ,reg))) + + +(defx86lapmacro unbox-fixnum (src dest) + `(progn + (mov (% ,src) (% ,dest)) + (sar ($ x8664::fixnumshift) (% ,dest)))) + +(defx86lapmacro box-fixnum (src dest) + `(imulq ($ x8664::fixnumone) (% ,src) (% ,dest))) + + +(defx86lapmacro get-single-float (node dest) + `(progn + (movd (% ,node) (% ,dest)) + (psrlq ($ 32) (% ,dest)))) + + +;;; Note that this modifies the src argument. +(defx86lapmacro put-single-float (src node) + `(progn + (psllq ($ 32) (% ,src)) + (movd (% ,src) (% ,node)) + (movb ($ x8664::tag-single-float) (%b ,node)))) + +(defx86lapmacro get-double-float (src fpreg) + `(movsd (@ x8664::double-float.value (% ,src)) (% ,fpreg))) + +(defx86lapmacro put-double-float (fpreg dest) + `(movsd (% ,fpreg) (@ x8664::double-float.value (% ,dest)))) + + + +(defx86lapmacro getvheader (src dest) + `(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) + `(progn + (mov (% ,vheader) (% ,dest)) + (shr ($ x8664::num-subtag-bits) (% ,dest)))) + + +;;; "Length" is fixnum element-count. +(defx86lapmacro header-length (vheader dest) + `(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) + `(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) + `(progn + (unbox-fixnum ,int ,temp) + (cvtsi2sdq (% ,temp) (% ,double)))) + +(defx86lapmacro int-to-single (int temp single) + `(progn + (unbox-fixnum ,int ,temp) + (cvtsi2ssq (% ,temp) (% ,single)))) + +(defx86lapmacro ref-global (global reg) + `(movq (@ (+ x8664::nil-value ,(x8664::%kernel-global global))) (% ,reg))) + +(defx86lapmacro ref-global.l (global reg) + `(movl (@ (+ x8664::nil-value ,(x8664::%kernel-global global))) (%l ,reg))) + +(defx86lapmacro set-global (reg global) + `(movq (% ,reg) (@ (+ x8664::nil-value ,(x8664::%kernel-global global))))) + +(defx86lapmacro macptr-ptr (src dest) + `(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) + `(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) + `(movq (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector)) (% ,dest))) + +;;; Index is still a constant +(defx86lapmacro svset (vector index new) + `(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 () + `(progn + (pushq (% rbp)) + (movq (% rsp) (% rbp)))) + +(defx86lapmacro save-frame-variable-arg-count () + (let* ((push (gensym)) + (done (gensym))) + `(progn + (movzwl (% 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 () + `(add ($ '2) (% rsp))) + +;;; Return to caller. +(defx86lapmacro single-value-return (&optional (words-to-discard 0)) + (if (zerop words-to-discard) + `(ret) + `(ret ($ ,(* x8664::node-size words-to-discard))))) + +;;; Using *x8664-backend* here is wrong but expedient. +(defun x86-subprim-offset (name) + (let* ((info (find name (arch::target-subprims-table (backend-target-arch *x8664-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 call-subprim (name) + `(progn + (:talign 4) + (call (@ ,(x86-subprim-offset name))) + (recover-fn-from-rip))) + + +(defx86lapmacro %car (src dest) + `(movq (@ x8664::cons.car (% ,src)) (% ,dest))) + +(defx86lapmacro %cdr (src dest) + `(movq (@ x8664::cons.cdr (% ,src)) (% ,dest))) + +(defx86lapmacro stack-probe () + (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)) + `(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) + `(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) + `(progn + (load-constant ,name fname) + (set-nargs ,nargs) + (jmp (@ x8664::symbol.fcell (% fname))))) + +(defx86lapmacro push-argregs () + (let* ((done (gensym)) + (yz (gensym)) + (z (gensym))) + `(progn + (testw (% nargs) (% nargs)) + (je ,done) + (cmpw ($ '2) (% nargs)) + (je ,yz) + (jb ,z) + (push (% arg_x)) + ,yz + (push (% arg_y)) + ,z + (push (% arg_z)) + ,done))) + Index: /branches/experimentation/later/source/compiler/X86/x862.lisp =================================================================== --- /branches/experimentation/later/source/compiler/X86/x862.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/X86/x862.lisp (revision 8058) @@ -0,0 +1,9166 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2005, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "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* ()) + + + + +(defun x862-immediate-operand (x) + (if (eq (acode-operator x) (%nx1-operator immediate)) + (cadr x) + (compiler-bug "not an immediate: ~s" x))) + +(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-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 + (if (eq class :gpr) + (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))) + ($ (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 + (if (eq class :gpr) + (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)))) + ,@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-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-result-reg* x8664::arg_z) + + +(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 x8664::arg_z valreg) + (x862-stack-to-register seg ea x8664::arg_x) + (x862-lri seg x8664::arg_y 0) + (! call-subprim-3 x8664::arg_z (subprim-name->offset '.SPgvset) x8664::arg_x x8664::arg_y x8664::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 ($ x8664::arg_z)) + (result ($ x8664::arg_z))) + (x862-do-lexical-reference seg arg ea) + (x862-set-nargs seg 1) + (! ref-constant ($ x8664::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 (- x8664::word-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) + (*x862-target-num-arg-regs* (target-arch-case (:x8664 $numx8664argregs))) + (*x862-target-num-save-regs* (target-arch-case (: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 (:x8664 x8664-node-regs))) + (*backend-node-temps* (target-arch-case (:x8664 x8664-temp-node-regs))) + (*available-backend-node-temps* (target-arch-case (:x8664 x8664-temp-node-regs))) + (*backend-imm-temps* (target-arch-case (:x8664 x8664-imm-regs))) + (*available-backend-imm-temps* (target-arch-case (:x8664 x8664-imm-regs))) + (*backend-crf-temps* (target-arch-case (:x8664 x8664-cr-fields))) + (*available-backend-crf-temps* (target-arch-case (:x8664 x8664-cr-fields))) + (*backend-fp-temps* (target-arch-case (:x8664 x8664-temp-fp-regs))) + (*available-backend-fp-temps* (target-arch-case (: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-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*) + (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-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)) + debug-info) + (make-x86-lap-label end-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 + + (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))))) + (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) + (x86-lap-directive frag-list :quad 0))) + + (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (let* ((function-debugging-info (afunc-lfun-info afunc))) + (when (or function-debugging-info lambda-form *x862-record-symbols*) + (if lambda-form (setq function-debugging-info + (list* 'function-lambda-expression lambda-form function-debugging-info))) + (if *x862-record-symbols* + (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*) + function-debugging-info))) + (setq bits (logior (ash 1 $lfbits-symmap-bit) bits)) + (setq debug-info function-debugging-info))) + (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*)))) + (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) + (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) + (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))) + (x862-digest-symbols))))) + (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-x8664-functions #-x8664-target nil + #+x8664-target (eq *target-backend* + *host-backend*)) + (v (if native-x8664-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-x8664-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-digest-symbols () + (if *x862-recorded-symbols* + (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))) + (flet ((label-address (note 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))) + x8664::fulltag-function))) + (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)) (label-address startlab t sym)) + (setf (aref ptrs (incf i)) (label-address endlab nil sym)))))))) + +(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-reckless* (neq 0 (%ilogand2 $decl_unsafe decls)) + *x862-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls)))))) + + +(defun %x862-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 x862-partition-vars (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 + (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits)))) + 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))))) + (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 x862-allocate-global-registers (fcells vcells all-vars no-regs) + (if no-regs + (progn + (dolist (c fcells) (%rplacd c nil)) + (dolist (c vcells) (%rplacd c nil)) + (values 0 nil)) + (let* ((maybe (x862-partition-vars all-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 #'%x862-bigger-cdr-than) (cdr things)) + (n 0 (1+ n)) + (registers (target-arch-case (:x8664 + (list x8664::save0 x8664::save1 x8664::save2 x8664::save3)))) + (regno (pop registers) (pop registers)) + (constant-alist ())) + ((or (null things) (= n *x862-target-num-save-regs*)) + (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)) + (nx-set-var-bits var + (%ilogior (%ilogand (%ilognot $vrefmask) (nx-var-bits var)) + regno + (%ilsl $vbitreg 1)))))))))) + + + +;;; Vpush the last N non-volatile-registers. +(defun x862-save-nvrs (seg n) + (declare (fixnum n)) + (when (> n 0) + (setq *x862-compiler-register-save-label* (x862-emit-note seg :regsave)) + (with-x86-local-vinsn-macros (seg) + (let* ((mask (target-arch-case (:x8664 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)) + (when (and ea nregs) + (with-x86-local-vinsn-macros (seg) + (let* ((mask (target-arch-case (:x8664 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 (x862-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 (x862-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 (x862-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 (x862-assign-register-var rest)) + (progn + (x862-copy-register seg reg x8664::arg_z) + (x862-set-var-ea seg rest reg)) + (let* ((loc *x862-vstack*)) + (x862-vpush-register seg x8664::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 (x862-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 (x862-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 ($ x8664::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 (x862-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 (x862-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 ($ x8664::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 (x862-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 + (let* ((bits (nx-var-bits var))) + (declare (fixnum bits)) + (if (logbitp $vbitreg bits) + 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)))) + (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 ($ x8664::arg_y) yvar) reg-vars)) + (if (>= nargs 1) + (push (x862-vpush-arg-register seg ($ x8664::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* + (when rev-req-args + (! check-min-nargs min)) + (! check-max-nargs max)) + (if (> min $numx8664argregs) + (! save-lisp-context-in-frame) + (if (<= max $numx8664argregs) + (! 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 ($ x8664::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 ($ x8664::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 ($ x8664::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-form (seg vreg xfer form) + (if (nx-null form) + (x862-nil seg vreg xfer) + (if (nx-t form) + (x862-t seg vreg xfer) + (let* ((op nil) + (fn nil)) + (if (and (consp form) + (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq 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))) + (compiler-bug "x862-form ? ~s" form)))))) + +;;; dest is a float reg - form is acode +(defun x862-form-float (seg freg xfer form) + (declare (ignore xfer)) + (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 nil)) + (if (and (consp form) + (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form))))) + (apply fn seg freg nil (%cdr form)) + (compiler-bug "x862-form ? ~s" 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)) + +;;; Returns true iff lexical variable VAR isn't setq'ed in FORM. +;;; Punts a lot ... +(defun x862-var-not-set-by-form-p (var form) + (or (not (%ilogbitp $vbitsetq (nx-var-bits var))) + (x862-setqed-var-not-set-by-form-p var form))) + +(defun x862-setqed-var-not-set-by-form-p (var form) + (setq form (acode-unwrapped-form form)) + (or (atom form) + (x86-constant-form-p form) + (x862-lexical-reference-p form) + (let ((op (acode-operator form)) + (subforms nil)) + (if (eq op (%nx1-operator setq-lexical)) + (and (neq var (cadr form)) + (x862-setqed-var-not-set-by-form-p var (caddr form))) + (and (%ilogbitp operator-side-effect-free-bit op) + (flet ((not-set-in-formlist (formlist) + (dolist (subform formlist t) + (unless (x862-setqed-var-not-set-by-form-p var subform) (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))) + (x862-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 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))) + (! set-bigits-and-header-for-fixnum-overflow target (aref *backend-labels* (or labelno no-overflow))) + (! %allocate-uvector target) + (! set-bigits-after-fixnum-overflow target) + (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 x8664::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 x8664::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 ($ x8664::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* new)) + + +;;; 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-assign-register-var (v) + (let ((bits (nx-var-bits v))) + (when (%ilogbitp $vbitreg bits) + (%ilogand bits $vrefmask)))) + +(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) x8664::subtag-character)) + (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)))) + (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 ($ x8664::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 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) + (if (target-arch-case + + (:x8664 t)) + (! box-fixnum node-dest s32-src) + (let* ((arg_z ($ x8664::arg_z)) + (imm0 ($ x8664::imm0 :mode :s32))) + (x862-copy-register seg imm0 s32-src) + (! call-subprim (subprim-name->offset '.SPmakes32)) + (x862-copy-register seg node-dest arg_z))))) + +(defun x862-box-s64 (seg node-dest s64-src) + (with-x86-local-vinsn-macros (seg) + (if (target-arch-case + (: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 ($ x8664::arg_z)) + (imm0 (make-wired-lreg x8664::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) + (if (target-arch-case + + (:x8664 t)) + (! box-fixnum node-dest u32-src) + (let* ((arg_z ($ x8664::arg_z)) + (imm0 ($ x8664::imm0 :mode :u32))) + (x862-copy-register seg imm0 u32-src) + (! call-subprim (subprim-name->offset '.SPmakeu32)) + (x862-copy-register seg node-dest arg_z))))) + +(defun x862-box-u64 (seg node-dest u64-src) + (with-x86-local-vinsn-macros (seg) + (if (target-arch-case + + (: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 ($ x8664::arg_z)) + (imm0 ($ x8664::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-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 (eql vreg-class hard-reg-class-gpr) + (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) + (! 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))) + (cond ((eq 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) + (! single->node target fp-val))))) + (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) + (! box-fixnum target temp)))))) + (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 2))) + (! scale-32bit-misc-index idx-reg unscaled-idx)) + (cond ((eq 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) + (! single->node target fp-val))))) + (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) + (! box-fixnum 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-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 + (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-temps + () (word-index bitnum) + (if index-known-fixnum + (progn + (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6))) + (x862-lri seg bitnum (logand index-known-fixnum #x63))) + (! word-index-and-bitnum-from-index word-index bitnum unscaled-idx)) + (! ref-bit-vector-fixnum target bitnum src word-index)))))))) + (^))) + +;;; 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) + (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 x8664::arg_y index x8664::arg_z)) + (setq src (x862-one-untargeted-reg-form seg vector x8664::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) + (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 ($ x8664::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 ($ x8664::temp0) + i ($ x8664::arg_x) + j ($ x8664::arg_y) + new val-reg) + (values ($ x8664::temp0) ($ x8664::arg_x) ($ x8664::arg_y) ($ x8664::arg_z))) + (x862-four-untargeted-reg-forms seg + array ($ x8664::temp0) + i ($ x8664::arg_x) + j ($ x8664::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 ($ x8664::arg_y))) + (if constidx + (if needs-memoization + (x862-lri seg x8664::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) + (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 ($ x8664::temp0) new val-reg)) + (progn + (setq src ($ x8664::temp1) + unscaled-i ($ x8664::temp0) + unscaled-j ($ x8664::arg_x) + unscaled-k ($ x8664::arg_y)) + (x862-push-register + seg + (x862-one-untargeted-reg-form seg array ($ x8664::arg_z))) + (x862-four-targeted-reg-forms seg + i ($ x8664::temp0) + j ($ x8664::arg_x) + k ($ x8664::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 ($ x8664::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) + (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 ($ x8664::arg_z))) + (multiple-value-setq (src unscaled-i unscaled-j) + (x862-three-untargeted-reg-forms seg + array x8664::arg_x + i x8664::arg_y + j x8664::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) + (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 ($ x8664::arg_z))) + (multiple-value-setq (src unscaled-i unscaled-j unscaled-k) + (x862-four-untargeted-reg-forms seg + array x8664::temp0 + i x8664::arg_x + j x8664::arg_y + k x8664::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 x8664::arg_y index x8664::arg_z value (or vreg target))) + (multiple-value-setq (src target) + (x862-two-untargeted-reg-forms seg vector x8664::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 ((eq form *nx-nil*) + (arch::target-nil-value arch)) + ((eq form *nx-t*) + (+ (arch::target-nil-value arch) (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 x8664::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* + (! %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))))))) + +(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) x8664::arg_x) + (eql (hard-regspec-value unscaled-idx) x8664::arg_y) + (eql (hard-regspec-value val-reg) x8664::arg_z)) + (nx-error "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 + (with-imm-target (unboxed-val-reg) scaled-idx + (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 (+ (arch::target-misc-dfloat-offset arch) (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 + (if index-known-fixnum + (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (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 + (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-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (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 + (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-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) 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 + (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))) + (with-imm-temps () (word-index bit-number) + (if index-known-fixnum + (progn + (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6))) + (x862-lri seg bit-number (logand index-known-fixnum #x63))) + (! word-index-and-bitnum-from-index word-index bit-number unscaled-idx)) + (if constval + (if (zerop constval) + (! set-variable-bit-to-zero src word-index bit-number) + (! set-variable-bit-to-one src word-index bit-number)) + (progn + (! set-variable-bit-to-variable-value src word-index bit-number val-reg)))))))))) + (when (and vreg val-reg) (<- val-reg)) + (^)))) + + + +(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 ($ x8664::arg_x)) + (unscaled-idx ($ x8664::arg_y)) + (result-reg ($ x8664::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)) + (x862-three-targeted-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)))) + (when (and value (logbitp value *available-backend-imm-temps*)) + (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*))) + (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-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 (x862-lexical-reference-p (%car reg-args)) rest)) + (return nil)) + (flet ((independent-of-all-values (form) + (setq form (acode-unwrapped-form form)) + (or (x86-constant-form-p form) + (let* ((lexref (x862-lexical-reference-p form))) + (and lexref + (neq lexref rest) + (dolist (val rest-values t) + (unless (x862-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 (x862-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 (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 (x862-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 (x862-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 x8664::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)) + (<- x8664::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) + (! 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 x8664::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 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 ($ x8664::fname) (unless label-p ($ x8664::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 + (if (eq spread-p 0) + (! spread-lexpr) + (! spread-list)) + (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 ($ x8664::fname) ($ x8664::temp0)))) + (unless mvpass-label (compiler-bug "no label for mvpass")) + (if label-p + (x862-copy-register seg call-reg ($ x8664::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 x8664::temp0 x8664::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 ($ x8664::arg_z)) + (vsize (+ (length inherited-vars) + 5 ; %closure-code%, afunc + 1))) ; lfun-bits + (declare (list inherited-vars)) + (let* ((cell 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 + x8664::imm0 + (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function))) + (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) (target-arch-case (:x8664 x8664::fulltag-misc)))) + (! %allocate-uvector dest))) + (! init-nclosure x8664::arg_z) + (x862-store-immediate seg (x862-afunc-lfun-ref afunc) x8664::ra0) + (with-node-temps (x8664::arg_z) (t0 t1 t2 t3) + (do* ((func x8664::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 x8664::arg_y (ash (logior (ash 1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*)) + (! misc-set-c-node x8664::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 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-long-constant-p (form) + (setq form (acode-unwrapped-form form)) + (or (acode-fixnum-form-p form) + (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq form (%cadr form)) + (if (integerp form) + form)))) + + +(defun x86-side-effect-free-form-p (form) + (when (consp (setq form (acode-unwrapped-form form))) + (or (x86-constant-form-p form) + ;(eq (acode-operator form) (%nx1-operator bound-special-ref)) + (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 x8664::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) + (x862-three-targeted-reg-forms seg xform ($ x8664::arg_x) yform ($ x8664::arg_y) zform ($ x8664::arg_z)) + (if (eq 2 nregs) + (x862-two-targeted-reg-forms seg yform ($ x8664::arg_y) zform ($ x8664::arg_z)) + (x862-one-targeted-reg-form seg zform ($ x8664::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 :reserverd *x862-target-lcell-size* 0 nil) + (x862-new-vstack-lcell :reserverd *x862-target-lcell-size* 0 nil) + (setq *x862-vstack* (+ *x862-vstack* (* 2 *x862-target-node-size*)))) + (x862-formlist seg (car args) (cadr args)))) + + + + +;;; treat form as a 32-bit immediate value and load it into immreg. +;;; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars +;;; count, and we don't care about the integer's sign. + +(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-long-constant-p form))) + (if value + (progn + (unless (typep immreg 'lreg) + (setq immreg (make-unwired-lreg immreg :mode modeval))) + (x862-lri seg immreg value) + immreg) + (progn + (x862-one-targeted-reg-form seg form (make-wired-lreg x8664::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 + (progn + (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*)) + (progn + (setq vinsn + (if a-float + (! temp-push-double-float areg) + (! temp-push-unboxed-word areg))) + (setq *x862-cstack* (+ *x862-cstack* 16))))) + 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 + (progn + (setq vinsn (! vpop-single-float areg)) + (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*)) + (x862-adjust-vstack (- *x862-target-node-size*))) + (progn + (setq vinsn + (if a-float + (! temp-pop-double-float areg) + (! temp-pop-unboxed-word areg))) + (setq *x862-cstack* (- *x862-cstack* 16))))) + vinsn))) + +(defun x862-acc-reg-for (reg) + (with-x86-local-vinsn-macros (seg) + (let* ((class (hard-regspec-class reg)) + (mode (get-regspec-mode reg))) + (declare (fixnum class mode)) + (cond ((= class hard-reg-class-fpr) + (make-wired-lreg x8664::fp1 :class class :mode mode)) + ((= class hard-reg-class-gpr) + (if (= mode hard-reg-class-gpr-mode-node) + ($ x8664::arg_z) + (make-wired-lreg x8664::imm0 :mode mode))) + (t (compiler-bug "Unknown register class for reg ~s" 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. + (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) + (unless (typep areg 'lreg) + (warn "~s is not an lreg (1/2)" areg)) + (unless (typep breg 'lreg) + (warn "~s is not an lreg (2/2)" breg)) + (let* ((avar (x862-lexical-reference-p aform)) + (atriv (x862-trivial-p bform)) + (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform) + (if avar (x862-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 (x862-lexical-reference-p aform)) + (adest areg) + (bdest breg) + (atriv (x862-trivial-p bform)) + (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform) + (if avar (x862-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) + (unless (typep areg 'lreg) + (warn "~s is not an lreg (1/3)" areg)) + (unless (typep breg 'lreg) + (warn "~s is not an lreg (2/3)" breg)) + (unless (typep creg 'lreg) + (warn "~s is not an lreg (3/3)" creg)) + (let* ((atriv (or (null aform) + (and (x862-trivial-p bform) + (x862-trivial-p cform)))) + (btriv (or (null bform) + (x862-trivial-p cform))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (x862-lexical-reference-p aform))) + (and avar + (x862-var-not-set-by-form-p avar bform) + (x862-var-not-set-by-form-p avar cform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (x862-lexical-reference-p bform))) + (and bvar (x862-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) + (unless (typep areg 'lreg) + (warn "~s is not an lreg (1/4)" areg)) + (unless (typep breg 'lreg) + (warn "~s is not an lreg (2/4)" breg)) + (unless (typep creg 'lreg) + (warn "~s is not an lreg (3/4)" creg)) + (unless (typep dreg 'lreg) + (warn "~s is not an lreg (4/4)" dreg)) + (let* ((atriv (or (null aform) + (and (x862-trivial-p bform) + (x862-trivial-p cform) + (x862-trivial-p dform)))) + (btriv (or (null bform) + (and (x862-trivial-p cform) + (x862-trivial-p dform)))) + (ctriv (or (null cform) + (x862-trivial-p dform))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (x862-lexical-reference-p aform))) + (and avar + (x862-var-not-set-by-form-p avar bform) + (x862-var-not-set-by-form-p avar cform) + (x862-var-not-set-by-form-p avar dform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (x862-lexical-reference-p bform))) + (and bvar + (x862-var-not-set-by-form-p bvar cform) + (x862-var-not-set-by-form-p bvar dform)))))) + (cconst (and (not ctriv) + (or + (x86-side-effect-free-form-p cform) + (let ((cvar (x862-lexical-reference-p cform))) + (and cvar (x862-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))) + +(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg) + (with-x86-local-vinsn-macros (seg) + (let* ((atriv (or (null aform) + (and (x862-trivial-p bform) + (x862-trivial-p cform)))) + (btriv (or (null bform) + (x862-trivial-p cform))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (x862-lexical-reference-p aform))) + (and avar + (x862-var-not-set-by-form-p avar bform) + (x862-var-not-set-by-form-p avar cform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (x862-lexical-reference-p bform))) + (and bvar (x862-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* ((atriv (or (null aform) + (and (x862-trivial-p bform) + (x862-trivial-p cform) + (x862-trivial-p dform)))) + (btriv (or (null bform) + (and (x862-trivial-p cform) + (x862-trivial-p dform)))) + (ctriv (or (null cform) + (x862-trivial-p dform))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (x862-lexical-reference-p aform))) + (and avar + (x862-var-not-set-by-form-p avar bform) + (x862-var-not-set-by-form-p avar cform) + (x862-var-not-set-by-form-p avar dform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (x862-lexical-reference-p bform))) + (and bvar + (x862-var-not-set-by-form-p bvar cform) + (x862-var-not-set-by-form-p bvar dform)))))) + (cconst (and (not ctriv) + (or + (x86-side-effect-free-form-p cform) + (let ((cvar (x862-lexical-reference-p cform))) + (and cvar + (x862-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))) + + +(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 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) + (setq form (acode-unwrapped-form form)) + (when (acode-p form) + (if (or (eq form *nx-t*) + (eq form *nx-nil*) + (let* ((operator (acode-operator form))) + (member operator *x862-operator-supports-push*))) + form))) + +(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 x8664::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) x8664::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) + x8664::arg_z) + cr-bit + true-p + (or js32 is32))) + (multiple-value-bind (ireg jreg) (x862-two-untargeted-reg-forms seg i x8664::arg_y j x8664::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))) + (^ cr-bit true-p)) + (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))))))) + + +(defun x862-cr-bit-for-logical-comparison (cr-bit true-p) + (declare (fixnum cr-bit)) + (let* ((unsigned + (case cr-bit + (#.x86::x86-l-bits x86::x86-b-bits) + (#.x86::x86-le-bits x86::x86-be-bits ) + (#.x86::x86-g-bits x86::x86-a-bits) + (#.x86::x86-ge-bits x86::x86-ae-bits) + (t cr-bit)))) + (declare (fixnum unsigned)) + (if true-p + unsigned + (logxor unsigned 1)))) + +(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-logical-comparison cr-bit true-p)) + (! compare ireg jreg) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (! 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 ((eq constant *nx-nil*) + (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 (eq constant *nx-t*) + (! compare-to-t ireg) + (let* ((imm (x862-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 x8664::arg_z) cr-bit true-p 0)) + +(defun x862-test-reg-%izerop (seg vreg xfer reg cr-bit true-p zero) + (declare (fixnum reg 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 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 + (: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 + (! 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 + (: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 + (: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) + (when (acode-p val) + (with-x86-local-vinsn-macros (seg) + (let* ((op (acode-operator val))) + (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 val) nil)) + (x862-open-undo $undostkblk curstack) + (! stack-cons-list)) + (setq val x8664::arg_z)) + ((eq op (%nx1-operator list*)) + (let* ((arglist (%cadr val))) + (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 x8664::arg_z))) + ((eq op (%nx1-operator multiple-value-list)) + (x862-multiple-value-body seg (%cadr val)) + (x862-open-undo $undostkblk curstack) + (! stack-cons-list) + (setq val x8664::arg_z)) + ((eq op (%nx1-operator cons)) + (let* ((y ($ x8664::arg_y)) + (z ($ x8664::arg_z)) + (result ($ x8664::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 val 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 val))) + (if (nx-constant-form-p clear-form) + (progn + (x862-one-targeted-reg-form seg (%cadr val) ($ x8664::arg_z)) + (if (nx-null clear-form) + (! 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 ($ x8664::arg_z)) + (rclear ($ x8664::arg_y))) + (x862-two-targeted-reg-forms seg (%cadr val) 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 ($ x8664::arg_z))) + ((eq op (%nx1-operator make-list)) + (x862-two-targeted-reg-forms seg (%cadr val) ($ x8664::arg_y) (%caddr val) ($ x8664::arg_z)) + (x862-open-undo $undostkblk curstack) + (! make-stack-list) + (setq val x8664::arg_z)) + ((eq (%car val) (%nx1-operator vector)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-set-nargs seg (x862-formlist seg (%cadr val) nil)) + (! make-stack-vector)) + (x862-open-undo $undostkblk) + (setq val x8664::arg_z)) + ((eq op (%nx1-operator %gvector)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (arglist (%cadr val))) + (x862-set-nargs seg (x862-formlist seg (append (car arglist) (reverse (cadr arglist))) nil)) + (! make-stack-gvector)) + (x862-open-undo $undostkblk) + (setq val x8664::arg_z)) + ((eq op (%nx1-operator closed-function)) + (setq val (x862-make-closure seg (cadr val) t))) ; can't error + ((eq op (%nx1-operator %make-uvector)) + (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr val) + (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 ($ x8664::arg_x) subtag ($ x8664::arg_y) init ($ x8664::arg_z)) + (! stack-misc-alloc-init)) + (progn + (x862-two-targeted-reg-forms seg element-count ($ x8664::arg_y) subtag ($ x8664::arg_z)) + (! stack-misc-alloc))) + (if is-node + (x862-open-undo $undostkblk) + (x862-open-undo $undo-x86-c-frame)) + (setq val ($ x8664::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) + (nx-untyped-form 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)) + (x862-set-var-ea seg var puntval)) + (progn + (let* ((vloc *x862-vstack*) + (reg (let* ((r (x862-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 x8664::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 (x8664::allocptr) closed + (with-node-target (x8664::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 (x8664::allocptr) closed + (with-node-target (x8664::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 (eq (setq value (nx-untyped-form value)) *nx-nil*))) + (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 x8664::arg_z) + (x862-one-targeted-reg-form seg value ($ x8664::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) x8664::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 x8664::arg_z) + (x862-one-targeted-reg-form seg value ($ x8664::arg_z))) + (x862-store-immediate seg (x862-symbol-value-cell sym) ($ x8664::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))))) + + + + +(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 ($ x8664::arg_z)) + (progn + (if intval + (x862-lri seg x8664::imm0 intval) + (! deref-macptr x8664::imm0 x8664::arg_z)) + (values x8664::imm0 x8664::arg_z))) + (values (x862-macptr-arg-to-reg seg val ($ x8664::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))) + (! mem-set-c-constant-doubleword intval ptr-reg offval)))) + (t + (with-imm-target () (ptr-reg :address) + (with-imm-target (ptr-reg) (offsetreg :signed-natural) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ x8664::arg_z)) + (! fixnum->signed-natural offsetreg x8664::arg_z) + (! mem-set-constant-doubleword intval ptr-reg offsetreg))))) + (if for-value + (with-imm-target () (val-reg :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-imm-target (address) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (! mem-set-c-doubleword address ptr-reg offval)) + (if for-value + (<- node)))) + (t + (with-imm-target () (ptr-reg :address) + (with-imm-target (ptr-reg) (offset-reg :address) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ x8664::arg_z)) + (! fixnum->signed-natural offset-reg x8664::arg_z) + (! fixnum-add2 ptr-reg offset-reg) + (x862-push-register seg ptr-reg))) + (multiple-value-bind (address node) + (address-and-node-regs) + (with-imm-target (address) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (! 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 ($ x8664::arg_z)) + (if (eq size 8) + (if signed + (! gets64) + (! getu64)) + (! fixnum->signed-natural x8664::imm0 x8664::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-imm-target (ptr-reg) (offsetreg :signed-natural) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ x8664::arg_z)) + (! fixnum->signed-natural offsetreg x8664::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 thant 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) + (with-imm-target (x8664::imm0) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (case size + (8 (! mem-set-c-doubleword x8664::imm0 ptr-reg offval)) + (4 (! mem-set-c-fullword x8664::imm0 ptr-reg offval)) + (2 (! mem-set-c-halfword x8664::imm0 ptr-reg offval)) + (1 (! mem-set-c-byte x8664::imm0 ptr-reg offval)))) + (if for-value + (<- x8664::arg_z))) + (t + (with-imm-target () (ptr-reg :address) + (with-imm-target (ptr-reg) (offset-reg :address) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ x8664::arg_z)) + (! fixnum->signed-natural offset-reg x8664::arg_z) + (! fixnum-add2 ptr-reg offset-reg) + (x862-push-register seg ptr-reg))) + (val-to-argz-and-imm0) + (with-imm-target (x8664::imm0) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (case size + (8 (! mem-set-c-doubleword x8664::imm0 ptr-reg 0)) + (4 (! mem-set-c-fullword x8664::imm0 ptr-reg 0)) + (2 (! mem-set-c-halfword x8664::imm0 ptr-reg 0)) + (1 (! mem-set-c-byte x8664::imm0 ptr-reg 0)))) + (if for-value + (< x8664::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 &aux op bits) + (setq form (nx-untyped-form form)) + (and + (consp form) + (not (eq (setq op (%car form)) (%nx1-operator call))) + (or + (nx-null form) + (nx-t 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 form)))) + (neq (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) + (%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits))))))) + +(defun x862-lexical-reference-p (form) + (when (acode-p form) + (let ((op (acode-operator (setq form (acode-unwrapped-form form))))) + (when (or (eq op (%nx1-operator lexical-reference)) + (eq op (%nx1-operator inherited-arg))) + (%cadr 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 vreg + (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 ($ x8664::arg_z)) + (dest ($ x8664::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 x8664::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 x8664::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) + (x862-lri seg x8664::imm0 header) + (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ n 2) 1) (arch::target-word-shift arch)) (target-arch-case (:x8664 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 x8664::arg_z))))) + (x862-lri seg x8664::imm0 header) + (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ n 2) 1) (arch::target-word-shift arch)) (target-arch-case (:x8664 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 valform))) + (if (or (eq val *nx-t*) + (eq val *nx-nil*) + (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 ($ x8664::arg_y) valform ($ x8664::arg_z)) + (when safe + (! trap-unless-cons ptr-vreg)) + (if setcdr + (! call-subprim-2 ($ x8664::arg_z) (subprim-name->offset '.SPrplacd) ptr-vreg val-vreg) + (! call-subprim-2 ($ x8664::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 form))) + (if (nx-null uwf) + (x862-branch seg (x862-cd-false xfer)) + (if (x86-constant-form-p uwf) + (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)) + (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 x8664::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)) + +(defun x862-long-constant-p (form) + (setq form (acode-unwrapped-form form)) + (or (acode-fixnum-form-p form) + (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq form (%cadr form)) + (if (integerp form) + form + (progn + (if (symbolp form) (setq form (symbol-name form))) + (if (and (stringp form) (eql (length form) 4)) + (logior (ash (%char-code (char form 0)) 24) + (ash (%char-code (char form 1)) 16) + (ash (%char-code (char form 2)) 8) + (%char-code (char form 3))) + (if (characterp form) (%char-code form)))))))) + +;;; 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 x8664::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))) x8664::arg_z) nil body) + (x862-unwind-set seg xfer old-stack) + (when vreg (<- x8664::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 x8664::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 x8664::temp0) + (x862-invoke-fn seg x8664::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 + (<- x8664::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 (x862-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-cstack) + (target-vstack) + (lastcatch n) + (i nil) + (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 numnlispareas 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 x8664::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)))))) + (while (%i> n dest) + (cond ((eql $undocatch (setq reason (aref *x862-undo-because* (setq n (%i- n 1))))) + (pop-temp-frames) + (pop-c-frames) + (setq numnthrow (%i+ numnthrow 1) lastcatch n)) + ((eql $undostkblk reason) + (throw-through-numnthrow-catch-frames) + (incf num-temp-frames)) + ((eql $undo-x86-c-frame reason) + (throw-through-numnthrow-catch-frames) + (incf num-c-frames)))) + (throw-through-numnthrow-catch-frames) + (setq i lastcatch) + (while (%i> i dest) + (let ((reason (aref *x862-undo-because* (setq i (%i- i 1))))) + (if (or (eql reason $undospecial) + (eql reason $undointerruptlevel)) + (push reason unbind)))) + (if unbind + (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 x8664::imm0 vdiff) + (! slide-values)) + (! adjust-vsp vdiff))))) + (setq num-temp-frames 0 num-c-frames 0) + (while (%i> lastcatch dest) + (let ((reason (aref *x862-undo-because* (setq lastcatch (%i- lastcatch 1))))) + (setq target-cstack (nth-value 1 + (x862-decode-stack (aref *x862-undo-stack* lastcatch)))) + (if (eq reason $undostkblk) + (incf num-temp-frames)) + (if (eq reason $undo-x86-c-frame) + (incf num-c-frames)) + (if (%i> cstack target-cstack) + (compiler-bug "bug: adjust foreign stack ??")) + ;; else what's going on? $sp-stkcons, for one thing + (setq cstack target-cstack))) + (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 *x862-open-code-inline* + (let* ((*available-backend-node-temps* (bitclr x8664::arg_z (bitclr x8664::rcx *available-backend-node-temps*)))) + (! unbind-interrupt-level-inline)) + (! unbind-interrupt-level))) + (nx-error "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 ($ x8664::temp0)) + (keyvectreg ($ 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 x8664::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) + (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 + (: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)))))) + (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 (typep id 'fixnum) + (when (or t (vinsn-label-refs v)) + (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) + ((atom (cdr valform)) (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) + (cons 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 (target-arch-case + (:x8664 x86::*x8664-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) + (cons 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)) + (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 ($ x8664::imm0) (ash index *x862-target-fixnum-shift*)))) + (if tail-p + (! jump-subprim subprim) + (progn + (! call-subprim subprim) + (<- ($ x8664::arg_z)) + (^)))))) + +(defun x862-unary-builtin (seg vreg xfer name form) + (with-x86-local-vinsn-macros (seg) + (x862-one-targeted-reg-form seg form ($ x8664::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 ($ x8664::arg_y) form2 ($ x8664::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 ($ x8664::arg_x) form2 ($ x8664::arg_y) form3 ($ x8664::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) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((stack-consed-rest 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 reqvloc)) + (with-x86-p2-declarations p2decls + (setq *x862-inhibit-register-allocation* + (setq no-regs (%ilogbitp $fbitnoregs fbits))) + (multiple-value-setq (pregs reglocatives) + (x862-allocate-global-registers *x862-fcells* *x862-vcells* (afunc-all-vars afunc) no-regs)) + (@ (backend-get-next-label)) ; generic self-reference label, should be label #1 + (! establish-fn) + (@ (backend-get-next-label)) ; self-call label + (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. + + (when rev-fixed + (x862-reserve-vstack-lcells num-fixed) + (! check-min-nargs num-fixed)) + (when max-args + (! check-max-nargs max-args)) + (if (not (or rest keys)) + (if (<= (+ num-fixed num-opt) $numx8664argregs) + (! 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)) + (x862-lri seg x8664::temp1 (ash flags *x862-target-fixnum-shift*)) + (unless (= nprev 0) + (x862-lri seg x8664::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 x8664::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) + (x862-lri seg x8664::imm0 (ash num-opt *x862-target-fixnum-shift*)) + + ;; ! 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)))) + (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) + (declare (cons pair)) + (let* ((constant (car pair)) + (reg (cdr pair))) + (declare (cons constant)) + (rplacd constant reg) + (! ref-constant reg (x86-immediate-label (car constant)))))) + (when (and (not (or opt rest keys)) + (<= max-args $numx8664argregs) + (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 + (x862-seq-bind-var seg method-var x8664::next-method-context)) + ;; 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 + (:x8664 (list x8664::arg_z x8664::arg_y x8664::arg_x)))) + (arg-reg-num (pop arg-reg-numbers) (pop arg-reg-numbers))) + ((null vars)) + (declare (list vars) (fixnum arg-reg-num)) + (let* ((var (car vars))) + (when var + (let* ((reg (x862-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 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))) + (x862-push-register seg + (if (or node-p crf-p) + (x862-one-untargeted-reg-form seg first x8664::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 x8664::arg_z) + (<- x8664::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 ($ x8664::arg_z))) + (multiple-value-bind (v i) + (x862-two-untargeted-reg-forms seg instance x8664::arg_y idx x8664::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) + (declare (ignore typespec)) ; Boy, do we ever ! + (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) + (let* ((tagreg x8664::imm0)) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (! extract-fulltag tagreg (x862-one-untargeted-reg-form seg form x8664::arg_z)) + (! compare-u8-constant tagreg x8664::fulltag-cons) + (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 x8664::arg_y z x8664::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)) + (<- x8664::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 x8664::arg_y form2 x8664::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 x8664::arg_y form2 x8664::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 x8664::arg_y form2 x8664::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 x8664::arg_y type x8664::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 x8664::arg_z)) + (ensuring-node-target (target vreg) + (! extract-tag-fixnum target (x862-one-untargeted-reg-form seg node x8664::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 x8664::arg_z)) + (ensuring-node-target (target vreg) + (! extract-fulltag-fixnum target (x862-one-untargeted-reg-form seg node x8664::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 x8664::arg_z)) + (let* ((reg (x862-one-untargeted-reg-form seg node (if (eq (hard-regspec-value vreg) x8664::arg_z) + x8664::arg_y x8664::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 ($ x8664::arg_y)) + (valreg ($ x8664::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) x8664::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 x8664::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 (:x8664 63)))) + (ensuring-node-target (target vreg) + (if const + (let* ((src (x862-one-untargeted-reg-form seg form2 x8664::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 x8664::arg_y form2 x8664::arg_z) + (! %ilsl target count src)))) + (^)))) + +(defx862 x862-endp endp (seg vreg xfer cc form) + (let* ((formreg (x862-one-untargeted-reg-form seg form x8664::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 x8664::arg_y idx x8664::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 x8664::arg_x + idx x8664::arg_y + char x8664::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 x8664::arg_x idx x8664::arg_y + char x8664::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 x8664::arg_y idx x8664::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 x8664::arg_z))) + ;; Typecheck even if result unused. + (! require-char-code reg) + (if vreg + (ensuring-node-target (target vreg) + (! fixnum->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 (eq f1 *nx-nil*) + (eq f1 *nx-t*) + (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 ($ x8664::arg_z)) cr-bit true-p f1)) + ((or (eq f2 *nx-nil*) + (eq f2 *nx-t*) + (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 ($ x8664::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 ($ x8664::arg_y)) + (x862-two-targeted-reg-forms seg form1 ($ x8664::arg_y) form2 ($ x8664::arg_z))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ x8664::arg_y) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ x8664::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ x8664::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ x8664::arg_y) ($ x8664::arg_z) (aref *backend-labels* out-of-line))))) + (if otherform + (if (zerop fixval) + (! compare-reg-to-zero ($ x8664::arg_y)) + (! compare-s32-constant ($ x8664::arg_y) (ash fixval x8664::fixnumshift))) + (! compare ($ x8664::arg_y) ($ x8664::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 ($ x8664::arg_z) cr-bit) + (-> done) + (@ out-of-line) + (when otherform + (x862-lri seg ($ x8664::arg_z) (ash fixval x8664::fixnumshift)) + (unless (or fix2 (eq cr-bit x86::x86-e-bits)) + (! xchg-registers ($ x8664::arg_z) ($ x8664::arg_y)))) + (let* ((index (arch::builtin-function-name-offset name)) + (idx-subprim (x862-builtin-index-subprim index))) + (! call-subprim-2 ($ x8664::arg_z) idx-subprim ($ x8664::arg_y) ($ x8664::arg_z))) + (@ done) + (<- ($ x8664::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 x8664::arg_z))) + (^)))) + +(defx862 x862-multiple-value-list multiple-value-list (seg vreg xfer form) + (x862-multiple-value-body seg form) + (! list) + (when vreg + (<- x8664::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 + x8664::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 x8664::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 x8664::arg_y form x8664::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 ($ x8664::arg_y) index ($ x8664::arg_z)) + (! misc-ref) + (<- ($ x8664::arg_z)) + (^)) + +(defx862 x862-uvset uvset (seg vreg xfer vector index value) + (x862-three-targeted-reg-forms seg vector ($ x8664::arg_x) index ($ x8664::arg_y) value ($ x8664::arg_z)) + (! misc-set) + (<- ($ x8664::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) + (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) + (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 x8664::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) + (<- x8664::arg_z) + (^))))) + + +(defx862 x862-if if (seg vreg xfer testform true false) + (if (nx-constant-form-p (acode-unwrapped-form testform)) + (x862-form seg vreg xfer (if (nx-null (acode-unwrapped-form testform)) 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 x8664::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 x8664::arg_z (available-crf-temp *available-backend-crf-temps*)))) + (cd1 (x862-make-compound-cd + (if (eq dest x8664::arg_z) tag1 (x862-cd-merge (x862-cd-true xfer) tag1)) 0))) + (while (cdr forms) + (x862-form seg dest (if (eq dest x8664::arg_z) nil cd1) (car forms)) + (when (eq dest x8664::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 x8664::arg_z) (x862-cd-merge xfer tag2) xfer) (car forms))) + (setq *x862-vstack* vstack *x862-cstack* cstack) + (@ tag1) + (when (eq dest x8664::arg_z) + (<- x8664::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) + (<- x8664::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 args)) + (when (> nargs 1) + (x862-set-nargs seg (1- nargs)) + (! list*)) + (<- x8664::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 ($ x8664::arg_y) form2 ($ x8664::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 ($ x8664::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ x8664::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ x8664::arg_y) ($ x8664::arg_z) (aref *backend-labels* out-of-line)))) + (! fixnum-sub2 ($ x8664::arg_z) ($ x8664::arg_y) ($ x8664::arg_z)) + (x862-check-fixnum-overflow seg ($ x8664::arg_z) done) + (@ out-of-line) + (! call-subprim-2 ($ x8664::arg_z) (subprim-name->offset '.SPbuiltin-minus) ($ x8664::arg_y) ($ x8664::arg_z)) + (@ done) + (x862-copy-register seg target ($ x8664::arg_z))) + (^)))))) + +(defun x862-inline-add2 (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)) + (otherform (if (and fix1 + (typep (ash fix1 *x862-target-fixnum-shift*) + '(signed-byte 32))) + form2 + (if (and fix2 + (typep (ash fix2 *x862-target-fixnum-shift*) + '(signed-byte 32))) + form1)))) + (if otherform + (x862-one-targeted-reg-form seg otherform ($ x8664::arg_z)) + (x862-two-targeted-reg-forms seg form1 ($ x8664::arg_y) form2 ($ x8664::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 ($ x8664::arg_z) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ x8664::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ x8664::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ x8664::arg_y) ($ x8664::arg_z) (aref *backend-labels* out-of-line))))) + (if otherform + (! add-constant ($ x8664::arg_z) (ash (or fix1 fix2) *x862-target-fixnum-shift*)) + (! fixnum-add2 ($ x8664::arg_z) ($ x8664::arg_y))) + (x862-check-fixnum-overflow seg ($ x8664::arg_z) done) + (@ out-of-line) + (if otherform + (x862-lri seg ($ x8664::arg_y) (ash (or fix1 fix2) *x862-target-fixnum-shift*))) + (! call-subprim-2 ($ x8664::arg_z) (subprim-name->offset '.SPbuiltin-plus) ($ x8664::arg_y) ($ x8664::arg_z)) + (@ done) + (x862-copy-register seg target ($ x8664::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 ($ x8664::arg_z)) + (x862-two-targeted-reg-forms seg form1 ($ x8664::arg_y) form2 ($ x8664::arg_z))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ x8664::arg_z) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ x8664::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ x8664::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ x8664::arg_y) ($ x8664::arg_z) (aref *backend-labels* out-of-line))))) + (if otherform + (! %logior-c ($ x8664::arg_z) ($ x8664::arg_z) (ash fixval x8664::fixnumshift)) + (! %logior2 ($ x8664::arg_z) ($ x8664::arg_z) ($ x8664::arg_y))) + (-> done) + (@ out-of-line) + (if otherform + (x862-lri seg ($ x8664::arg_y) (ash fixval x8664::fixnumshift))) + (! call-subprim-2 ($ x8664::arg_z) (subprim-name->offset '.SPbuiltin-logior) ($ x8664::arg_y) ($ x8664::arg_z)) + (@ done) + (x862-copy-register seg target ($ x8664::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 ($ x8664::arg_z)) + (x862-two-targeted-reg-forms seg form1 ($ x8664::arg_y) form2 ($ x8664::arg_z))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ x8664::arg_z) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ x8664::arg_z) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ x8664::arg_y) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ x8664::arg_y) ($ x8664::arg_z) (aref *backend-labels* out-of-line))))) + (if otherform + (! %logand-c ($ x8664::arg_z) ($ x8664::arg_z) (ash fixval x8664::fixnumshift)) + (! %logand2 ($ x8664::arg_z) ($ x8664::arg_z) ($ x8664::arg_y))) + (-> done) + (@ out-of-line) + (if otherform + (x862-lri seg ($ x8664::arg_y) (ash fixval x8664::fixnumshift))) + (! call-subprim-2 ($ x8664::arg_z) (subprim-name->offset '.SPbuiltin-logand) ($ x8664::arg_y) ($ x8664::arg_z)) + (@ done) + (x862-copy-register seg target ($ x8664::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))) + (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))) + (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*)) + (x862-ternary-builtin seg vreg xfer '%aset1 v i n)))) + +(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* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2)) + (other (if (and fix1 + (typep (ash fix1 *x862-target-fixnum-shift*) + '(signed-byte 32))) + form2 + (if (and fix2 + (typep (ash fix2 *x862-target-fixnum-shift*) + '(signed-byte 32))) + form1)))) + (if (and fix1 fix2) + (x862-lri seg vreg (ash (+ fix1 fix2) *x862-target-fixnum-shift*)) + (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 x8664::arg_y form2 x8664::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 x8664::arg_y form2 x8664::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 fixnum) seg vreg xfer (%i- v1 v2)) + (if (and v2 (neq v2 most-negative-fixnum)) + (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 + (let* ((fix1 (acode-fixnum-form-p num1)) + (fix2 (acode-fixnum-form-p num2))) + (if (and fix1 fix2 (not overflow)) + (x862-lri seg vreg (ash (- fix1 fix2) *x862-target-fixnum-shift*)) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg num1 x8664::arg_y num2 x8664::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 x8664::arg_z) (or fix1 fix2)) + (multiple-value-bind (rx ry) (x862-two-untargeted-reg-forms seg num1 x8664::arg_y num2 x8664::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 x8664::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 x8664::arg_z)) + (<- x8664::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) + (! compare-u8-constant (x862-one-untargeted-reg-form seg form x8664::arg_z) + (target-arch-case + (:x8664 x8664::subtag-character))) + (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)) + (^)))))) + + + +(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 (x862-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 x8664::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 x8664::imm0) + (physsize x8664::imm1)) + (x862-lri seg header (arch::make-vheader nelements subtag)) + (x862-lri seg physsize (- (* (ceiling (+ nbytes *x862-target-node-size*) *x862-target-dnode-size*) *x862-target-dnode-size*) (target-arch-case (:x8664 x8664::fulltag-misc)))) + (ensuring-node-target (target vreg) + (! %allocate-uvector target))) + (progn + (if initval + (progn + (x862-three-targeted-reg-forms seg element-count ($ x8664::arg_x) st ($ x8664::arg_y) initval ($ x8664::arg_z)) + (! misc-alloc-init) + (<- ($ x8664::arg_z))) + (progn + (x862-two-targeted-reg-forms seg element-count ($ x8664::arg_y) st ($ x8664::arg_z)) + (! misc-alloc) + (<- ($ x8664::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 (: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 x8664::arg_z)) + (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ x8664::arg_y) form2 ($ x8664::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 ($ x8664::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 ($ x8664::arg_y) form2 ($ x8664::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-imm-target (ptrreg) (offsetreg :s64) + (x862-two-targeted-reg-forms seg + ptr ptrreg + offset ($ x8664::arg_z)) + (! fixnum->signed-natural offsetreg x8664::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-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 + x8664::arg_z)) + (x862-one-targeted-reg-form seg newval fp-reg) + (x862-pop-register seg x8664::arg_z) + (x862-pop-register seg ptr-reg) + (! fixnum->signed-natural offset-reg x8664::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 ($ x8664::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-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 ($ x8664::arg_y)) + (rnew ($ x8664::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-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)))))) + (<- x8664::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) 15) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 15) (setq absptr nil)) + (target-arch-case + + (:x8664 (progn + (and offval (logtest 3 offval) (setq offval nil)) + (and absptr (logtest 3 absptr) (setq absptr nil))))) + (if absptr + (! mem-ref-c-absolute-natural dest absptr) + (if offval + (let* ((src (x862-macptr-arg-to-reg seg ptr ($ x8664::imm0 :mode :address)))) + (! mem-ref-c-natural dest src offval)) + (let* ((src (x862-macptr-arg-to-reg seg ptr ($ x8664::imm0 :mode :address)))) + (if triv-p + (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 x8664::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 x8664::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 ($ x8664::arg_z)) + (if (node-reg-p vreg) + (! mem-ref-bit-fixnum vreg src-reg ($ x8664::arg_z)) + (with-imm-target () ;OK if src-reg & dest overlap + (dest :u8) + (! mem-ref-bit dest src-reg offset) + (<- dest))))) + (^)))) + + + + +;;; 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)) + (target-arch-case + + (: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 + + (: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 + + (:x8664 (! mem-ref-c-doubleword dest src-reg offval))))) + (t + (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 x8664::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 x8664::arg_z)) + (! temp-pop-unboxed-word src-reg) + (x862-close-undo))) + (target-arch-case + + (: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-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-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 x8664::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 x8664::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 + + (: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-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-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 x8664::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 x8664::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 (%ilogbitp $vbitreg bits) + (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 x8664::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 (<- x8664::arg_z)) + (^)) + +(defx862 x862-flet flet (seg vreg xfer vars afuncs body p2decls) + (x862-seq-fbind seg vreg xfer vars afuncs body p2decls)) + +(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 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 x8664::temp0) + (dolist (r ref) + (let* ((v-ea (var-ea (cdr r)))) + (let* ((val-reg (if (eq v-ea ea) + x8664::temp0 + (progn + (x862-addrspec-to-reg seg v-ea x8664::temp1) + x8664::temp1)))) + (! set-closure-forward-reference val-reg x8664::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 x8664::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 x8664::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 + + (:x8664 (typep fixoffset '(signed-byte 13)))) + (ensuring-node-target (target vreg) + (! lisp-word-ref-c target + (x862-one-untargeted-reg-form seg base x8664::arg_z) + (ash fixoffset *x862-target-fixnum-shift*))) + (^)) + (t (multiple-value-bind (breg oreg) + (x862-two-untargeted-reg-forms seg base x8664::arg_y offset x8664::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 x8664::arg_z) + fixoffset)) + (^)) + (t (multiple-value-bind (breg oreg) + (x862-two-untargeted-reg-forms seg base x8664::arg_y offset x8664::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 x8664::arg_z) + fixoffset) + (<- val)) + (^)) + (t (multiple-value-bind (breg oreg) + (x862-two-untargeted-reg-forms seg base x8664::arg_y offset x8664::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 ($ x8664::arg_z)) + (! integer-sign) + (x862-test-reg-%izerop seg vreg xfer x8664::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 x8664::arg_z)) + (if (x862-trivial-p valform) + (progn + (x862-vpush-register seg (x862-one-untargeted-reg-form seg valform x8664::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 ($ x8664::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 ($ x8664::arg_z))) + (x862-lri seg x8664::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 (<- x8664::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 (x862-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) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (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 ($ x8664::arg_x) + i ($ x8664::arg_y) + j ($ x8664::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 (x862-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) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (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 ($ x8664::temp0) + i ($ x8664::arg_x) + j ($ x8664::arg_y) + k ($ x8664::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) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (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 ($ x8664::temp0) + i ($ x8664::arg_x) + j ($ x8664::arg_y) + new ($ x8664::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) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (and atype + (let* ((dims (array-ctype-dimensions atype))) + (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 + (let* ((dims (array-ctype-dimensions atype)) + (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 ($ x8664::arg_z))) + (x862-four-targeted-reg-forms seg + i ($ x8664::temp0) + j ($ x8664::arg_x) + k ($ x8664::arg_y) + new ($ x8664::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 (x862-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 (x862-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) + (x862-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 ($ x8664::arg_x) uvector ($ x8664::arg_y) index ($ x8664::arg_z)) + (! subtag-misc-ref) + (when vreg (<- ($ x8664::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) + (x862-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 + (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 (<- ($ x8664::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)) x8664::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 + + (: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 + (: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 + (: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 x8664::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 x8664::arg_z) x8664::arg_y x8664::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)) + +(defx862 x862-%badarg2 %badarg2 (seg vreg xfer badthing goodthing) + (x862-two-targeted-reg-forms seg badthing ($ x8664::arg_y) goodthing ($ x8664::arg_z)) + (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) + (x862-form seg vreg xfer (make-acode (%nx1-operator call) + (make-acode (%nx1-operator immediate) 'make-list) + (list nil + (list initial-element + (make-acode (%nx1-operator immediate) + :initial-element) + size))))) + + +(defx862 x862-setq-free setq-free (seg vreg xfer sym val) + (let* ((rsym ($ x8664::arg_y)) + (rval ($ x8664::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 x8664::arg_z)) + (with-imm-target () (src-reg :address) + (x862-one-targeted-reg-form seg y src-reg) + (x862-vpop-register seg x8664::arg_z) + (unless (or *x862-reckless* (x862-form-typep x 'macptr)) + (with-imm-temps (src-reg) () + (! trap-unless-macptr x8664::arg_z))) + (! set-macptr-address src-reg x8664::arg_z) + (<- x8664::arg_z) + (^))) + +(defx862 x862-%setf-double-float %setf-double-float (seg vref xfer fnode fval) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode x8664::arg_z)) + (let* ((target ($ x8664::fp1 :class :fpr :mode :double-float)) + (node ($ x8664::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 ($ x8664::arg_y) values ($ x8664::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-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-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 ($ x8664::arg_z)) + (! mem-set-c-bit-variable-value src offval ($ x8664::arg_z)) + (<- ($ x8664::arg_z))))) + (if constval + (with-imm-target () (src :address) + (x862-two-targeted-reg-forms seg ptr src offset ($ x8664::arg_z)) + (if (eql constval 0) + (! mem-set-bit-0 src ($ x8664::arg_z)) + (! mem-set-bit-1 src ($ x8664::arg_z))) + (when vreg + (x862-form seg vreg nil newval))) + (with-imm-target () (src :address) + (x862-three-targeted-reg-forms seg ptr src offset ($ x8664::arg_y) newval ($ x8664::arg_z)) + (! mem-set-bit-variable-value src ($ x8664::arg_y) ($ x8664::arg_z)) + (<- ($ x8664::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)))) + (if fixnum-by + (let* ((result ptr-reg)) + (! add-constant result fixnum-by) + (<- result)) + (progn + (unless triv-by + (x862-push-register seg ptr-reg)) + (let* ((boxed-by (x862-one-targeted-reg-form seg by x8664::arg_z))) + (unless triv-by + (x862-pop-register seg ptr-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-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 narg-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 x8664::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 ($ x8664::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 ($ x8664::arg_z)))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target (target vreg) + (! makes64) + (x862-copy-register seg target ($ x8664::arg_z)))) + (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-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 nshort-floats ndouble-floats nfpr-args ngpr-args narg-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 ($ x8664::arg_z)) + (! %debug-trap) + (<- ($ x8664::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) x8664::arg_z) ($ x8664::arg_y) ($ x8664::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-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-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-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-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-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 + (: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 + (: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 ($ x8664::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 x8664::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 x8664::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 x8664::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 x8664::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 arg))) + (if (and (acode-p form) + (eq (acode-operator form) + (%nx1-operator immediate)) + (typep (cadr form) 'real)) + (cadr form)))))) + (if real + (x862-immediate seg vreg xfer (float real 0.0d0)) + (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 arg))) + (if (and (acode-p form) + (eq (acode-operator form) + (%nx1-operator immediate)) + (typep (cadr form) 'real)) + (cadr form)))))) + (if real + (x862-immediate seg vreg xfer (float real 0.0f0)) + (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)))))))) + + +;------ + +#+not-yet +(progn + + +;Make a gcable macptr. +(defx862 x862-%new-ptr %new-ptr (b vreg xfer size clear-p ) + (declare (ignore b vreg xfer size clear-p)) + (error "%New-ptr is a waste of precious silicon.")) + + + +) + +#-x86-target +(defun x8664-xcompile-lambda (def &key show-vinsns (symbolic-names t) + (target :linuxx8664) + (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 nil + nil + nil + nil + nil + nil + target) + (signal-or-defer-warnings warnings nil) + (when disassemble + (format t "~%~%") + (apply #'x8664-disassemble-xfunction + xlfun + (unless symbolic-names (list nil)))) + xlfun))) + + + + Index: /branches/experimentation/later/source/compiler/acode-rewrite.lisp =================================================================== --- /branches/experimentation/later/source/compiler/acode-rewrite.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/acode-rewrite.lisp (revision 8058) @@ -0,0 +1,379 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 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 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 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 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/experimentation/later/source/compiler/arch.lisp =================================================================== --- /branches/experimentation/later/source/compiler/arch.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/arch.lisp (revision 8058) @@ -0,0 +1,337 @@ +;;;-*- Mode: Lisp; Package: (ARCH :use CL) -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-cant-call 17) ; Attempt to funcall something that is not a symbol or function. +(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 + + ;; 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-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) + + + +(provide "ARCH") Index: /branches/experimentation/later/source/compiler/backend.lisp =================================================================== --- /branches/experimentation/later/source/compiler/backend.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/backend.lisp (revision 8058) @@ -0,0 +1,450 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + +(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)) + +(defmethod print-object ((b backend) s) + (print-unreadable-object (b s :type t :identity t) + (format s "~A" (backend-name b)))) + + + +(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))) + +(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 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 ,regval)) + (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)) Index: /branches/experimentation/later/source/compiler/dll-node.lisp =================================================================== --- /branches/experimentation/later/source/compiler/dll-node.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/dll-node.lisp (revision 8058) @@ -0,0 +1,227 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/compiler/lambda-list.lisp =================================================================== --- /branches/experimentation/later/source/compiler/lambda-list.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/lambda-list.lisp (revision 8058) @@ -0,0 +1,78 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + +;;; used-by: backtrace, arglist +(defun function-symbol-map (fn) + (getf (%lfun-info fn) 'function-symbol-map)) + +(defun %lfun-info-index (fn) + (and (compiled-function-p fn) + (let ((bits (lfun-bits fn))) + (declare (fixnum bits)) + (and (logbitp $lfbits-symmap-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 uncompile-function (fn) + (getf (%lfun-info fn) 'function-lambda-expression )) + + +;;; 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/experimentation/later/source/compiler/nx-base-app.lisp =================================================================== --- /branches/experimentation/later/source/compiler/nx-base-app.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/nx-base-app.lisp (revision 8058) @@ -0,0 +1,30 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/compiler/nx-basic.lisp =================================================================== --- /branches/experimentation/later/source/compiler/nx-basic.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/nx-basic.lisp (revision 8058) @@ -0,0 +1,491 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 *nx1-alphatizers* (make-hash-table :size 180 :test #'eq)) + +(let ((policy (%istruct 'compiler-policy + #'(lambda (env) + (neq (debug-optimize-quantity env) 3)) ; allow-tail-recursion-elimination + #'(lambda (env) + (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) + (>= (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) + (and (eq (speed-optimize-quantity env) 3) + (eq (safety-optimize-quantity env) 0))) ; inhibit-event-polling + #'(lambda (env) + (neq (debug-optimize-quantity env) 3)) ; inline-self-calls + #'(lambda (env) + (and (neq (compilation-speed-optimize-quantity env) 3) + (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) + (inhibit-event-polling nil iep-p) + (inline-self-calls nil iscall-p) + (allow-transforms nil at-p) + (force-boundp-checks nil fb-p) + (allow-constant-substitution nil acs-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 iep-p (setf (policy.inhibit-event-checking p) inhibit-event-polling)) + (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)) + 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 (eq (uvref contour 0) '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 (%svref env 0)) '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) (eq (uvref env 0) '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))) + +(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 (and (consp spec) (eq (%car spec) 'setf)) + (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 (and (consp fname) (eq (%car fname) 'setf)) + (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 (and (consp fname) (eq (%car fname) 'setf)) + (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)) + + +(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)))) + +(defun merge-compiler-warnings (old-warnings) + (let ((warnings nil)) + (dolist (w old-warnings) + (if + (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 + (eq (%car (compiler-warning-args w)) + (%car w1-args))) + (incf (compiler-warning-nrefs w1)) + (return)))) + (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)))) + +(defparameter *compiler-warning-formats* + '((:special . "Undeclared free variable ~S") + (:unused . "Unused lexical variable ~S") + (:ignore . "Variable ~S not ignored") + (:undefined-function . "Undefined function ~S") + (:unknown-declaration . "Unknown declaration ~S") + (:unknown-type-declaration . "Unknown type ~S") + (:macro-used-before-definition . "Macro function ~S was used before it was defined") + (:unsettable . "Shouldn't assign to variable ~S") + (:global-mismatch . "Function call arguments don't match current definition of ~S") + (:environment-mismatch . "Function call arguments don't match visible definition of ~S") + (:type . "Type declarations violated in ~S") + (:type-conflict . "Conflicting type declarations for ~S") + (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined"))) + +(defun report-compiler-warning (condition stream) + (let* ((warning-type (compiler-warning-warning-type condition)) + (format-string (or (cdr (assq warning-type *compiler-warning-formats*)) + (format nil "~S compiler warning with args ~~S" + warning-type)))) + (apply #'format stream format-string (compiler-warning-args condition)) + (let ((nrefs (compiler-warning-nrefs condition))) + (when (and nrefs (neq nrefs 1)) + (format stream " (~D references)" nrefs))) + (princ ", in " stream) + (print-nested-name (reverse (compiler-warning-function-name condition)) stream) + (princ "." stream))) + +(defun environment-structref-info (name env) + (let ((defenv (definition-environment env))) + (when defenv + (cdr (assq name (defenv.structrefs defenv)))))) + +; end Index: /branches/experimentation/later/source/compiler/nx.lisp =================================================================== --- /branches/experimentation/later/source/compiler/nx.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/nx.lisp (revision 8058) @@ -0,0 +1,214 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 spec nil *save-definitions* *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 nil + nil + nil + nil + nil + nil + 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 + env + *save-definitions* + *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-function-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) + + + + +(eval-when (:compile-toplevel) + (declaim (ftype (function (&rest ignore) t) ppc-compile))) + +(defparameter *nx-discard-xref-info-hook* nil) + +(defun compile-named-function + (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target) + (when (and name *nx-discard-xref-info-hook*) + (funcall *nx-discard-xref-info-hook* name)) + (setq + def + (let ((env (new-lexical-environment env))) + (setf (lexenv.variables env) 'barrier) + (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*)) + (afunc (nx1-compile-lambda + name + def + (make-afunc) + nil + env + (or policy *default-compiler-policy*) + *load-time-eval-token*))) + (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) + (:global-mismatch . invalid-arguments-global) + (:lexical-mismatch . invalid-arguments) + (:environment-mismatch . invalid-arguments) + (:ignore . 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/experimentation/later/source/compiler/nx0.lisp =================================================================== --- /branches/experimentation/later/source/compiler/nx0.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/nx0.lisp (revision 8058) @@ -0,0 +1,2381 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 (allocate-typed-vector :istruct $afunc-size nil))) + (setf (%svref v 0) 'afunc) + (setf (afunc-fn-refcount v) 0) + (setf (afunc-fn-downward-refcount v) 0) + (setf (afunc-bits v) 0) + v) + +(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-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 *nx1-vcells* nil) +(defvar *nx1-fcells* nil) + +(defvar *nx1-operators* (make-hash-table :size 160 :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)) + + + + +(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") + +(defparameter *nx-never-tail-call* + '(error cerror break warn type-error file-error + signal-program-error signal-simple-program-error + #-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) + (when (fboundp '%add-xref-entry) + (funcall '%add-xref-entry 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-inhibit-eventchecks (env) + (unless (eq (safety-optimize-quantity env) 3) + (nx-apply-env-hook policy.inhibit-event-checking 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)) + +#-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) + (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. + ; We should probably do something to distinguish "type names" from "typo names", + ; so that (declare (inliMe foo)) warns unless the compiler has some reason to + ; believe that 'inliMe' (inlemon) has been DEFTYPEd. + (dolist (var (%cdr spec)) + (if (symbolp var) + (nx-new-vdecl pending var 'type s))))))) + +; 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) + (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 typed-form)) + (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)) + (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*))))))))))))) + +(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))))) + +; 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 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-double-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-double-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 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) + (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 (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.vdecls env)))) + (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* + (%ilogior + (if (nx-tailcalls env) $decl_tailcalls 0) + (if (nx-inhibit-eventchecks env) $decl_eventchk 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 :unknown-declaration decls)) + + + +(defnxdecl special (pending decl env) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'special) + (nx-bad-decls decl)))) + +(defnxdecl dynamic-extent (pending decl env) + (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) + (nx-bad-decls decl))))) + +(defnxdecl ignorable (pending decl env) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'ignore-if-unused 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-if-unused t) + (nx-bad-decls decl))))) + +(defnxdecl ftype (pending decl env) + (declare (ignore env)) + (destructuring-bind (type &rest fnames) (%cdr decl) + (dolist (s fnames) + (nx-new-fdecl pending s 'ftype type)))) + +(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) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'settable val) + (nx-bad-decls decl)))) + +(defnxdecl type (pending decl env) + (declare (ignore env)) + (labels ((kludge (type) ; 0 => known, 1 => unknown, 2=> illegal + (cond ((type-specifier-p type) + 0) + ((and (consp type) + (member (car type) '(and or)) + (not (null (list-length type)))) + (do ((result 0 (max result (kludge (car tail)))) + (tail (cdr type) (cdr tail))) + ((null tail) + result))) + ((not (symbolp type)) + ;;>>>> nx-bad-decls shouldn't signal a fatal error!!!! + ;;>>>> Most callers of nx-bad-decls should just ignore the + ;;>>>> losing decl element and proceed with the rest + ;;>>>> (ie (declare (ignore foo (bar) baz)) should + ;;>>>> have the effect of ignoring foo and baz as well + ;;>>>> as WARNING about the mal-formed declaration.) + (nx-bad-decls decl) + 2) + (t 1)))) + (let* ((spec (%cdr decl)) + (type (car spec))) + (case (kludge type) + ((0) + (dolist (sym (cdr spec)) + (if (symbolp sym) + (nx-new-vdecl pending sym 'type type) + (nx-bad-decls decl)))) + ((1) + (dolist (sym (cdr spec)) + (unless (symbolp sym) + (nx-bad-decls decl)))) + ((2) + (nx-bad-decls decl)))))) + + + +(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) + (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))) + (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) + (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) + (nx-bad-decls decl))))) + +(defnxdecl ignore-if-unused (pending decl env) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'ignore-if-unused) + (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-bindings (vars initforms &aux alist) + (dolist (var vars alist) + (let* ((binding (nx1-note-var-binding var (pop initforms)))) + (if binding (push binding alist))))) + +(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)) + (consp 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))))))) + +(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 setq'ed or closed; target can't be setq'ed AND closed. + (neq (%ilogand vbits (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 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 specs))))) + +(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))) + (when (and (fixnump v) (<= 0 v 3)) + (if (eq q 'speed) + (setq *nx-speed* v) + (if (eq q 'space) + (setq *nx-space* v) + (if (eq q 'compilation-speed) + (setq *nx-cspeed* v) + (if (eq q 'safety) + (setq *nx-safety* v) + (if (eq q 'debug) + (setq *nx-debug* v))))))))) + +(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*))) + (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))) + (let* ((defenv (definition-environment env))) + (if (cdr (setq info (if defenv (cdr (assq sym (defenv.defined defenv)))))) + (setq lambda-form (cdr info) + token sym + containing-env (new-lexical-environment defenv)) + (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) (eq (%svref env 0) '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 (neq (%svref env 0) '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))) + (nx-set-var-bits + boundto + (%i+ (%i- boundtobits boundtocount) + (%ilogand $vrefmask + (%i+ (%i- boundtocount 1) varcount))))))))) + +(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)) + (setf (afunc-name p) 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-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* (or (and (method-lambda-p lambda-form) *nx-method-warning-name*) + name))) + (if (%non-empty-environment-p *nx-lexical-environment*) + (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p))))) + (multiple-value-bind (body decls) + (parse-body (%cddr lambda-form) *nx-lexical-environment* t) + (setf (afunc-lambdaform p) lambda-form) + (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 + (list + (%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*))))) + (make-acode + (%nx1-operator lambda-list) + req + opt + (if lexpr (list rest) rest) + keys + auxen + body + *nx-new-p2decls*))))) + +(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* t)) + (when (and (consp form)(eq (car form) 'the)) + (setq *nx-form-type* (nx-target-type (cadr form)))) + (prog1 + (nx1-typed-form form *nx-lexical-environment*)))) + +(defun nx1-typed-form (original env) + (nx1-transformed-form (nx-transform original env) env)) + +(defun nx1-transformed-form (form &optional (env *nx-lexical-environment*)) + (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)))))) + + + +(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 nx-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 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)) + (make-acode (%nx1-operator 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*) + :warning-type about + :args (or forms (list nil))) + *nx-warnings*) + nil) + +(defun nx1-type-intersect (form type1 type2 &optional env) + (declare (ignore env)) ; use it when deftype records info in env. Fix this then ... + (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1))) + (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2))) + (intersection (type-intersection ctype1 ctype2))) + (if (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*)) + ;(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 "~S is not a symbol or lambda expression in the form ~S ." sym form))))) + +(defun nx1-treat-as-call (args) + (nx1-typed-call (car args) (%cdr args))) + +(defun nx1-typed-call (sym args) + (let ((type (nx1-call-result-type sym args)) + (form (nx1-call sym args))) + (if (eq type t) + form + (list (%nx1-operator typed-form) type form)))) + +; Wimpy. +(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p) + (let* ((env *nx-lexical-environment*) + (global-def nil) + (lexenv-def nil) + (defenv-def nil) + (somedef nil)) + (when (and sym + (symbolp sym) + (not (find-ftype-decl sym env)) + (not (setq lexenv-def (nth-value 1 (nx-lexical-finfo sym)))) + (null (setq defenv-def (retrieve-environment-function-info sym env))) + (neq sym *nx-global-function-name*) + (not (functionp (setq global-def (fboundp sym))))) + (nx1-whine :undefined-function sym)) + (when (and args-p (setq somedef (or lexenv-def defenv-def global-def))) + (multiple-value-bind (deftype required max minargs maxargs) + (nx1-check-call-args somedef args spread-p) + (when deftype + (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype) + sym required max minargs maxargs)))) + (nx-target-type *nx-form-type*))) + +(defun find-ftype-decl (sym env) + (setq sym (maybe-setf-function-name sym)) + (loop + (when (listp env) + (return (and (symbolp sym) + (proclaimed-ftype sym)))) + (dolist (fdecl (lexenv.fdecls env)) + (declare (list fdecl)) + (when (and (eq (car fdecl) sym) + (eq (car (the list (cdr fdecl))) 'ftype)) + (return-from find-ftype-decl (cdr (the list (cdr fdecl)))))) + (setq env (lexenv.parent-env env)))) + +(defun innermost-lfun-bits-keyvect (def) + (declare (notinline innermost-lfun-bits-keyvect)) + (let* ((gf-p (standard-generic-function-p def))) + (unless gf-p + (let ((inner-def (closure-function (find-unencapsulated-definition def)))) + (values (lfun-bits inner-def)(lfun-keyvect inner-def)))))) + + +(defun nx1-check-call-args (def arglist spread-p) + (let* ((deftype (if (functionp def) + :global-mismatch + (if (istruct-typep def 'afunc) + :lexical-mismatch + :environment-mismatch)))) + (multiple-value-bind (bits keyvect) + (case deftype + (:global-mismatch (innermost-lfun-bits-keyvect def)) + (:environment-mismatch (values (caadr def) (cdadr def))) + (t (let* ((lambda-form (afunc-lambdaform def))) + (if (lambda-expression-p lambda-form) + (encode-lambda-list (cadr lambda-form)))))) + (when bits + (unless (typep bits 'fixnum) (bug "Bad bits!")) + (let* ((nargs (length arglist)) + (minargs (if spread-p (1- nargs) nargs)) + (maxargs (if spread-p nil 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. + (if (or (and (not spread-p) (< minargs required)) + (and max (or (> minargs max)) (if maxargs (> maxargs max))) + (nx1-find-bogus-keywords arglist spread-p bits keyvect)) + (values deftype required max minargs maxargs))))))) + +(defun nx1-find-bogus-keywords (args spread-p bits keyvect) + (declare (fixnum bits)) + (when (logbitp $lfbits-aok-bit bits) + (setq keyvect nil)) ; only check for even length tail + (when (and (logbitp $lfbits-keys-bit bits) + (not spread-p)) ; Can't be sure, last argform may contain :allow-other-keys + (do* ((key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args) (cddr key-args))) + ((null key-args)) + (if (null (cdr key-args)) + (return t) + (when keyvect + (let* ((keyword (%car key-args))) + (unless (constantp keyword) + (return nil)) + (unless (eq keyword :allow-other-keys) + (unless (position (nx-unquote keyword) keyvect) + (return t))))))))) + +;;; 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) + (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 spread-p (nx1-builtin-function-offset global-name)))) + (if builtin + (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) + (nx1-verify-length args 0 nil) + (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 required max minargs maxargs) + (nx1-check-call-args *nx-current-function* args spread-p) + (when deftype + (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype) + sym required max minargs maxargs)) + (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 (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*))) + (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)))) + +; 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-transform (form &optional (environment *nx-lexical-environment*)) + (let* (sym transforms lexdefs changed enabled macro-function compiler-macro) + (tagbody + (go START) + LOOP + (setq changed t) + (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 changed (or changed win)) + (go LOOP))) + (when (atom form) (go DONE)) + (unless (symbolp (setq sym (%car form))) + (go DONE)) + (when (eq sym 'the) + (destructuring-bind (typespec thing) (cdr form) + (if (constantp thing) + (progn + (setq form thing form thing) + (go LOOP)) + (multiple-value-bind (newform win) (nx-transform thing environment) + (when win + (setq changed t) + (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)) + (if win (setq changed t))))) + (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 changed t) (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 #-bccl (boundp '%structure-refs%) + (gethash sym %structure-refs%)))) + (setq form (defstruct-ref-transform transforms (%cdr form)) changed T) + (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) changed t) + (go START)) + DONE) + (values form changed))) + +; 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) + (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))) + (rplacd ptr (setq ptr (cons (multiple-value-setq (form win) (nx-transform form env)) 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)) + (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-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))) + (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 (quoted-form-p form) + (type-of (nx-unquote form)) + (if (self-evaluating-p form) + (type-of form) + (if (and (consp form) ; Kinda bogus now, but require-type + (eq (%car form) 'require-type) ; should be special some day + (quoted-form-p (caddr form))) + (%cadr (%caddr form)) + (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)) + (let* ((ctype (values-specifier-type typespec))) + (if (typep ctype 'values-ctype) + (let* ((req (values-ctype-required ctype))) + (if req + (nx-target-type (type-specifier (car req))) + '*)) + (nx-target-type (type-specifier ctype))))) + (if (eq (%car form) 'setq) + (nx-declared-type (cadr form) env) + (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*))) + (and (memq (car form) *numeric-ops*) + (grovel-numeric-form form env)) + (and (memq (car form) *logical-ops*) + (grovel-logical-form form env)) + ;; Sort of the right idea, but this should be done + ;; in a more general way. + (when (or (eq (car form) 'aref) + (eq (car form) 'uvref)) + (let* ((atype (nx-form-type (cadr form) env)) + (a-ctype (specifier-type atype))) + (when (array-ctype-p a-ctype) + (type-specifier (array-ctype-specialized-element-type + a-ctype))))) + 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 (constantp arg) + (typep (nx-unquote arg) type) + (subtypep (nx-form-type arg env) type))) + + +(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) + (or (eq (%car gizmo) 'function) (eq (%car gizmo) 'quote)) + (consp (%cdr gizmo)) + (null (%cddr 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")) + Index: /branches/experimentation/later/source/compiler/nx1.lisp =================================================================== --- /branches/experimentation/later/source/compiler/nx1.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/nx1.lisp (revision 8058) @@ -0,0 +1,2116 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Wimp out, but don't choke on (the (values ...) form) +(defnx1 nx1-the the (&whole call typespec form &environment env) + (if (and (self-evaluating-p form) + (not (typep form typespec)) + (progn (nx1-whine :type call) t)) + (setq typespec t)) + ;; Allow VALUES types here (or user-defined types that + ;; expand to VALUES types). + (let* ((ctype (values-specifier-type typespec))) + (if (typep ctype 'values-ctype) + (setq typespec '*) + (setq typespec (nx-target-type (type-specifier ctype))))) + (let* ((*nx-form-type* typespec) + (transformed (nx-transform form env))) + (if (and (consp transformed) + (eq (car transformed) 'the)) + (setq transformed form)) + (make-acode + (%nx1-operator typed-form) + typespec + (nx1-transformed-form transformed 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 (quoted-form-p type) (symbolp (cadr type))) + (make-acode (%nx1-operator istruct-typep) + (nx1-immediate :eq) + (nx1-form thing) + (nx1-form 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 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) + (%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)) (&whole w 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) (&whole whole size 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) + (eq (%car form) (%nx1-operator typed-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)) (&whole w 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 &environment env) + (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) + (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)) (&whole whole &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)) (&whole whole &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)) (&whole whole 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)) (&whole whole &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)) (&whole whole &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)) (&whole whole &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 &environment env) + (make-acode (%nx1-operator uvset) + (nx1-form vector) + (nx1-form index) + (nx1-form value))) + +(defnx1 nx1-set-schar ((set-schar)) (&whole w s i v &environment env) + (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)) (&whole w 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) + (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) + (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) + (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) + (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))) + (make-acode (%nx1-operator if) (nx1-form test) (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))) + (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)) + (declared-type (nx-declared-type sym))) + (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) nil nil nil nil nil *nx-load-time-eval-token* (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) + (make-acode (%nx1-operator %badarg2) + (nx1-form badthing) + (nx1-form (or (if (quoted-form-p right-type) (%typespec-id (cadr right-type))) 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 &aux (orig args) (spread-p t)) + (if (null (%car (last (push arg args)))) + (setq spread-p nil args (butlast args))) + (let ((name (nx1-func-name fn)) + (global nil)) + (if name + (if (eq (%car fn) 'quote) + (setq global t name (nx1-form fn)) + (let* ((afunc (nth-value 1 (nx-lexical-finfo name)))) + (when (and afunc (eq afunc *nx-call-next-method-function*)) + (setq name (if (or arg orig) + '%call-next-method-with-args + '%call-next-method) + global t + args (cons (var-name *nx-next-method-var*) args))))) + (setq name (nx1-form fn))) + (nx1-call name args spread-p global))) + +(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (&whole call fn arg &rest args &aux (orig args)) + (push arg args) + (let ((name (nx1-func-name fn)) + (global nil)) + (if name + (if (eq (%car fn) 'quote) + (setq global t name (nx1-form fn)) + (let* ((afunc (nth-value 1 (nx-lexical-finfo name)))) + (when (and afunc (eq afunc *nx-call-next-method-function*)) + (setq name (if (or arg orig) + '%call-next-method-with-args + '%call-next-method) + global t + args (cons (var-name *nx-next-method-var*) args))))) + (setq name (nx1-form fn))) + (nx1-call name args 0 global))) + + + +(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)) + (symbolp (%cadr def))) + (note-function-info (%cadr def) nil 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 + &optional p (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) + (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p. + +(defun nx1-afunc-ref (afunc) + (let ((op (if (afunc-inherited-vars afunc) + (%nx1-operator closed-function) + (%nx1-operator simple-function))) + (ref (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)) + (progn + (nx1-call-result-type symbol) ; misnamed. Checks for (un-)definedness. + (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)) + ((:linuxx8664 :freebsdx8664 :darwinx8664) (%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)) + ((:linuxx8664 :freebsdx8664 :darwinx8664) (%nx1-operator syscall)))))) + +(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator ) + (let* ((specs ()) + (vals ()) + (register-spec-seen nil) + (monitor (eq (car arg-specs-and-result-spec) :monitor-exception-ports)) + (arg-specs (butlast arg-specs-and-result-spec)) + (result-spec (car (last arg-specs-and-result-spec)))) + (if monitor + (setq arg-specs (cdr arg-specs))) + (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 + monitor))) + +(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) + (make-acode (%nx1-operator 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)) (func &rest args) + (let ((name func)) + (if (and (consp name) + (eq (%car name) 'function) + (consp (%cdr name)) + (null (%cddr name)) + (or + (if (symbolp (setq name (%cadr name))) + (or (not (macro-function name *nx-lexical-environment*)) + (nx-error "Can't funcall macro function ~s ." name))) + (and (consp name) + (or (eq (%car name) 'lambda) + (setq name (nx-need-function-name name)))))) + (nx1-form (cons name args)) ; This picks up call-next-method evil. + (nx1-call (nx1-form func) args nil t)))) + +(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args) + (make-acode (%nx1-default-operator) + (nx1-form value-form) + (nx1-formlist args))) + +#| +(defun nx1-call-name (fn &aux (name (nx1-func-name fn))) + (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name)))) + (make-acode (%nx1-operator immediate) name) + (or name (nx1-form fn)))) +|# + +(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))) + (setf (afunc-environment func) env + (afunc-lambdaform func) `(lambda ,lambda-list + ,@decls + (block ,(if (consp funcname) (%cadr funcname) funcname) + ,@body))) + (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)))) + (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)) (&whole whole 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) + (let* ((vars nil) + (vals nil) + (varspecs nil)) + (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) + (push (nx-need-var (nx-pair-name pair)) vars) + (push (nx1-typed-var-initform pending (car vars) (nx-pair-initform pair)) vals))) + (let* ((*nx-bound-vars* (append vars *nx-bound-vars*)) + (varbindings (nx1-note-var-bindings + (dolist (sym vars varspecs) + (push (nx-new-var pending sym) varspecs)) + (setq vals (nreverse vals)))) + (form + (make-acode + (%nx1-operator let) + varspecs + 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 varspecs 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 in Lambda form: ~S ~S." lambda-list args)) + (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 in Lambda form: ~S ~S." lambda-list args)) + (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 + (make-acode + (%nx1-operator 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 in Lambda form: ~S ~S." + lambda-list args)) + (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 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) + (do* ((form (nx1-progn-body body)) + (env *nx-lexical-environment* (lexenv.parent-env env))) + ((or (eq env old-env) (null env)) form) + (let ((vars (lexenv.variables env))) + (if (consp vars) + (dolist (var vars) + (nx-check-var-usage var)))))) + +(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) + (make-acode (%nx1-operator natural-shift-right) + (nx1-form num) + (make-acode (%nx1-operator fixnum) + (- amt))) + (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/experimentation/later/source/compiler/nxenv.lisp =================================================================== --- /branches/experimentation/later/source/compiler/nxenv.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/nxenv.lisp (revision 8058) @@ -0,0 +1,642 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) +) + +#+ppc-target (require "PPCENV") +#+x8664-target (require "X8664ENV") + +(defconstant $afunc-size + (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 +)) + +; + +(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.inhibit-event-checking + policy.inline-self-calls + policy.allow-transforms + policy.force-boundp-checks + policy.allow-constant-substitution + policy.misc) + +(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)) +(defconstant $decl_tailcalls (%ilsl 16 1)) +(defconstant $decl_opencodeinline (%ilsl 16 4)) +(defconstant $decl_eventchk (%ilsl 16 8)) +(defconstant $decl_unsafe (%ilsl 16 16)) +(defconstant $decl_trustdecls (%ilsl 16 32)) + +(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) + (spushl . #.operator-single-valued-mask) + (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)) + (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) + (%ttagp . #.(logior operator-cc-invertable-mask operator-single-valued-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 . 0) + (%double-float--2 . 0) + (%double-float*-2 . 0) + (%double-float/-2 . 0) + (%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 . 0) + (%short-float--2 . 0) + (%short-float*-2 . 0) + (%short-float/-2 . 0) + (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))))) + +(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 $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-p (x) + " A big help this is ..." + `(consp ,x)) + +(defmacro defnx2 (name locative arglist &body forms) + (multiple-value-bind (body decls) + (parse-body forms nil t) + (let ((fn `(nfunction ,name (lambda ,arglist ,@decls (block ,name .,body))))) + `(progn + (record-source-file ',name 'function) + (svset *nx2-specials* (%ilogand operator-id-mask (%nx1-operator ,locative)) ,fn))))) + +(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))) + + + +(defmacro with-p2-declarations (declsform &body body) + `(let* ((*nx2-tail-allow* *nx2-tail-allow*) + (*nx2-reckless* *nx2-reckless*) + (*nx2-inhibit-eventchecks* *nx2-inhibit-eventchecks*) + (*nx2-open-code-inline* *nx2-open-code-inline*) + (*nx2-trust-declarations* *nx2-trust-declarations*)) + (nx2-decls ,declsform) + ,@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)))) + (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)))) + new)) + + +(defun nx1-sysnode (form) + (if form + (if (eq form t) + *nx-t*) + *nx-nil*)) +) + +(provide "NXENV") + Index: /branches/experimentation/later/source/compiler/optimizers.lisp =================================================================== --- /branches/experimentation/later/source/compiler/optimizers.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/optimizers.lisp (revision 8058) @@ -0,0 +1,2016 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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.) +(defun constant-keywords-p (keys) + (when (plistp keys) + (while keys + (unless (keywordp (%car keys)) + (return-from constant-keywords-p nil)) + (setq keys (%cddr keys))) + t)) + +(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 (quoted-form-p thing) + (setq thing (%cadr thing)) + (if (not (self-evaluating-p thing)) + (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 (quoted-form-p thing) + (setq thing (%cadr thing)) + (if (not (self-evaluating-p thing)) + (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 &environment env 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)))) + 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 &environment env 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 (constantp n) n 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 &environment env 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) + (multiple-value-bind (test test-win) (nx-transform test env) + (multiple-value-bind (true true-win) (nx-transform true env) + (multiple-value-bind (false false-win) (nx-transform false env) + (if (or (quoted-form-p test) (self-evaluating-p test)) + (if (eval test) + true + false) + (if (or test-win true-win false-win) + `(if ,test ,true ,false) + call)))))) + +(define-compiler-macro %ilsr (&whole call &environment env shift value) + (if (eql shift 0) + value + (if (eql value 0) + `(progn ,shift 0) + call))) + + +(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 &environment env &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) + (let* ((ctype (ignore-errors (specifier-type `(array ,typespec))))) + (if (or (null ctype) (typep ctype 'unknown-ctype)) + (progn + (nx1-whine :unknown-type-declaration typespec) + nil) + (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 (quoted-form-p dims) + (let* ((dims (nx-unquote dims))) + (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* ((element-type (specifier-type (if element-type-p (nx-unquote element-type) t)))) + (setf (array-ctype-element-type ctype) element-type) + (if (typep element-type 'unknown-ctype) + (setf (array-ctype-specialized-element-type ctype) *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) + (nx1-whine 'illegal-arguments 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 (constantp element-type)) + (null (setq element-type-keyword + (target-element-type-type-keyword + (eval element-type))))) + (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 (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env))) + `(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))) + (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 + (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 (&whole call &environment env 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 (&whole call &environment env 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 (&whole call &environment env 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) + (cond ((and (quoted-form-p type) + (setq type (%cadr type)) + (not (typep (specifier-type type) 'unknown-ctype))) + (cond ((nx-form-typep arg type env) arg) + ((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= (specifier-type type) + (specifier-type '(signed-byte 8))) + `(the (signed-byte 8) (require-s8 ,arg))) + ((type= (specifier-type type) + (specifier-type '(unsigned-byte 8))) + `(the (unsigned-byte 8) (require-u8 ,arg))) + ((type= (specifier-type type) + (specifier-type '(signed-byte 16))) + `(the (signed-byte 16) (require-s16 ,arg))) + ((type= (specifier-type type) + (specifier-type '(unsigned-byte 16))) + `(the (unsigned-byte 16) (require-u16 ,arg))) + ((type= (specifier-type type) + (specifier-type '(signed-byte 32))) + `(the (signed-byte 32) (require-s32 ,arg))) + ((type= (specifier-type type) + (specifier-type '(unsigned-byte 32))) + `(the (unsigned-byte 32) (require-u32 ,arg))) + ((type= (specifier-type type) + (specifier-type '(signed-byte 64))) + `(the (signed-byte 64) (require-s64 ,arg))) + ((type= (specifier-type type) + (specifier-type '(unsigned-byte 64))) + `(the (unsigned-byte 64) (require-u64 ,arg))) + ((and (symbolp type) + (let ((simpler (type-predicate type))) + (if simpler `(the ,type (%require-type ,arg ',simpler)))))) + ((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))) + `(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 (&whole call &environment env + test sequence &rest keys) + `(find ,test ,sequence + :test #'funcall + ,@keys)) + +(define-compiler-macro find-if-not (&whole call &environment env + 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 (constantp item) + (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 (&whole call &environment env + test sequence &rest keys) + `(position ,test ,sequence + :test #'funcall + ,@keys)) + +(define-compiler-macro position-if-not (&whole call &environment env + 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)) + (sequence-value (if (constantp sequence) + (eval-constant sequence) + sequence))) + (cond ((nx-form-typep sequence-value 'list env) + (let ((item-var (unless (or (constantp item) + (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-value 'vector env) + (let ((item-var (unless (or (constantp item) + (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 + (&whole w &environment env &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) + 0)))) + +(define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more) + (if more + `(- (--2 ,n0 ,n1) ,@more) + (if n1p + `(--2 ,n0 ,n1) + `(%negate ,n0)))) + +(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more) + (if more + (let ((type (nx-form-type w env))) + (if (and type (numeric-type-p type)) ; go pairwise if type known, else not + `(*-2 ,n0 (* ,n1 ,@more)) + w)) + (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) + class))) + (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)) + (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))))))))))))) + `(array-%%typep ,thing ,ctype)))))) + + + +(defun optimize-typep (thing type env) + ;; returns a new form, or nil if it can't optimize + (let* ((ctype (ignore-errors (specifier-type type)))) + (when (and ctype (not (typep ctype 'unknown-ctype))) + (let* ((type (type-specifier ctype)) + (predicate (if (typep type 'symbol) (type-predicate type)))) + (if (and predicate (symbolp predicate)) + `(,predicate ,thing) + (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 ',type)) + ((find-class type nil env) + `(class-cell-typep ,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) + (declare (ignore e)) + (if (quoted-form-p type) + (or (optimize-typep thing (%cadr type) env) + call) + (if (eq type t) + `(progn ,thing t) + call))) + +(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))) + + + + +(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 (n) + (let* ((cons-tag (arch::target-cons-tag (backend-target-arch *target-backend*)))) + `(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)))) + (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype)))) + (useful (unless (or (eq type *) (eq type t)) + type))) + (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 &environment env typespec len &rest keys &key initial-element) + (declare (ignore typespec len keys initial-element)) + call) + +(define-compiler-macro make-string (&whole call 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 + (quoted-form-p element-type)) + (let* ((element-type (cadr element-type))) + (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 sbit (&environment env &whole call v &optional sub0 &rest others) + (if (and sub0 (null others)) + `(aref (the simple-bit-vector ,v) ,sub0) + call)) + +(define-compiler-macro %sbitset (&environment env &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 ,thing))) + (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 :simple-string))) + `(eq ,tag (typecode ,lock)))) + + +(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 %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))) + `(let* ((,code (char-code ,ch))) + (and (eq ,code (setq ,code (char-code ,other))) + (eq ,code (char-code ,third))))) + 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 (char-upcase ,ch)) (%char-code (char-upcase ,other))) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym))) + `(let* ((,code (%char-code (char-upcase ,ch)))) + (and (eq ,code (setq ,code (%char-code (char-upcase ,other)))) + (eq ,code (%char-code (char-upcase ,third)))))) + 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))) + `(let* ((,code (char-code ,ch))) + (declare (fixnum ,code)) + (and (< ,code (setq ,code (char-code ,other))) + (< ,code (the fixnum (char-code ,third)))))) + 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))) + `(let* ((,code (char-code ,ch))) + (declare (fixnum ,code)) + (and (<= ,code (setq ,code (char-code ,other))) + (<= ,code (the fixnum (char-code ,third)))))) + 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))) + `(let* ((,code (char-code ,ch))) + (declare (fixnum ,code)) + (and (> ,code (setq ,code (char-code ,other))) + (> ,code (the fixnum (char-code ,third)))))) + 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))) + `(let* ((,code (char-code ,ch))) + (declare (fixnum ,code)) + (and (>= ,code (setq ,code (char-code ,other))) + (>= ,code (the fixnum (char-code ,third)))))) + 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 thing type) + (if (quoted-form-p type) + (setq type (cadr type))) + (if (ignore-errors (subtypep type 'single-float)) + `(float ,thing 0.0f0) + (if (ignore-errors (subtypep type 'double-float)) + `(float ,thing 0.0d0) + 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)) + +(provide "OPTIMIZERS") + Index: /branches/experimentation/later/source/compiler/reg.lisp =================================================================== --- /branches/experimentation/later/source/compiler/reg.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/reg.lisp (revision 8058) @@ -0,0 +1,237 @@ +;;;-*- Mode: Lisp; Package: CCL-*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/compiler/risc-lap.lisp =================================================================== --- /branches/experimentation/later/source/compiler/risc-lap.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/risc-lap.lisp (revision 8058) @@ -0,0 +1,198 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (declare (ignore depth)) + (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/experimentation/later/source/compiler/subprims.lisp =================================================================== --- /branches/experimentation/later/source/compiler/subprims.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/subprims.lisp (revision 8058) @@ -0,0 +1,48 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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*)) + (%subprim-name->offset name (arch::target-subprims-table + (backend-target-arch backend)))) + +(provide "SUBPRIMS") Index: /branches/experimentation/later/source/compiler/vinsn.lisp =================================================================== --- /branches/experimentation/later/source/compiler/vinsn.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/vinsn.lisp (revision 8058) @@ -0,0 +1,759 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + )) + +(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 result-specs temp-specs arg-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)))) + + +;;; 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 ())) + (declare (fixnum id)) + (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))))) + (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/experimentation/later/source/compiler/vreg.lisp =================================================================== --- /branches/experimentation/later/source/compiler/vreg.lisp (revision 8058) +++ /branches/experimentation/later/source/compiler/vreg.lisp (revision 8058) @@ -0,0 +1,309 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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" 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/experimentation/later/source/darwin-headers/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/darwin-headers/addressbook/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/addressbook/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/addressbook/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/darwin-headers/addressbook/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/addressbook/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/addressbook/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/addressbook/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/addressbook/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/addressbook/C/populate.sh (revision 8058) @@ -0,0 +1,9 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +rm -rf System Developer usr +CFLAGS="-isysroot ${SDK}"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/AddressBook.framework/Headers/AddressBook.h Index: /branches/experimentation/later/source/darwin-headers/carbon/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/carbon/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/carbon/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +*.cdb* + + +*~.* Index: /branches/experimentation/later/source/darwin-headers/carbon/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/carbon/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/carbon/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/carbon/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/carbon/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/carbon/C/populate.sh (revision 8058) @@ -0,0 +1,10 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +CFLAGS="-Wno-multichar -isysroot ${SDK}" ; export CFLAGS +/bin/rm -rf Developer System +h-to-ffi.sh ${SDK}/System/Library/Frameworks/Carbon.framework/Headers/Carbon.h + Index: /branches/experimentation/later/source/darwin-headers/chud/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/chud/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/chud/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +*.cdb* + + +*~.* Index: /branches/experimentation/later/source/darwin-headers/chud/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/chud/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/chud/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/chud/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/chud/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/chud/C/populate.sh (revision 8058) @@ -0,0 +1,7 @@ +#!/bin/sh +# This is for CHUD 4.1.x. No two versions of CHUD install in the +# same place, or contain the same set of headers +# A lot of the CHUD headers are missing terminating newlines; +# I'm not sure how to suppress warnings about that (or why those newlines +# are missing.) +h-to-ffi.sh -Wno-endif-labels /System/Library/PrivateFrameworks/CHUD.framework/Headers/CHUDCore.h Index: /branches/experimentation/later/source/darwin-headers/cocoa/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/cocoa/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/cocoa/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/darwin-headers/cocoa/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/cocoa/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/cocoa/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/cocoa/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/cocoa/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/cocoa/C/populate.sh (revision 8058) @@ -0,0 +1,10 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +rm -rf System Developer usr +CFLAGS="-isysroot ${SDK}"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/Cocoa.framework/Headers/Cocoa.h + Index: /branches/experimentation/later/source/darwin-headers/gl/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/gl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/gl/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/darwin-headers/gl/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/gl/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/gl/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/gl/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/gl/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/gl/C/populate.sh (revision 8058) @@ -0,0 +1,11 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +CFLAGS="-isysroot ${SDK}"; export CFLAGS +rm -rf System Developer +h-to-ffi.sh ${SDK}/System/Library/Frameworks/OpenGL.framework/Headers/OpenGL.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/GLUT.framework/Headers/glut.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/AGL.framework/Headers/agl.h Index: /branches/experimentation/later/source/darwin-headers/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/libc/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/darwin-headers/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/libc/C/populate.sh (revision 8058) @@ -0,0 +1,620 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +CFLAGS="-isysroot ${SDK}"; export CFLAGS +rm -rf Developer usr System +h-to-ffi.sh ${SDK}/usr/include/ar.h +h-to-ffi.sh ${SDK}/usr/include/arpa/ftp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/arpa/inet.h +h-to-ffi.sh ${SDK}/usr/include/arpa/nameser.h +h-to-ffi.sh ${SDK}/usr/include/arpa/nameser_compat.h +h-to-ffi.sh ${SDK}/usr/include/arpa/telnet.h +h-to-ffi.sh ${SDK}/usr/include/arpa/tftp.h +h-to-ffi.sh ${SDK}/usr/include/bitstring.h +h-to-ffi.sh ${SDK}/usr/include/bzlib.h +h-to-ffi.sh ${SDK}/usr/include/c.h +h-to-ffi.sh ${SDK}/usr/include/com_err.h +h-to-ffi.sh ${SDK}/usr/include/crt_externs.h +h-to-ffi.sh ${SDK}/usr/include/ctype.h +h-to-ffi.sh ${SDK}/usr/include/curl/curl.h +h-to-ffi.sh ${SDK}/usr/include/curses.h +h-to-ffi.sh ${SDK}/usr/include/db.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/ev_keymap.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOHIDTypes.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOLLEvent.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOHIDShared.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/event_status_driver.h +h-to-ffi.sh ${SDK}/usr/include/device/device_port.h +h-to-ffi.sh ${SDK}/usr/include/device/device_types.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/dirent.h +h-to-ffi.sh ${SDK}/usr/include/disktab.h +h-to-ffi.sh ${SDK}/usr/include/DNSServiceDiscovery/DNSServiceDiscovery.h +h-to-ffi.sh ${SDK}/usr/include/dlfcn.h +h-to-ffi.sh ${SDK}/usr/include/err.h +h-to-ffi.sh ${SDK}/usr/include/errno.h +h-to-ffi.sh ${SDK}/usr/include/eti.h +h-to-ffi.sh ${SDK}/usr/include/fcntl.h +h-to-ffi.sh ${SDK}/usr/include/float.h +h-to-ffi.sh ${SDK}/usr/include/fnmatch.h +h-to-ffi.sh ${SDK}/usr/include/form.h +h-to-ffi.sh ${SDK}/usr/include/fsproperties.h +h-to-ffi.sh ${SDK}/usr/include/fstab.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/fts.h +h-to-ffi.sh ${SDK}/usr/include/glob.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/grp.h +h-to-ffi.sh ${SDK}/usr/include/gssapi/gssapi_generic.h +h-to-ffi.sh -include ${SDK}/usr/include/gssapi/gssapi.h ${SDK}/usr/include/gssapi/gssapi_krb5.h +# can't find typedef of Str31 +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_encodings.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_format.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_mount.h +h-to-ffi.sh ${SDK}/usr/include/histedit.h +#h-to-ffi.sh ${SDK}/usr/include/httpd/httpd.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/ifaddrs.h +h-to-ffi.sh ${SDK}/usr/include/inttypes.h +h-to-ffi.sh ${SDK}/usr/include/iodbcinst.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_mount.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_node.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_rrip.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/iso.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/iso_rrip.h +h-to-ffi.sh ${SDK}/usr/include/kerberosIV/des.h +h-to-ffi.sh ${SDK}/usr/include/kerberosIV/krb.h +h-to-ffi.sh ${SDK}/usr/include/krb.h +h-to-ffi.sh ${SDK}/usr/include/krb5.h +h-to-ffi.sh ${SDK}/usr/include/kvm.h +h-to-ffi.sh ${SDK}/usr/include/lber.h +h-to-ffi.sh ${SDK}/usr/include/lber_types.h +h-to-ffi.sh ${SDK}/usr/include/ldap.h +h-to-ffi.sh ${SDK}/usr/include/libc.h +h-to-ffi.sh ${SDK}/usr/include/libgen.h +#h-to-ffi.sh ${SDK}/usr/include/libkern/libkern.h +h-to-ffi.sh ${SDK}/usr/include/libkern/OSReturn.h +h-to-ffi.sh ${SDK}/usr/include/libkern/OSTypes.h +h-to-ffi.sh ${SDK}/usr/include/limits.h +h-to-ffi.sh ${SDK}/usr/include/locale.h +h-to-ffi.sh ${SDK}/usr/include/mach/boolean.h +#h-to-ffi.sh ${SDK}/usr/include/mach/boot_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/bootstrap.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_priv.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_reply.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/error.h +h-to-ffi.sh ${SDK}/usr/include/mach/exception.h +h-to-ffi.sh ${SDK}/usr/include/mach/exception_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_priv.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_reboot.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_security.h +h-to-ffi.sh ${SDK}/usr/include/mach/kern_return.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/vm_types.h ${SDK}/usr/include/mach/kmod.h +h-to-ffi.sh ${SDK}/usr/include/mach/ledger.h +h-to-ffi.sh ${SDK}/usr/include/mach/lock_set.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_error.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_host.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_init.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_interface.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_param.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_port.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/message.h ${SDK}/usr/include/mach/mach_syscalls.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_time.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_traps.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/machine.h +h-to-ffi.sh ${SDK}/usr/include/mach/memory_object_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/message.h +h-to-ffi.sh ${SDK}/usr/include/mach/mig.h +h-to-ffi.sh ${SDK}/usr/include/mach/mig_errors.h +h-to-ffi.sh ${SDK}/usr/include/mach/ndr.h +h-to-ffi.sh ${SDK}/usr/include/mach/notify.h +h-to-ffi.sh ${SDK}/usr/include/mach/policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/port.h +h-to-ffi.sh ${SDK}/usr/include/mach/port_obj.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor_set.h +h-to-ffi.sh ${SDK}/usr/include/mach/rpc.h +h-to-ffi.sh ${SDK}/usr/include/mach/semaphore.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/mach/shared_memory_server.h +h-to-ffi.sh ${SDK}/usr/include/mach/std_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/sync.h +h-to-ffi.sh ${SDK}/usr/include/mach/sync_policy.h +#h-to-ffi.sh ${SDK}/usr/include/mach/syscall_sw.h +h-to-ffi.sh ${SDK}/usr/include/mach/task.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_ledger.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_special_ports.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_act.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_special_ports.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_status.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_switch.h +h-to-ffi.sh ${SDK}/usr/include/mach/time_value.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_attributes.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_behavior.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_inherit.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_map.h +h-to-ffi.sh ${SDK}/usr/include/mach/machine/vm_param.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_prot.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/mach_types.h ${SDK}/usr/include/mach/vm_region.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_statistics.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_sync.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_task.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_types.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/arch.h +h-to-ffi.sh -D__private_extern__=extern ${SDK}/usr/include/mach-o/dyld.h +h-to-ffi.sh -D__private_extern__=extern ${SDK}/usr/include/mach-o/dyld_debug.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/fat.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/getsect.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/ldsyms.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/loader.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/nlist.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/ranlib.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/reloc.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/stab.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/swap.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/machine/vm_types.h ${SDK}/usr/include/mach_debug/hash_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/ipc_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/mach_debug.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/mach_debug_types.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/page_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/vm_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/zone_info.h +h-to-ffi.sh ${SDK}/usr/include/malloc/malloc.h +h-to-ffi.sh ${SDK}/usr/include/math.h +h-to-ffi.sh ${SDK}/usr/include/memory.h +h-to-ffi.sh ${SDK}/usr/include/monitor.h +h-to-ffi.sh ${SDK}/usr/include/nameser.h +h-to-ffi.sh ${SDK}/usr/include/ncurses_dll.h +h-to-ffi.sh ${SDK}/usr/include/ndbm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/net/bpf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/ethernet.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/net/if.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/net/if_arp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/if_dl.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/if_llc.h +h-to-ffi.sh ${SDK}/usr/include/net/if_media.h +h-to-ffi.sh ${SDK}/usr/include/net/if_types.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/kext_net.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/pfkeyv2.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/radix.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/route.h +#h-to-ffi.sh ${SDK}/usr/include/net/slcompress.h +#h-to-ffi.sh ${SDK}/usr/include/net/slip.h +#h-to-ffi.sh ${SDK}/usr/include/netat/adsp.h +h-to-ffi.sh ${SDK}/usr/include/netat/appletalk.h +#h-to-ffi.sh ${SDK}/usr/include/netat/asp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_aarp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_ddp_brt.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_pat.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_snmp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_var.h +#h-to-ffi.sh ${SDK}/usr/include/netat/atp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/aurp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/ddp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/debug.h +#h-to-ffi.sh ${SDK}/usr/include/netat/ep.h +#h-to-ffi.sh ${SDK}/usr/include/netat/lap.h +#h-to-ffi.sh ${SDK}/usr/include/netat/nbp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/pap.h +#h-to-ffi.sh ${SDK}/usr/include/netat/routing_tables.h +#h-to-ffi.sh ${SDK}/usr/include/netat/rtmp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/sysglue.h +#h-to-ffi.sh ${SDK}/usr/include/netat/zip.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/dll.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/hd_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/hdlc.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/llc_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/pk.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/pk_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25_sockaddr.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25acct.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25err.h +h-to-ffi.sh ${SDK}/usr/include/netdb.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/udp.h ${SDK}/usr/include/netinet/bootp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/netinet/icmp6.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/ip_icmp.h ${SDK}/usr/include/netinet/icmp_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/netinet/if_ether.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/ip_icmp.h ${SDK}/usr/include/netinet/icmp_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/netinet/if_ether.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/netinet/igmp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/igmp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_systm.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_fw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_icmp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_mroute.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_nat.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_proxy.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_state.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/tcp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_fsm.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_seq.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_timer.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcpip.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/udp.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/udp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ah.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/esp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/icmp6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_gif.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_ifattach.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_prefix.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_fw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_mroute.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6protosw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ipcomp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ipsec.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mip6_common.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mld6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_defs.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_list.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_log.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_soctl.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/nd6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/pim6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/pim6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/udp6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/udp6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/_lu_types.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/lookup.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/lookup_types.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni_prot.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni_util.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/nibind_prot.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/argo_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnl.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnp.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnp_stat.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cltp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cons.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cons_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/eonvar.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/esis.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_errno.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_snpac.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_var.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_clnp.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_events.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_ip.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_meas.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_param.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_seq.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_stat.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_states.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_timer.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_tpdu.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_trace.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_user.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tuba_table.h +#h-to-ffi.sh ${SDK}/usr/include/netkey/keydb.h +#h-to-ffi.sh ${SDK}/usr/include/netkey/keysock.h +#h-to-ffi.sh ${SDK}/usr/include/netns/idp.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_error.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_if.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spidp.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spp_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spp_var.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/krpc.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfs.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsdiskless.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsm_subs.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsmount.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsnode.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsproto.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsrtt.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsrvcache.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nqnfs.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/nfs/rpcv2.h +h-to-ffi.sh ${SDK}/usr/include/nfs/xdr_subs.h +h-to-ffi.sh ${SDK}/usr/include/nlist.h +h-to-ffi.sh ${SDK}/usr/include/NSSystemDirectories.h +h-to-ffi.sh ${SDK}/usr/include/objc/objc-load.h +h-to-ffi.sh ${SDK}/usr/include/objc/objc-runtime.h +h-to-ffi.sh ${SDK}/usr/include/objc/objc.h +h-to-ffi.sh ${SDK}/usr/include/objc/Object.h +h-to-ffi.sh ${SDK}/usr/include/objc/Protocol.h +h-to-ffi.sh ${SDK}/usr/include/objc/zone.h +h-to-ffi.sh ${SDK}/usr/include/openssl/asn1.h +h-to-ffi.sh ${SDK}/usr/include/openssl/asn1_mac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/bio.h +h-to-ffi.sh ${SDK}/usr/include/openssl/blowfish.h +h-to-ffi.sh ${SDK}/usr/include/openssl/bn.h +h-to-ffi.sh ${SDK}/usr/include/openssl/buffer.h +h-to-ffi.sh ${SDK}/usr/include/openssl/cast.h +h-to-ffi.sh ${SDK}/usr/include/openssl/comp.h +h-to-ffi.sh ${SDK}/usr/include/openssl/conf.h +h-to-ffi.sh ${SDK}/usr/include/openssl/conf_api.h +h-to-ffi.sh ${SDK}/usr/include/openssl/crypto.h +h-to-ffi.sh ${SDK}/usr/include/openssl/des.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dh.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dsa.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dso.h +h-to-ffi.sh ${SDK}/usr/include/openssl/e_os2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ebcdic.h +h-to-ffi.sh ${SDK}/usr/include/openssl/err.h +h-to-ffi.sh ${SDK}/usr/include/openssl/evp.h +h-to-ffi.sh ${SDK}/usr/include/openssl/hmac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/lhash.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md4.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md5.h +h-to-ffi.sh ${SDK}/usr/include/openssl/mdc2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/obj_mac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/objects.h +h-to-ffi.sh ${SDK}/usr/include/openssl/opensslconf.h +h-to-ffi.sh ${SDK}/usr/include/openssl/opensslv.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pem.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pem2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pkcs12.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pkcs7.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rand.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc4.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc5.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ripemd.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rsa.h +h-to-ffi.sh ${SDK}/usr/include/openssl/safestack.h +h-to-ffi.sh ${SDK}/usr/include/openssl/sha.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl23.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl3.h +h-to-ffi.sh ${SDK}/usr/include/openssl/stack.h +h-to-ffi.sh ${SDK}/usr/include/openssl/symhacks.h +h-to-ffi.sh ${SDK}/usr/include/openssl/tls1.h +h-to-ffi.sh ${SDK}/usr/include/openssl/tmdiff.h +h-to-ffi.sh ${SDK}/usr/include/openssl/txt_db.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509_vfy.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509v3.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_aconf.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_compat.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_macros.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_types.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_appl.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_client.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_misc.h +h-to-ffi.sh -include ${SDK}/usr/include/pam/_pam_types.h ${SDK}/usr/include/pam/pam_mod_misc.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_modules.h +h-to-ffi.sh ${SDK}/usr/include/paths.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/net/bpf.h -include ${SDK}/usr/include/stdio.h ${SDK}/usr/include/pcap-namedb.h +h-to-ffi.sh ${SDK}/usr/include/pcap.h +#h-to-ffi.sh ${SDK}/usr/include/pexpert/boot.h +#h-to-ffi.sh ${SDK}/usr/include/pexpert/pexpert.h +h-to-ffi.sh ${SDK}/usr/include/pexpert/protos.h +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-internal.h +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-kgmon.c +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-mk.h +h-to-ffi.sh ${SDK}/usr/include/profile.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/dumprestore.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/routed.h +h-to-ffi.sh ${SDK}/usr/include/protocols/rwhod.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/talkd.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/timed.h +h-to-ffi.sh ${SDK}/usr/include/pthread.h +h-to-ffi.sh ${SDK}/usr/include/pthread_impl.h +h-to-ffi.sh ${SDK}/usr/include/pwd.h +h-to-ffi.sh ${SDK}/usr/include/ranlib.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/regex.h +#h-to-ffi.sh ${SDK}/usr/include/regexp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/nameser.h ${SDK}/usr/include/resolv.h +#h-to-ffi.sh ${SDK}/usr/include/rmd160.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/auth.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/auth_unix.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/clnt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_clnt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_prot.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_rmt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/rpc.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/rpc_msg.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/svc.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/svc_auth.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/types.h +h-to-ffi.sh -include ${SDK}/usr/include/rpc/types.h ${SDK}/usr/include/rpc/xdr.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/mount.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rex.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rnusers.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rquota.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rstat.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rusers.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rwall.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/spray.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/yp.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh ${SDK}/usr/include/rune.h +h-to-ffi.sh ${SDK}/usr/include/runetype.h +h-to-ffi.sh ${SDK}/usr/include/sched.h +h-to-ffi.sh ${SDK}/usr/include/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/servers/bootstrap.h +h-to-ffi.sh ${SDK}/usr/include/servers/bootstrap_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/key_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/ls_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/netname.h +h-to-ffi.sh ${SDK}/usr/include/servers/netname_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/nm_defs.h +h-to-ffi.sh ${SDK}/usr/include/setjmp.h +h-to-ffi.sh ${SDK}/usr/include/sgtty.h +h-to-ffi.sh ${SDK}/usr/include/signal.h +h-to-ffi.sh ${SDK}/usr/include/sql.h +h-to-ffi.sh ${SDK}/usr/include/sqlext.h +h-to-ffi.sh ${SDK}/usr/include/sqltypes.h +h-to-ffi.sh ${SDK}/usr/include/stab.h +h-to-ffi.sh ${SDK}/usr/include/standards.h +#h-to-ffi.sh ${SDK}/usr/include/stdarg.h +h-to-ffi.sh ${SDK}/usr/include/stdbool.h +h-to-ffi.sh ${SDK}/usr/include/stddef.h +h-to-ffi.sh ${SDK}/usr/include/stdint.h +h-to-ffi.sh ${SDK}/usr/include/stdio.h +h-to-ffi.sh ${SDK}/usr/include/stdlib.h +h-to-ffi.sh ${SDK}/usr/include/string.h +h-to-ffi.sh ${SDK}/usr/include/strings.h +h-to-ffi.sh ${SDK}/usr/include/struct.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/acct.h +h-to-ffi.sh ${SDK}/usr/include/sys/attr.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/buf.h +#h-to-ffi.sh ${SDK}/usr/include/sys/callout.h +h-to-ffi.sh ${SDK}/usr/include/sys/cdefs.h +#h-to-ffi.sh ${SDK}/usr/include/sys/clist.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/conf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dir.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dirent.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/disk.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/disklabel.h +#h-to-ffi.sh ${SDK}/usr/include/sys/disktab.h +h-to-ffi.sh ${SDK}/usr/include/sys/dkstat.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dmap.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/domain.h +h-to-ffi.sh ${SDK}/usr/include/sys/errno.h +h-to-ffi.sh ${SDK}/usr/include/sys/ev.h +#h-to-ffi.sh ${SDK}/usr/include/sys/exec.h +h-to-ffi.sh ${SDK}/usr/include/sys/fcntl.h +h-to-ffi.sh ${SDK}/usr/include/sys/file.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/filedesc.h +h-to-ffi.sh ${SDK}/usr/include/sys/filio.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/gmon.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioccom.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioctl.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioctl_compat.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ipc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kdebug.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kern_control.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kern_event.h +h-to-ffi.sh ${SDK}/usr/include/sys/kernel.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ktrace.h +#h-to-ffi.sh ${SDK}/usr/include/sys/linker_set.h +h-to-ffi.sh ${SDK}/usr/include/sys/loadable_fs.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/lock.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/fcntl.h ${SDK}/usr/include/sys/lockf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/malloc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/machine/param.h ${SDK}/usr/include/sys/mbuf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/md5.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/mman.h +h-to-ffi.sh ${SDK}/usr/include/sys/mount.h +h-to-ffi.sh ${SDK}/usr/include/sys/msgbuf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/mtio.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/namei.h +h-to-ffi.sh ${SDK}/usr/include/sys/netport.h +h-to-ffi.sh ${SDK}/usr/include/sys/param.h +h-to-ffi.sh ${SDK}/usr/include/sys/paths.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/sys/proc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/protosw.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ptrace.h +h-to-ffi.sh ${SDK}/usr/include/sys/queue.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/quota.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/random.h +h-to-ffi.sh ${SDK}/usr/include/sys/reboot.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/sys/resource.h ${SDK}/usr/include/sys/resourcevar.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/select.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/sem.h +h-to-ffi.sh ${SDK}/usr/include/sys/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/sys/shm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/signal.h ${SDK}/usr/include/sys/signalvar.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/socket.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/socketvar.h +h-to-ffi.sh ${SDK}/usr/include/sys/sockio.h +h-to-ffi.sh ${SDK}/usr/include/sys/stat.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/sys_domain.h +h-to-ffi.sh ${SDK}/usr/include/sys/syscall.h +h-to-ffi.sh ${SDK}/usr/include/sys/sysctl.h +h-to-ffi.sh ${SDK}/usr/include/sys/syslimits.h +h-to-ffi.sh ${SDK}/usr/include/sys/syslog.h +#h-to-ffi.sh ${SDK}/usr/include/sys/systm.h +h-to-ffi.sh ${SDK}/usr/include/sys/termios.h +h-to-ffi.sh ${SDK}/usr/include/sys/time.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/timeb.h +h-to-ffi.sh ${SDK}/usr/include/sys/times.h +#h-to-ffi.sh ${SDK}/usr/include/sys/tprintf.h +h-to-ffi.sh ${SDK}/usr/include/sys/trace.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/tty.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttychars.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttycom.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttydefaults.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttydev.h +#h-to-ffi.sh ${SDK}/usr/include/sys/types.h +#h-to-ffi.sh ${SDK}/usr/include/sys/ubc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/signal.h ${SDK}/usr/include/sys/ucontext.h +h-to-ffi.sh ${SDK}/usr/include/sys/ucred.h +#h-to-ffi.sh ${SDK}/usr/include/sys/uio.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/un.h +h-to-ffi.sh ${SDK}/usr/include/sys/unistd.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/unpcb.h +h-to-ffi.sh ${SDK}/usr/include/sys/user.h +h-to-ffi.sh ${SDK}/usr/include/sys/utfconv.h +h-to-ffi.sh ${SDK}/usr/include/sys/utsname.h +#h-to-ffi.sh ${SDK}/usr/include/sys/ux_exception.h +h-to-ffi.sh ${SDK}/usr/include/sys/vadvise.h +h-to-ffi.sh ${SDK}/usr/include/sys/vcmd.h +h-to-ffi.sh ${SDK}/usr/include/sys/version.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/sys/vmparam.h ${SDK}/usr/include/sys/vm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/vmmeter.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/sys/vmparam.h +h-to-ffi.sh ${SDK}/usr/include/sys/vnioctl.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/vnode.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/vnode.h ${SDK}/usr/include/sys/vnode_if.h +h-to-ffi.sh ${SDK}/usr/include/sys/wait.h +h-to-ffi.sh ${SDK}/usr/include/sysexits.h +h-to-ffi.sh ${SDK}/usr/include/syslog.h +h-to-ffi.sh ${SDK}/usr/include/tar.h +h-to-ffi.sh ${SDK}/usr/include/TargetConditionals.h +h-to-ffi.sh ${SDK}/usr/include/tcl.h +h-to-ffi.sh ${SDK}/usr/include/tcpd.h +h-to-ffi.sh ${SDK}/usr/include/term.h +h-to-ffi.sh ${SDK}/usr/include/termios.h +h-to-ffi.sh ${SDK}/usr/include/time.h +h-to-ffi.sh ${SDK}/usr/include/ttyent.h +h-to-ffi.sh ${SDK}/usr/include/tzfile.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ffs/ffs_extern.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ffs/fs.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/dinode.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/dir.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/inode.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/lockf.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/quota.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/ufs_extern.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/mount.h ${SDK}/usr/include/ufs/ufs/ufsmount.h +h-to-ffi.sh ${SDK}/usr/include/ulimit.h +h-to-ffi.sh ${SDK}/usr/include/unctrl.h +h-to-ffi.sh ${SDK}/usr/include/unistd.h +h-to-ffi.sh ${SDK}/usr/include/util.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/utime.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/utmp.h +#h-to-ffi.sh ${SDK}/usr/include/vfs/vfs_support.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/vis.h +h-to-ffi.sh ${SDK}/usr/include/zconf.h +h-to-ffi.sh ${SDK}/usr/include/zlib.h Index: /branches/experimentation/later/source/darwin-headers/quicktime/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/quicktime/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/quicktime/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +*.cdb* + + +*~.* Index: /branches/experimentation/later/source/darwin-headers/quicktime/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/quicktime/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/quicktime/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/quicktime/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/quicktime/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/quicktime/C/populate.sh (revision 8058) @@ -0,0 +1,10 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +rm -rf System Developer usr +CFLAGS="-isysroot ${SDK}"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/QuickTime.framework/Headers/QuickTime.h + Index: /branches/experimentation/later/source/darwin-headers/webkit/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/webkit/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/webkit/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/darwin-headers/webkit/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers/webkit/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/webkit/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers/webkit/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers/webkit/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers/webkit/C/populate.sh (revision 8058) @@ -0,0 +1,9 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +rm -rf System Developer usr +CFLAGS="-isysroot ${SDK}"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/WebKit.framework/Headers/WebKit.h Index: /branches/experimentation/later/source/darwin-headers64/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers64/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/darwin-headers64/chud/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers64/chud/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/chud/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +*.cdb* + + +*~.* Index: /branches/experimentation/later/source/darwin-headers64/chud/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers64/chud/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/chud/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-headers64/chud/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers64/chud/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/chud/C/populate.sh (revision 8058) @@ -0,0 +1,7 @@ +#!/bin/sh +# This is for CHUD 4.4.x. No two versions of CHUD install in the +# same place, or contain the same set of headers +# A lot of the CHUD headers are missing terminating newlines; +# I'm not sure how to suppress warnings about that (or why those newlines +# are missing.) +h-to-ffi.sh -m64 -Wno-endif-labels /System/Library/PrivateFrameworks/CHUD.framework/Headers/CHUDCore.h Index: /branches/experimentation/later/source/darwin-headers64/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers64/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/libc/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/darwin-headers64/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-headers64/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +usr* +System* +Developer* Index: /branches/experimentation/later/source/darwin-headers64/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-headers64/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-headers64/libc/C/populate.sh (revision 8058) @@ -0,0 +1,620 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +CFLAGS="-m64 -Wno-endif-labels -isysroot ${SDK}";export CFLAGS +rm -rf usr Developer System +h-to-ffi.sh ${SDK}/usr/include/ar.h +h-to-ffi.sh ${SDK}/usr/include/arpa/ftp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/arpa/inet.h +h-to-ffi.sh ${SDK}/usr/include/arpa/nameser.h +h-to-ffi.sh ${SDK}/usr/include/arpa/nameser_compat.h +h-to-ffi.sh ${SDK}/usr/include/arpa/telnet.h +h-to-ffi.sh ${SDK}/usr/include/arpa/tftp.h +h-to-ffi.sh ${SDK}/usr/include/bitstring.h +h-to-ffi.sh ${SDK}/usr/include/bzlib.h +h-to-ffi.sh ${SDK}/usr/include/c.h +h-to-ffi.sh ${SDK}/usr/include/com_err.h +h-to-ffi.sh ${SDK}/usr/include/crt_externs.h +h-to-ffi.sh ${SDK}/usr/include/ctype.h +h-to-ffi.sh ${SDK}/usr/include/curl/curl.h +h-to-ffi.sh ${SDK}/usr/include/curses.h +h-to-ffi.sh ${SDK}/usr/include/db.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/ev_keymap.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOHIDTypes.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOLLEvent.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOHIDShared.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/cdefs.h ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/event_status_driver.h +h-to-ffi.sh ${SDK}/usr/include/device/device_port.h +h-to-ffi.sh ${SDK}/usr/include/device/device_types.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/dirent.h +h-to-ffi.sh ${SDK}/usr/include/disktab.h +h-to-ffi.sh ${SDK}/usr/include/DNSServiceDiscovery/DNSServiceDiscovery.h +h-to-ffi.sh ${SDK}/usr/include/dlfcn.h +h-to-ffi.sh ${SDK}/usr/include/err.h +h-to-ffi.sh ${SDK}/usr/include/errno.h +h-to-ffi.sh ${SDK}/usr/include/eti.h +h-to-ffi.sh ${SDK}/usr/include/fcntl.h +h-to-ffi.sh ${SDK}/usr/include/float.h +h-to-ffi.sh ${SDK}/usr/include/fnmatch.h +h-to-ffi.sh ${SDK}/usr/include/form.h +h-to-ffi.sh ${SDK}/usr/include/fsproperties.h +h-to-ffi.sh ${SDK}/usr/include/fstab.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/fts.h +h-to-ffi.sh ${SDK}/usr/include/glob.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/grp.h +h-to-ffi.sh ${SDK}/usr/include/gssapi/gssapi_generic.h +h-to-ffi.sh -include ${SDK}/usr/include/gssapi/gssapi.h ${SDK}/usr/include/gssapi/gssapi_krb5.h +# can't find typedef of Str31 +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_encodings.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_format.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_mount.h +h-to-ffi.sh ${SDK}/usr/include/histedit.h +#h-to-ffi.sh ${SDK}/usr/include/httpd/httpd.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/ifaddrs.h +h-to-ffi.sh ${SDK}/usr/include/inttypes.h +h-to-ffi.sh ${SDK}/usr/include/iodbcinst.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_mount.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_node.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_rrip.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/iso.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/iso_rrip.h +h-to-ffi.sh ${SDK}/usr/include/kerberosIV/des.h +h-to-ffi.sh ${SDK}/usr/include/kerberosIV/krb.h +h-to-ffi.sh ${SDK}/usr/include/krb.h +h-to-ffi.sh ${SDK}/usr/include/krb5.h +h-to-ffi.sh ${SDK}/usr/include/kvm.h +h-to-ffi.sh ${SDK}/usr/include/lber.h +h-to-ffi.sh ${SDK}/usr/include/lber_types.h +h-to-ffi.sh ${SDK}/usr/include/ldap.h +h-to-ffi.sh ${SDK}/usr/include/libc.h +h-to-ffi.sh ${SDK}/usr/include/libgen.h +#h-to-ffi.sh ${SDK}/usr/include/libkern/libkern.h +h-to-ffi.sh ${SDK}/usr/include/libkern/OSReturn.h +h-to-ffi.sh ${SDK}/usr/include/libkern/OSTypes.h +h-to-ffi.sh ${SDK}/usr/include/limits.h +h-to-ffi.sh ${SDK}/usr/include/locale.h +h-to-ffi.sh ${SDK}/usr/include/mach/boolean.h +#h-to-ffi.sh ${SDK}/usr/include/mach/boot_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/bootstrap.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_priv.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_reply.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/error.h +h-to-ffi.sh ${SDK}/usr/include/mach/exception.h +h-to-ffi.sh ${SDK}/usr/include/mach/exception_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_priv.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_reboot.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_security.h +h-to-ffi.sh ${SDK}/usr/include/mach/kern_return.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/vm_types.h ${SDK}/usr/include/mach/kmod.h +h-to-ffi.sh ${SDK}/usr/include/mach/ledger.h +h-to-ffi.sh ${SDK}/usr/include/mach/lock_set.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_error.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_host.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_init.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_interface.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_param.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_port.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/message.h ${SDK}/usr/include/mach/mach_syscalls.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_time.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_traps.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/machine.h +h-to-ffi.sh ${SDK}/usr/include/mach/memory_object_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/message.h +h-to-ffi.sh ${SDK}/usr/include/mach/mig.h +h-to-ffi.sh ${SDK}/usr/include/mach/mig_errors.h +h-to-ffi.sh ${SDK}/usr/include/mach/ndr.h +h-to-ffi.sh ${SDK}/usr/include/mach/notify.h +h-to-ffi.sh ${SDK}/usr/include/mach/policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/port.h +h-to-ffi.sh ${SDK}/usr/include/mach/port_obj.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor_set.h +h-to-ffi.sh ${SDK}/usr/include/mach/rpc.h +h-to-ffi.sh ${SDK}/usr/include/mach/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/mach/shared_memory_server.h +h-to-ffi.sh ${SDK}/usr/include/mach/std_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/sync.h +h-to-ffi.sh ${SDK}/usr/include/mach/sync_policy.h +#h-to-ffi.sh ${SDK}/usr/include/mach/syscall_sw.h +h-to-ffi.sh ${SDK}/usr/include/mach/task.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_ledger.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_special_ports.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_act.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_special_ports.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_status.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_switch.h +h-to-ffi.sh ${SDK}/usr/include/mach/time_value.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_attributes.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_behavior.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_inherit.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_map.h +h-to-ffi.sh ${SDK}/usr/include/mach/machine/vm_param.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_prot.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/mach_types.h ${SDK}/usr/include/mach/vm_region.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_statistics.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_sync.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_task.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_types.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/arch.h +h-to-ffi.sh -D__private_extern__=extern ${SDK}/usr/include/mach-o/dyld.h +h-to-ffi.sh -D__private_extern__=extern ${SDK}/usr/include/mach-o/dyld_debug.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/fat.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/getsect.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/ldsyms.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/loader.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/nlist.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/ranlib.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/reloc.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/stab.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/swap.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/machine/vm_types.h ${SDK}/usr/include/mach_debug/hash_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/ipc_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/mach_debug.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/mach_debug_types.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/page_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/vm_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/zone_info.h +h-to-ffi.sh ${SDK}/usr/include/malloc/malloc.h +h-to-ffi.sh ${SDK}/usr/include/math.h +h-to-ffi.sh ${SDK}/usr/include/memory.h +h-to-ffi.sh ${SDK}/usr/include/monitor.h +h-to-ffi.sh ${SDK}/usr/include/nameser.h +h-to-ffi.sh ${SDK}/usr/include/ncurses_dll.h +h-to-ffi.sh ${SDK}/usr/include/ndbm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/net/bpf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/ethernet.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/net/if.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/net/if_arp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/if_dl.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/if_llc.h +h-to-ffi.sh ${SDK}/usr/include/net/if_media.h +h-to-ffi.sh ${SDK}/usr/include/net/if_types.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/kext_net.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/pfkeyv2.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/radix.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/route.h +#h-to-ffi.sh ${SDK}/usr/include/net/slcompress.h +#h-to-ffi.sh ${SDK}/usr/include/net/slip.h +#h-to-ffi.sh ${SDK}/usr/include/netat/adsp.h +h-to-ffi.sh ${SDK}/usr/include/netat/appletalk.h +#h-to-ffi.sh ${SDK}/usr/include/netat/asp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_aarp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_ddp_brt.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_pat.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_snmp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_var.h +#h-to-ffi.sh ${SDK}/usr/include/netat/atp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/aurp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/ddp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/debug.h +#h-to-ffi.sh ${SDK}/usr/include/netat/ep.h +#h-to-ffi.sh ${SDK}/usr/include/netat/lap.h +#h-to-ffi.sh ${SDK}/usr/include/netat/nbp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/pap.h +#h-to-ffi.sh ${SDK}/usr/include/netat/routing_tables.h +#h-to-ffi.sh ${SDK}/usr/include/netat/rtmp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/sysglue.h +#h-to-ffi.sh ${SDK}/usr/include/netat/zip.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/dll.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/hd_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/hdlc.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/llc_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/pk.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/pk_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25_sockaddr.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25acct.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25err.h +h-to-ffi.sh ${SDK}/usr/include/netdb.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/udp.h ${SDK}/usr/include/netinet/bootp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/netinet/icmp6.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/ip_icmp.h ${SDK}/usr/include/netinet/icmp_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/netinet/if_ether.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/ip_icmp.h ${SDK}/usr/include/netinet/icmp_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/netinet/if_ether.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/netinet/igmp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/igmp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_systm.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_fw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_icmp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_mroute.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_nat.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_proxy.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_state.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/tcp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_fsm.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_seq.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_timer.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcpip.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/udp.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/udp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ah.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/esp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/icmp6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_gif.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_ifattach.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_prefix.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_fw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_mroute.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6protosw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ipcomp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ipsec.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mip6_common.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mld6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_defs.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_list.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_log.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_soctl.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/nd6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/pim6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/pim6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/udp6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/udp6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/_lu_types.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/lookup.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/lookup_types.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni_prot.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni_util.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/nibind_prot.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/argo_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnl.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnp.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnp_stat.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cltp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cons.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cons_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/eonvar.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/esis.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_errno.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_snpac.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_var.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_clnp.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_events.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_ip.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_meas.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_param.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_seq.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_stat.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_states.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_timer.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_tpdu.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_trace.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_user.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tuba_table.h +#h-to-ffi.sh ${SDK}/usr/include/netkey/keydb.h +#h-to-ffi.sh ${SDK}/usr/include/netkey/keysock.h +#h-to-ffi.sh ${SDK}/usr/include/netns/idp.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_error.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_if.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spidp.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spp_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spp_var.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/krpc.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfs.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsdiskless.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsm_subs.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsmount.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsnode.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsproto.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsrtt.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsrvcache.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nqnfs.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/nfs/rpcv2.h +h-to-ffi.sh ${SDK}/usr/include/nfs/xdr_subs.h +#h-to-ffi.sh ${SDK}/usr/include/nlist.h +#h-to-ffi.sh ${SDK}/usr/include/NSSystemDirectories.h +#h-to-ffi.sh ${SDK}/usr/include/objc/objc-load.h +#h-to-ffi.sh ${SDK}/usr/include/objc/objc-runtime.h +#h-to-ffi.sh ${SDK}/usr/include/objc/objc.h +#h-to-ffi.sh ${SDK}/usr/include/objc/Object.h +#h-to-ffi.sh ${SDK}/usr/include/objc/Protocol.h +#h-to-ffi.sh ${SDK}/usr/include/objc/zone.h +h-to-ffi.sh ${SDK}/usr/include/openssl/asn1.h +h-to-ffi.sh ${SDK}/usr/include/openssl/asn1_mac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/bio.h +h-to-ffi.sh ${SDK}/usr/include/openssl/blowfish.h +h-to-ffi.sh ${SDK}/usr/include/openssl/bn.h +h-to-ffi.sh ${SDK}/usr/include/openssl/buffer.h +h-to-ffi.sh ${SDK}/usr/include/openssl/cast.h +h-to-ffi.sh ${SDK}/usr/include/openssl/comp.h +h-to-ffi.sh ${SDK}/usr/include/openssl/conf.h +h-to-ffi.sh ${SDK}/usr/include/openssl/conf_api.h +h-to-ffi.sh ${SDK}/usr/include/openssl/crypto.h +h-to-ffi.sh ${SDK}/usr/include/openssl/des.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dh.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dsa.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dso.h +h-to-ffi.sh ${SDK}/usr/include/openssl/e_os2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ebcdic.h +h-to-ffi.sh ${SDK}/usr/include/openssl/err.h +h-to-ffi.sh ${SDK}/usr/include/openssl/evp.h +h-to-ffi.sh ${SDK}/usr/include/openssl/hmac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/lhash.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md4.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md5.h +h-to-ffi.sh ${SDK}/usr/include/openssl/mdc2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/obj_mac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/objects.h +h-to-ffi.sh ${SDK}/usr/include/openssl/opensslconf.h +h-to-ffi.sh ${SDK}/usr/include/openssl/opensslv.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pem.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pem2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pkcs12.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pkcs7.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rand.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc4.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc5.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ripemd.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rsa.h +h-to-ffi.sh ${SDK}/usr/include/openssl/safestack.h +h-to-ffi.sh ${SDK}/usr/include/openssl/sha.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl23.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl3.h +h-to-ffi.sh ${SDK}/usr/include/openssl/stack.h +h-to-ffi.sh ${SDK}/usr/include/openssl/symhacks.h +h-to-ffi.sh ${SDK}/usr/include/openssl/tls1.h +h-to-ffi.sh ${SDK}/usr/include/openssl/tmdiff.h +h-to-ffi.sh ${SDK}/usr/include/openssl/txt_db.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509_vfy.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509v3.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_aconf.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_compat.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_macros.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_types.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_appl.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_client.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_misc.h +h-to-ffi.sh -include ${SDK}/usr/include/pam/_pam_types.h ${SDK}/usr/include/pam/pam_mod_misc.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_modules.h +h-to-ffi.sh ${SDK}/usr/include/paths.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/net/bpf.h -include ${SDK}/usr/include/stdio.h ${SDK}/usr/include/pcap-namedb.h +h-to-ffi.sh ${SDK}/usr/include/pcap.h +#h-to-ffi.sh ${SDK}/usr/include/pexpert/boot.h +#h-to-ffi.sh ${SDK}/usr/include/pexpert/pexpert.h +h-to-ffi.sh ${SDK}/usr/include/pexpert/protos.h +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-internal.h +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-kgmon.c +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-mk.h +h-to-ffi.sh ${SDK}/usr/include/profile.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/dumprestore.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/routed.h +h-to-ffi.sh ${SDK}/usr/include/protocols/rwhod.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/talkd.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/timed.h +h-to-ffi.sh ${SDK}/usr/include/pthread.h +h-to-ffi.sh ${SDK}/usr/include/pthread_impl.h +h-to-ffi.sh ${SDK}/usr/include/pwd.h +h-to-ffi.sh ${SDK}/usr/include/ranlib.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/regex.h +#h-to-ffi.sh ${SDK}/usr/include/regexp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/nameser.h ${SDK}/usr/include/resolv.h +#h-to-ffi.sh ${SDK}/usr/include/rmd160.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/auth.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/auth_unix.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/clnt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_clnt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_prot.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_rmt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/rpc.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/rpc_msg.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/svc.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/svc_auth.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/types.h +h-to-ffi.sh -include ${SDK}/usr/include/rpc/types.h ${SDK}/usr/include/rpc/xdr.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/mount.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rex.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rnusers.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rquota.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rstat.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rusers.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rwall.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/spray.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/yp.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh ${SDK}/usr/include/rune.h +h-to-ffi.sh ${SDK}/usr/include/runetype.h +h-to-ffi.sh ${SDK}/usr/include/sched.h +h-to-ffi.sh ${SDK}/usr/include/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/servers/bootstrap.h +h-to-ffi.sh ${SDK}/usr/include/servers/bootstrap_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/key_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/ls_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/netname.h +h-to-ffi.sh ${SDK}/usr/include/servers/netname_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/nm_defs.h +h-to-ffi.sh ${SDK}/usr/include/setjmp.h +h-to-ffi.sh ${SDK}/usr/include/sgtty.h +h-to-ffi.sh ${SDK}/usr/include/signal.h +h-to-ffi.sh ${SDK}/usr/include/sql.h +h-to-ffi.sh ${SDK}/usr/include/sqlext.h +h-to-ffi.sh ${SDK}/usr/include/sqltypes.h +h-to-ffi.sh ${SDK}/usr/include/stab.h +h-to-ffi.sh ${SDK}/usr/include/standards.h +#h-to-ffi.sh ${SDK}/usr/include/stdarg.h +h-to-ffi.sh ${SDK}/usr/include/stdbool.h +h-to-ffi.sh ${SDK}/usr/include/stddef.h +h-to-ffi.sh ${SDK}/usr/include/stdint.h +h-to-ffi.sh ${SDK}/usr/include/stdio.h +h-to-ffi.sh ${SDK}/usr/include/stdlib.h +h-to-ffi.sh ${SDK}/usr/include/string.h +h-to-ffi.sh ${SDK}/usr/include/strings.h +h-to-ffi.sh ${SDK}/usr/include/struct.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/acct.h +h-to-ffi.sh ${SDK}/usr/include/sys/attr.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/buf.h +#h-to-ffi.sh ${SDK}/usr/include/sys/callout.h +h-to-ffi.sh ${SDK}/usr/include/sys/cdefs.h +#h-to-ffi.sh ${SDK}/usr/include/sys/clist.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/conf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dir.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dirent.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/disk.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/disklabel.h +#h-to-ffi.sh ${SDK}/usr/include/sys/disktab.h +h-to-ffi.sh ${SDK}/usr/include/sys/dkstat.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dmap.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/domain.h +h-to-ffi.sh ${SDK}/usr/include/sys/errno.h +h-to-ffi.sh ${SDK}/usr/include/sys/ev.h +#h-to-ffi.sh ${SDK}/usr/include/sys/exec.h +h-to-ffi.sh ${SDK}/usr/include/sys/fcntl.h +h-to-ffi.sh ${SDK}/usr/include/sys/file.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/filedesc.h +h-to-ffi.sh ${SDK}/usr/include/sys/filio.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/gmon.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioccom.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioctl.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioctl_compat.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ipc.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kdebug.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kern_control.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kern_event.h +h-to-ffi.sh ${SDK}/usr/include/sys/kernel.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ktrace.h +#h-to-ffi.sh ${SDK}/usr/include/sys/linker_set.h +h-to-ffi.sh ${SDK}/usr/include/sys/loadable_fs.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/lock.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/fcntl.h ${SDK}/usr/include/sys/lockf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/malloc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/machine/param.h ${SDK}/usr/include/sys/mbuf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/md5.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/mman.h +h-to-ffi.sh ${SDK}/usr/include/sys/mount.h +h-to-ffi.sh ${SDK}/usr/include/sys/msgbuf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/mtio.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/namei.h +h-to-ffi.sh ${SDK}/usr/include/sys/netport.h +h-to-ffi.sh ${SDK}/usr/include/sys/param.h +h-to-ffi.sh ${SDK}/usr/include/sys/paths.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/sys/proc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/protosw.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ptrace.h +h-to-ffi.sh ${SDK}/usr/include/sys/queue.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/quota.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/random.h +h-to-ffi.sh ${SDK}/usr/include/sys/reboot.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/sys/resource.h ${SDK}/usr/include/sys/resourcevar.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/select.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/sem.h +h-to-ffi.sh ${SDK}/usr/include/sys/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/sys/shm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/signal.h ${SDK}/usr/include/sys/signalvar.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/socket.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/socketvar.h +h-to-ffi.sh ${SDK}/usr/include/sys/sockio.h +h-to-ffi.sh ${SDK}/usr/include/sys/stat.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/sys_domain.h +h-to-ffi.sh ${SDK}/usr/include/sys/syscall.h +h-to-ffi.sh ${SDK}/usr/include/sys/sysctl.h +h-to-ffi.sh ${SDK}/usr/include/sys/syslimits.h +h-to-ffi.sh ${SDK}/usr/include/sys/syslog.h +#h-to-ffi.sh ${SDK}/usr/include/sys/systm.h +h-to-ffi.sh ${SDK}/usr/include/sys/termios.h +h-to-ffi.sh ${SDK}/usr/include/sys/time.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/timeb.h +h-to-ffi.sh ${SDK}/usr/include/sys/times.h +#h-to-ffi.sh ${SDK}/usr/include/sys/tprintf.h +h-to-ffi.sh ${SDK}/usr/include/sys/trace.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/tty.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttychars.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttycom.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttydefaults.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttydev.h +#h-to-ffi.sh ${SDK}/usr/include/sys/types.h +#h-to-ffi.sh ${SDK}/usr/include/sys/ubc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/signal.h ${SDK}/usr/include/sys/ucontext.h +h-to-ffi.sh ${SDK}/usr/include/sys/ucred.h +#h-to-ffi.sh ${SDK}/usr/include/sys/uio.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/un.h +h-to-ffi.sh ${SDK}/usr/include/sys/unistd.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/unpcb.h +h-to-ffi.sh ${SDK}/usr/include/sys/user.h +h-to-ffi.sh ${SDK}/usr/include/sys/utfconv.h +h-to-ffi.sh ${SDK}/usr/include/sys/utsname.h +#h-to-ffi.sh ${SDK}/usr/include/sys/ux_exception.h +h-to-ffi.sh ${SDK}/usr/include/sys/vadvise.h +h-to-ffi.sh ${SDK}/usr/include/sys/vcmd.h +h-to-ffi.sh ${SDK}/usr/include/sys/version.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/sys/vmparam.h ${SDK}/usr/include/sys/vm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/vmmeter.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/sys/vmparam.h +h-to-ffi.sh ${SDK}/usr/include/sys/vnioctl.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/vnode.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/vnode.h ${SDK}/usr/include/sys/vnode_if.h +h-to-ffi.sh ${SDK}/usr/include/sys/wait.h +h-to-ffi.sh ${SDK}/usr/include/sysexits.h +h-to-ffi.sh ${SDK}/usr/include/syslog.h +h-to-ffi.sh ${SDK}/usr/include/tar.h +h-to-ffi.sh ${SDK}/usr/include/TargetConditionals.h +h-to-ffi.sh ${SDK}/usr/include/tcl.h +h-to-ffi.sh ${SDK}/usr/include/tcpd.h +h-to-ffi.sh ${SDK}/usr/include/term.h +h-to-ffi.sh ${SDK}/usr/include/termios.h +h-to-ffi.sh ${SDK}/usr/include/time.h +h-to-ffi.sh ${SDK}/usr/include/ttyent.h +h-to-ffi.sh ${SDK}/usr/include/tzfile.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ffs/ffs_extern.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ffs/fs.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/dinode.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/dir.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/inode.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/lockf.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/quota.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/ufs_extern.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/mount.h ${SDK}/usr/include/ufs/ufs/ufsmount.h +h-to-ffi.sh ${SDK}/usr/include/ulimit.h +h-to-ffi.sh ${SDK}/usr/include/unctrl.h +h-to-ffi.sh ${SDK}/usr/include/unistd.h +h-to-ffi.sh ${SDK}/usr/include/util.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/utime.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/utmp.h +#h-to-ffi.sh ${SDK}/usr/include/vfs/vfs_support.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/vis.h +h-to-ffi.sh ${SDK}/usr/include/zconf.h +h-to-ffi.sh ${SDK}/usr/include/zlib.h Index: /branches/experimentation/later/source/darwin-x86-headers64/addressbook/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/addressbook/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/addressbook/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/addressbook/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/addressbook/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/addressbook/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/addressbook/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/addressbook/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/addressbook/C/populate.sh (revision 8058) @@ -0,0 +1,7 @@ +#!/bin/sh +# For now, things earlier than the 10.5 sdk are pointless +rm -rf System Developer usr +SDK=/Developer/SDKs/MacOSX10.5.sdk +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +rm -rf System Developer usr +h-to-ffi.sh ${SDK}/System/Library/Frameworks/AddressBook.framework/Headers/AddressBook.h Index: /branches/experimentation/later/source/darwin-x86-headers64/cocoa/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/cocoa/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/cocoa/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/cocoa/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/cocoa/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/cocoa/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/cocoa/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/cocoa/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/cocoa/C/populate.sh (revision 8058) @@ -0,0 +1,10 @@ +#!/bin/sh +# For now, things earlier than the 10.5 sdk are pointless +rm -rf System Developer usr +SDK=/Developer/SDKs/MacOSX10.5.sdk +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +h-to-ffi.sh ${SDK}/usr/include/objc/objc-runtime.h +h-to-ffi.sh ${SDK}/usr/include/objc/objc-exception.h +h-to-ffi.sh ${SDK}/usr/include/objc/Object.h +h-to-ffi.sh ${SDK}/usr/include/objc/Protocol.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/Cocoa.framework/Headers/Cocoa.h Index: /branches/experimentation/later/source/darwin-x86-headers64/gl/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/gl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/gl/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/gl/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/gl/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/gl/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/gl/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/gl/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/gl/C/populate.sh (revision 8058) @@ -0,0 +1,12 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.5.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +rm -rf System Developer +h-to-ffi.sh ${SDK}/System/Library/Frameworks/OpenGL.framework/Headers/OpenGL.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/OpenGL.framework/Headers/glu.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/GLUT.framework/Headers/glut.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/AGL.framework/Headers/agl.h Index: /branches/experimentation/later/source/darwin-x86-headers64/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/libc/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/libc/C/populate.sh (revision 8058) @@ -0,0 +1,620 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.4u.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +CFLAGS="-m64 -Wno-endif-labels -isysroot ${SDK}";export CFLAGS +rm -rf usr Developer System +h-to-ffi.sh ${SDK}/usr/include/ar.h +h-to-ffi.sh ${SDK}/usr/include/arpa/ftp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/arpa/inet.h +h-to-ffi.sh ${SDK}/usr/include/arpa/nameser.h +h-to-ffi.sh ${SDK}/usr/include/arpa/nameser_compat.h +h-to-ffi.sh ${SDK}/usr/include/arpa/telnet.h +h-to-ffi.sh ${SDK}/usr/include/arpa/tftp.h +h-to-ffi.sh ${SDK}/usr/include/bitstring.h +h-to-ffi.sh ${SDK}/usr/include/bzlib.h +h-to-ffi.sh ${SDK}/usr/include/c.h +h-to-ffi.sh ${SDK}/usr/include/com_err.h +h-to-ffi.sh ${SDK}/usr/include/crt_externs.h +h-to-ffi.sh ${SDK}/usr/include/ctype.h +h-to-ffi.sh ${SDK}/usr/include/curl/curl.h +h-to-ffi.sh ${SDK}/usr/include/curses.h +h-to-ffi.sh ${SDK}/usr/include/db.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/ev_keymap.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOHIDTypes.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOLLEvent.h +h-to-ffi.sh ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/IOHIDShared.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/cdefs.h ${SDK}/System/Library/Frameworks/IOKit.framework/Headers/hidsystem/event_status_driver.h +h-to-ffi.sh ${SDK}/usr/include/device/device_port.h +h-to-ffi.sh ${SDK}/usr/include/device/device_types.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/dirent.h +h-to-ffi.sh ${SDK}/usr/include/disktab.h +h-to-ffi.sh ${SDK}/usr/include/DNSServiceDiscovery/DNSServiceDiscovery.h +h-to-ffi.sh ${SDK}/usr/include/dlfcn.h +h-to-ffi.sh ${SDK}/usr/include/err.h +h-to-ffi.sh ${SDK}/usr/include/errno.h +h-to-ffi.sh ${SDK}/usr/include/eti.h +h-to-ffi.sh ${SDK}/usr/include/fcntl.h +h-to-ffi.sh ${SDK}/usr/include/float.h +h-to-ffi.sh ${SDK}/usr/include/fnmatch.h +h-to-ffi.sh ${SDK}/usr/include/form.h +h-to-ffi.sh ${SDK}/usr/include/fsproperties.h +h-to-ffi.sh ${SDK}/usr/include/fstab.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/fts.h +h-to-ffi.sh ${SDK}/usr/include/glob.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/grp.h +h-to-ffi.sh ${SDK}/usr/include/gssapi/gssapi_generic.h +h-to-ffi.sh -include ${SDK}/usr/include/gssapi/gssapi.h ${SDK}/usr/include/gssapi/gssapi_krb5.h +# can't find typedef of Str31 +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_encodings.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_format.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/hfs/hfs_mount.h +h-to-ffi.sh ${SDK}/usr/include/histedit.h +#h-to-ffi.sh ${SDK}/usr/include/httpd/httpd.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/ifaddrs.h +h-to-ffi.sh ${SDK}/usr/include/inttypes.h +h-to-ffi.sh ${SDK}/usr/include/iodbcinst.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_mount.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_node.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/cd9660_rrip.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/iso.h +#h-to-ffi.sh ${SDK}/usr/include/isofs/cd9660/iso_rrip.h +h-to-ffi.sh ${SDK}/usr/include/kerberosIV/des.h +h-to-ffi.sh ${SDK}/usr/include/kerberosIV/krb.h +h-to-ffi.sh ${SDK}/usr/include/krb.h +h-to-ffi.sh ${SDK}/usr/include/krb5.h +h-to-ffi.sh ${SDK}/usr/include/kvm.h +h-to-ffi.sh ${SDK}/usr/include/lber.h +h-to-ffi.sh ${SDK}/usr/include/lber_types.h +h-to-ffi.sh ${SDK}/usr/include/ldap.h +h-to-ffi.sh ${SDK}/usr/include/libc.h +h-to-ffi.sh ${SDK}/usr/include/libgen.h +#h-to-ffi.sh ${SDK}/usr/include/libkern/libkern.h +h-to-ffi.sh ${SDK}/usr/include/libkern/OSReturn.h +h-to-ffi.sh ${SDK}/usr/include/libkern/OSTypes.h +h-to-ffi.sh ${SDK}/usr/include/limits.h +h-to-ffi.sh ${SDK}/usr/include/locale.h +h-to-ffi.sh ${SDK}/usr/include/mach/boolean.h +#h-to-ffi.sh ${SDK}/usr/include/mach/boot_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/bootstrap.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_priv.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_reply.h +h-to-ffi.sh ${SDK}/usr/include/mach/clock_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/error.h +h-to-ffi.sh ${SDK}/usr/include/mach/exception.h +h-to-ffi.sh ${SDK}/usr/include/mach/exception_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_priv.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_reboot.h +h-to-ffi.sh ${SDK}/usr/include/mach/host_security.h +h-to-ffi.sh ${SDK}/usr/include/mach/kern_return.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/vm_types.h ${SDK}/usr/include/mach/kmod.h +h-to-ffi.sh ${SDK}/usr/include/mach/ledger.h +h-to-ffi.sh ${SDK}/usr/include/mach/lock_set.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_error.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_host.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_init.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_interface.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_param.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_port.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/message.h ${SDK}/usr/include/mach/mach_syscalls.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_time.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_traps.h +h-to-ffi.sh ${SDK}/usr/include/mach/mach_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/machine.h +h-to-ffi.sh ${SDK}/usr/include/mach/memory_object_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/message.h +h-to-ffi.sh ${SDK}/usr/include/mach/mig.h +h-to-ffi.sh ${SDK}/usr/include/mach/mig_errors.h +h-to-ffi.sh ${SDK}/usr/include/mach/ndr.h +h-to-ffi.sh ${SDK}/usr/include/mach/notify.h +h-to-ffi.sh ${SDK}/usr/include/mach/policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/port.h +h-to-ffi.sh ${SDK}/usr/include/mach/port_obj.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/processor_set.h +h-to-ffi.sh ${SDK}/usr/include/mach/rpc.h +h-to-ffi.sh ${SDK}/usr/include/mach/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/mach/shared_memory_server.h +h-to-ffi.sh ${SDK}/usr/include/mach/std_types.h +h-to-ffi.sh ${SDK}/usr/include/mach/sync.h +h-to-ffi.sh ${SDK}/usr/include/mach/sync_policy.h +#h-to-ffi.sh ${SDK}/usr/include/mach/syscall_sw.h +h-to-ffi.sh ${SDK}/usr/include/mach/task.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_ledger.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/task_special_ports.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_act.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_info.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_policy.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_special_ports.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_status.h +h-to-ffi.sh ${SDK}/usr/include/mach/thread_switch.h +h-to-ffi.sh ${SDK}/usr/include/mach/time_value.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_attributes.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_behavior.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_inherit.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_map.h +h-to-ffi.sh ${SDK}/usr/include/mach/machine/vm_param.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_prot.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/mach_types.h ${SDK}/usr/include/mach/vm_region.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_statistics.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_sync.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_task.h +h-to-ffi.sh ${SDK}/usr/include/mach/vm_types.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/arch.h +h-to-ffi.sh -D__private_extern__=extern ${SDK}/usr/include/mach-o/dyld.h +h-to-ffi.sh -D__private_extern__=extern ${SDK}/usr/include/mach-o/dyld_debug.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/fat.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/getsect.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/ldsyms.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/loader.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/nlist.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/ranlib.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/reloc.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/stab.h +h-to-ffi.sh ${SDK}/usr/include/mach-o/swap.h +h-to-ffi.sh -include ${SDK}/usr/include/mach/machine/vm_types.h ${SDK}/usr/include/mach_debug/hash_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/ipc_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/mach_debug.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/mach_debug_types.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/page_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/vm_info.h +h-to-ffi.sh ${SDK}/usr/include/mach_debug/zone_info.h +h-to-ffi.sh ${SDK}/usr/include/malloc/malloc.h +h-to-ffi.sh ${SDK}/usr/include/math.h +h-to-ffi.sh ${SDK}/usr/include/memory.h +h-to-ffi.sh ${SDK}/usr/include/monitor.h +h-to-ffi.sh ${SDK}/usr/include/nameser.h +h-to-ffi.sh ${SDK}/usr/include/ncurses_dll.h +h-to-ffi.sh ${SDK}/usr/include/ndbm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/net/bpf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/ethernet.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/net/if.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/net/if_arp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/if_dl.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/if_llc.h +h-to-ffi.sh ${SDK}/usr/include/net/if_media.h +h-to-ffi.sh ${SDK}/usr/include/net/if_types.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/kext_net.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/pfkeyv2.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/radix.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/net/route.h +#h-to-ffi.sh ${SDK}/usr/include/net/slcompress.h +#h-to-ffi.sh ${SDK}/usr/include/net/slip.h +#h-to-ffi.sh ${SDK}/usr/include/netat/adsp.h +h-to-ffi.sh ${SDK}/usr/include/netat/appletalk.h +#h-to-ffi.sh ${SDK}/usr/include/netat/asp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_aarp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_ddp_brt.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_pat.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_snmp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/at_var.h +#h-to-ffi.sh ${SDK}/usr/include/netat/atp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/aurp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/ddp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/debug.h +#h-to-ffi.sh ${SDK}/usr/include/netat/ep.h +#h-to-ffi.sh ${SDK}/usr/include/netat/lap.h +#h-to-ffi.sh ${SDK}/usr/include/netat/nbp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/pap.h +#h-to-ffi.sh ${SDK}/usr/include/netat/routing_tables.h +#h-to-ffi.sh ${SDK}/usr/include/netat/rtmp.h +#h-to-ffi.sh ${SDK}/usr/include/netat/sysglue.h +#h-to-ffi.sh ${SDK}/usr/include/netat/zip.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/dll.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/hd_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/hdlc.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/llc_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/pk.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/pk_var.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25_sockaddr.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25acct.h +#h-to-ffi.sh ${SDK}/usr/include/netccitt/x25err.h +h-to-ffi.sh ${SDK}/usr/include/netdb.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/udp.h ${SDK}/usr/include/netinet/bootp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/netinet/icmp6.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/ip_icmp.h ${SDK}/usr/include/netinet/icmp_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/netinet/if_ether.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/netinet/in_systm.h -include ${SDK}/usr/include/netinet/ip.h -include ${SDK}/usr/include/netinet/ip_icmp.h ${SDK}/usr/include/netinet/icmp_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h ${SDK}/usr/include/netinet/if_ether.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/netinet/in.h ${SDK}/usr/include/netinet/igmp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/igmp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_systm.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/in_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_fw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_icmp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_mroute.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_nat.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_proxy.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_state.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/ip_var.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/tcp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_fsm.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_seq.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_timer.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet/tcpip.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/udp.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/netinet/udp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ah.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/esp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/icmp6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_gif.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_ifattach.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_prefix.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/in6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_fw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_mroute.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ip6protosw.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ipcomp.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/ipsec.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mip6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mip6_common.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/mld6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_defs.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_list.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_log.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_soctl.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/natpt_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/nd6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/pim6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/pim6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/udp6.h +#h-to-ffi.sh ${SDK}/usr/include/netinet6/udp6_var.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/_lu_types.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/lookup.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/lookup_types.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni_prot.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/ni_util.h +#h-to-ffi.sh ${SDK}/usr/include/netinfo/nibind_prot.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/argo_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnl.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnp.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/clnp_stat.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cltp_var.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cons.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/cons_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/eonvar.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/esis.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_errno.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_snpac.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/iso_var.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_clnp.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_events.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_ip.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_meas.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_param.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_seq.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_stat.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_states.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_timer.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_tpdu.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_trace.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tp_user.h +#h-to-ffi.sh ${SDK}/usr/include/netiso/tuba_table.h +#h-to-ffi.sh ${SDK}/usr/include/netkey/keydb.h +#h-to-ffi.sh ${SDK}/usr/include/netkey/keysock.h +#h-to-ffi.sh ${SDK}/usr/include/netns/idp.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_error.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_if.h +#h-to-ffi.sh ${SDK}/usr/include/netns/ns_pcb.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spidp.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spp_debug.h +#h-to-ffi.sh ${SDK}/usr/include/netns/spp_var.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/krpc.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfs.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsdiskless.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsm_subs.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsmount.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsnode.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsproto.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsrtt.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nfsrvcache.h +#h-to-ffi.sh ${SDK}/usr/include/nfs/nqnfs.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/nfs/rpcv2.h +h-to-ffi.sh ${SDK}/usr/include/nfs/xdr_subs.h +#h-to-ffi.sh ${SDK}/usr/include/nlist.h +#h-to-ffi.sh ${SDK}/usr/include/NSSystemDirectories.h +#h-to-ffi.sh ${SDK}/usr/include/objc/objc-load.h +#h-to-ffi.sh ${SDK}/usr/include/objc/objc-runtime.h +#h-to-ffi.sh ${SDK}/usr/include/objc/objc.h +#h-to-ffi.sh ${SDK}/usr/include/objc/Object.h +#h-to-ffi.sh ${SDK}/usr/include/objc/Protocol.h +#h-to-ffi.sh ${SDK}/usr/include/objc/zone.h +h-to-ffi.sh ${SDK}/usr/include/openssl/asn1.h +h-to-ffi.sh ${SDK}/usr/include/openssl/asn1_mac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/bio.h +h-to-ffi.sh ${SDK}/usr/include/openssl/blowfish.h +h-to-ffi.sh ${SDK}/usr/include/openssl/bn.h +h-to-ffi.sh ${SDK}/usr/include/openssl/buffer.h +h-to-ffi.sh ${SDK}/usr/include/openssl/cast.h +h-to-ffi.sh ${SDK}/usr/include/openssl/comp.h +h-to-ffi.sh ${SDK}/usr/include/openssl/conf.h +h-to-ffi.sh ${SDK}/usr/include/openssl/conf_api.h +h-to-ffi.sh ${SDK}/usr/include/openssl/crypto.h +h-to-ffi.sh ${SDK}/usr/include/openssl/des.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dh.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dsa.h +h-to-ffi.sh ${SDK}/usr/include/openssl/dso.h +h-to-ffi.sh ${SDK}/usr/include/openssl/e_os2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ebcdic.h +h-to-ffi.sh ${SDK}/usr/include/openssl/err.h +h-to-ffi.sh ${SDK}/usr/include/openssl/evp.h +h-to-ffi.sh ${SDK}/usr/include/openssl/hmac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/lhash.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md4.h +h-to-ffi.sh ${SDK}/usr/include/openssl/md5.h +h-to-ffi.sh ${SDK}/usr/include/openssl/mdc2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/obj_mac.h +h-to-ffi.sh ${SDK}/usr/include/openssl/objects.h +h-to-ffi.sh ${SDK}/usr/include/openssl/opensslconf.h +h-to-ffi.sh ${SDK}/usr/include/openssl/opensslv.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pem.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pem2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pkcs12.h +h-to-ffi.sh ${SDK}/usr/include/openssl/pkcs7.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rand.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc4.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rc5.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ripemd.h +h-to-ffi.sh ${SDK}/usr/include/openssl/rsa.h +h-to-ffi.sh ${SDK}/usr/include/openssl/safestack.h +h-to-ffi.sh ${SDK}/usr/include/openssl/sha.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl2.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl23.h +h-to-ffi.sh ${SDK}/usr/include/openssl/ssl3.h +h-to-ffi.sh ${SDK}/usr/include/openssl/stack.h +h-to-ffi.sh ${SDK}/usr/include/openssl/symhacks.h +h-to-ffi.sh ${SDK}/usr/include/openssl/tls1.h +h-to-ffi.sh ${SDK}/usr/include/openssl/tmdiff.h +h-to-ffi.sh ${SDK}/usr/include/openssl/txt_db.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509_vfy.h +h-to-ffi.sh ${SDK}/usr/include/openssl/x509v3.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_aconf.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_compat.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_macros.h +h-to-ffi.sh ${SDK}/usr/include/pam/_pam_types.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_appl.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_client.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_misc.h +h-to-ffi.sh -include ${SDK}/usr/include/pam/_pam_types.h ${SDK}/usr/include/pam/pam_mod_misc.h +h-to-ffi.sh ${SDK}/usr/include/pam/pam_modules.h +h-to-ffi.sh ${SDK}/usr/include/paths.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/net/bpf.h -include ${SDK}/usr/include/stdio.h ${SDK}/usr/include/pcap-namedb.h +h-to-ffi.sh ${SDK}/usr/include/pcap.h +#h-to-ffi.sh ${SDK}/usr/include/pexpert/boot.h +#h-to-ffi.sh ${SDK}/usr/include/pexpert/pexpert.h +h-to-ffi.sh ${SDK}/usr/include/pexpert/protos.h +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-internal.h +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-kgmon.c +#h-to-ffi.sh ${SDK}/usr/include/profile/profile-mk.h +h-to-ffi.sh ${SDK}/usr/include/profile.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/dumprestore.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/routed.h +h-to-ffi.sh ${SDK}/usr/include/protocols/rwhod.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/talkd.h +#h-to-ffi.sh ${SDK}/usr/include/protocols/timed.h +h-to-ffi.sh ${SDK}/usr/include/pthread.h +h-to-ffi.sh ${SDK}/usr/include/pthread_impl.h +h-to-ffi.sh ${SDK}/usr/include/pwd.h +h-to-ffi.sh ${SDK}/usr/include/ranlib.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/regex.h +#h-to-ffi.sh ${SDK}/usr/include/regexp.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/socket.h -include ${SDK}/usr/include/netinet/in.h -include ${SDK}/usr/include/nameser.h ${SDK}/usr/include/resolv.h +#h-to-ffi.sh ${SDK}/usr/include/rmd160.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/auth.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/auth_unix.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/clnt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_clnt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_prot.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/pmap_rmt.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/rpc.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/rpc_msg.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/svc.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/svc_auth.h +#h-to-ffi.sh ${SDK}/usr/include/rpc/types.h +h-to-ffi.sh -include ${SDK}/usr/include/rpc/types.h ${SDK}/usr/include/rpc/xdr.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/mount.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rex.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rnusers.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rquota.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rstat.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rusers.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/rwall.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/spray.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/yp.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh ${SDK}/usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh ${SDK}/usr/include/rune.h +h-to-ffi.sh ${SDK}/usr/include/runetype.h +h-to-ffi.sh ${SDK}/usr/include/sched.h +h-to-ffi.sh ${SDK}/usr/include/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/servers/bootstrap.h +h-to-ffi.sh ${SDK}/usr/include/servers/bootstrap_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/key_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/ls_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/netname.h +h-to-ffi.sh ${SDK}/usr/include/servers/netname_defs.h +h-to-ffi.sh ${SDK}/usr/include/servers/nm_defs.h +h-to-ffi.sh ${SDK}/usr/include/setjmp.h +h-to-ffi.sh ${SDK}/usr/include/sgtty.h +h-to-ffi.sh ${SDK}/usr/include/signal.h +h-to-ffi.sh ${SDK}/usr/include/sql.h +h-to-ffi.sh ${SDK}/usr/include/sqlext.h +h-to-ffi.sh ${SDK}/usr/include/sqltypes.h +h-to-ffi.sh ${SDK}/usr/include/stab.h +h-to-ffi.sh ${SDK}/usr/include/standards.h +#h-to-ffi.sh ${SDK}/usr/include/stdarg.h +h-to-ffi.sh ${SDK}/usr/include/stdbool.h +h-to-ffi.sh ${SDK}/usr/include/stddef.h +h-to-ffi.sh ${SDK}/usr/include/stdint.h +h-to-ffi.sh ${SDK}/usr/include/stdio.h +h-to-ffi.sh ${SDK}/usr/include/stdlib.h +h-to-ffi.sh ${SDK}/usr/include/string.h +h-to-ffi.sh ${SDK}/usr/include/strings.h +h-to-ffi.sh ${SDK}/usr/include/struct.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/acct.h +h-to-ffi.sh ${SDK}/usr/include/sys/attr.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/buf.h +#h-to-ffi.sh ${SDK}/usr/include/sys/callout.h +h-to-ffi.sh ${SDK}/usr/include/sys/cdefs.h +#h-to-ffi.sh ${SDK}/usr/include/sys/clist.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/conf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dir.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dirent.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/disk.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/disklabel.h +#h-to-ffi.sh ${SDK}/usr/include/sys/disktab.h +h-to-ffi.sh ${SDK}/usr/include/sys/dkstat.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/dmap.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/domain.h +h-to-ffi.sh ${SDK}/usr/include/sys/errno.h +h-to-ffi.sh ${SDK}/usr/include/sys/ev.h +#h-to-ffi.sh ${SDK}/usr/include/sys/exec.h +h-to-ffi.sh ${SDK}/usr/include/sys/fcntl.h +h-to-ffi.sh ${SDK}/usr/include/sys/file.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/filedesc.h +h-to-ffi.sh ${SDK}/usr/include/sys/filio.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/gmon.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioccom.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioctl.h +h-to-ffi.sh ${SDK}/usr/include/sys/ioctl_compat.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ipc.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kdebug.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kern_control.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/kern_event.h +h-to-ffi.sh ${SDK}/usr/include/sys/kernel.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ktrace.h +#h-to-ffi.sh ${SDK}/usr/include/sys/linker_set.h +h-to-ffi.sh ${SDK}/usr/include/sys/loadable_fs.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/lock.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/fcntl.h ${SDK}/usr/include/sys/lockf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/malloc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/machine/param.h ${SDK}/usr/include/sys/mbuf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/md5.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/mman.h +h-to-ffi.sh ${SDK}/usr/include/sys/mount.h +h-to-ffi.sh ${SDK}/usr/include/sys/msgbuf.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/mtio.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/namei.h +h-to-ffi.sh ${SDK}/usr/include/sys/netport.h +h-to-ffi.sh ${SDK}/usr/include/sys/param.h +h-to-ffi.sh ${SDK}/usr/include/sys/paths.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/sys/proc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/protosw.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/ptrace.h +h-to-ffi.sh ${SDK}/usr/include/sys/queue.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/quota.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/random.h +h-to-ffi.sh ${SDK}/usr/include/sys/reboot.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/sys/resource.h ${SDK}/usr/include/sys/resourcevar.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/select.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/sem.h +h-to-ffi.sh ${SDK}/usr/include/sys/semaphore.h +h-to-ffi.sh ${SDK}/usr/include/sys/shm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/signal.h ${SDK}/usr/include/sys/signalvar.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/socket.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/socketvar.h +h-to-ffi.sh ${SDK}/usr/include/sys/sockio.h +h-to-ffi.sh ${SDK}/usr/include/sys/stat.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/sys_domain.h +h-to-ffi.sh ${SDK}/usr/include/sys/syscall.h +h-to-ffi.sh ${SDK}/usr/include/sys/sysctl.h +h-to-ffi.sh ${SDK}/usr/include/sys/syslimits.h +h-to-ffi.sh ${SDK}/usr/include/sys/syslog.h +#h-to-ffi.sh ${SDK}/usr/include/sys/systm.h +h-to-ffi.sh ${SDK}/usr/include/sys/termios.h +h-to-ffi.sh ${SDK}/usr/include/sys/time.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/timeb.h +h-to-ffi.sh ${SDK}/usr/include/sys/times.h +#h-to-ffi.sh ${SDK}/usr/include/sys/tprintf.h +h-to-ffi.sh ${SDK}/usr/include/sys/trace.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/tty.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttychars.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttycom.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttydefaults.h +h-to-ffi.sh ${SDK}/usr/include/sys/ttydev.h +#h-to-ffi.sh ${SDK}/usr/include/sys/types.h +#h-to-ffi.sh ${SDK}/usr/include/sys/ubc.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/signal.h ${SDK}/usr/include/sys/ucontext.h +h-to-ffi.sh ${SDK}/usr/include/sys/ucred.h +#h-to-ffi.sh ${SDK}/usr/include/sys/uio.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/un.h +h-to-ffi.sh ${SDK}/usr/include/sys/unistd.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/unpcb.h +h-to-ffi.sh ${SDK}/usr/include/sys/user.h +h-to-ffi.sh ${SDK}/usr/include/sys/utfconv.h +h-to-ffi.sh ${SDK}/usr/include/sys/utsname.h +#h-to-ffi.sh ${SDK}/usr/include/sys/ux_exception.h +h-to-ffi.sh ${SDK}/usr/include/sys/vadvise.h +h-to-ffi.sh ${SDK}/usr/include/sys/vcmd.h +h-to-ffi.sh ${SDK}/usr/include/sys/version.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h -include ${SDK}/usr/include/sys/vmparam.h ${SDK}/usr/include/sys/vm.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/vmmeter.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/time.h ${SDK}/usr/include/sys/vmparam.h +h-to-ffi.sh ${SDK}/usr/include/sys/vnioctl.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/sys/vnode.h +#h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/vnode.h ${SDK}/usr/include/sys/vnode_if.h +h-to-ffi.sh ${SDK}/usr/include/sys/wait.h +h-to-ffi.sh ${SDK}/usr/include/sysexits.h +h-to-ffi.sh ${SDK}/usr/include/syslog.h +h-to-ffi.sh ${SDK}/usr/include/tar.h +h-to-ffi.sh ${SDK}/usr/include/TargetConditionals.h +h-to-ffi.sh ${SDK}/usr/include/tcl.h +h-to-ffi.sh ${SDK}/usr/include/tcpd.h +h-to-ffi.sh ${SDK}/usr/include/term.h +h-to-ffi.sh ${SDK}/usr/include/termios.h +h-to-ffi.sh ${SDK}/usr/include/time.h +h-to-ffi.sh ${SDK}/usr/include/ttyent.h +h-to-ffi.sh ${SDK}/usr/include/tzfile.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ffs/ffs_extern.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ffs/fs.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/dinode.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/dir.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/inode.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/lockf.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/quota.h +#h-to-ffi.sh ${SDK}/usr/include/ufs/ufs/ufs_extern.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h -include ${SDK}/usr/include/sys/mount.h ${SDK}/usr/include/ufs/ufs/ufsmount.h +h-to-ffi.sh ${SDK}/usr/include/ulimit.h +h-to-ffi.sh ${SDK}/usr/include/unctrl.h +h-to-ffi.sh ${SDK}/usr/include/unistd.h +h-to-ffi.sh ${SDK}/usr/include/util.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/utime.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/utmp.h +#h-to-ffi.sh ${SDK}/usr/include/vfs/vfs_support.h +h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/vis.h +h-to-ffi.sh ${SDK}/usr/include/zconf.h +h-to-ffi.sh ${SDK}/usr/include/zlib.h Index: /branches/experimentation/later/source/darwin-x86-headers64/qtkit/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/qtkit/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/qtkit/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/qtkit/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/qtkit/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/qtkit/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/qtkit/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/qtkit/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/qtkit/C/populate.sh (revision 8058) @@ -0,0 +1,6 @@ +#!/bin/sh +# For now, things earlier than the 10.5 sdk are pointless +rm -rf System Developer usr +SDK=/Developer/SDKs/MacOSX10.5.sdk +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/QTKit.framework/Headers/QTKit.h Index: /branches/experimentation/later/source/darwin-x86-headers64/quartz/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/quartz/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/quartz/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/quartz/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/quartz/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/quartz/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/quartz/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/quartz/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/quartz/C/populate.sh (revision 8058) @@ -0,0 +1,6 @@ +#!/bin/sh +# For now, things earlier than the 10.5 sdk are pointless +rm -rf System Developer usr +SDK=/Developer/SDKs/MacOSX10.5.sdk +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/Quartz.framework/Headers/Quartz.h Index: /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* + Index: /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/quartzcore/C/populate.sh (revision 8058) @@ -0,0 +1,7 @@ +#!/bin/sh +# For now, things earlier than the 10.5 sdk are pointless +rm -rf System Developer usr +SDK=/Developer/SDKs/MacOSX10.5.sdk +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/QuartzCore.framework/Headers/QuartzCore.h + Index: /branches/experimentation/later/source/darwin-x86-headers64/webkit/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/webkit/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/webkit/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/webkit/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/webkit/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/webkit/C/.cvsignore (revision 8058) @@ -0,0 +1,4 @@ +usr* +System* +Developer* +*~.* Index: /branches/experimentation/later/source/darwin-x86-headers64/webkit/C/populate.sh =================================================================== --- /branches/experimentation/later/source/darwin-x86-headers64/webkit/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/darwin-x86-headers64/webkit/C/populate.sh (revision 8058) @@ -0,0 +1,9 @@ +#!/bin/sh +SDK=/Developer/SDKs/MacOSX10.5.sdk +if [ $# -eq 1 ] +then +SDK=$1 +fi +rm -rf System Developer usr +CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS +h-to-ffi.sh ${SDK}/System/Library/Frameworks/WebKit.framework/Headers/WebKit.h Index: /branches/experimentation/later/source/doc/HTML/.cvsignore =================================================================== --- /branches/experimentation/later/source/doc/HTML/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/doc/HTML/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*.html Index: /branches/experimentation/later/source/doc/INFO/.cvsignore =================================================================== --- /branches/experimentation/later/source/doc/INFO/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/doc/INFO/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*.info Index: /branches/experimentation/later/source/examples/.cvsignore =================================================================== --- /branches/experimentation/later/source/examples/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/examples/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/examples/FFI/Allocating-foreign-data-on-the-lisp-heap/ptrtest-compile.sh =================================================================== --- /branches/experimentation/later/source/examples/FFI/Allocating-foreign-data-on-the-lisp-heap/ptrtest-compile.sh (revision 8058) +++ /branches/experimentation/later/source/examples/FFI/Allocating-foreign-data-on-the-lisp-heap/ptrtest-compile.sh (revision 8058) @@ -0,0 +1,4 @@ +#!/bin/sh +cd $1 +echo In directory: `pwd` +gcc -dynamiclib -Wall -o libptrtest.dylib ptrtest.c -install_name ./libptrtest.dylib Index: /branches/experimentation/later/source/examples/FFI/Allocating-foreign-data-on-the-lisp-heap/ptrtest.c =================================================================== --- /branches/experimentation/later/source/examples/FFI/Allocating-foreign-data-on-the-lisp-heap/ptrtest.c (revision 8058) +++ /branches/experimentation/later/source/examples/FFI/Allocating-foreign-data-on-the-lisp-heap/ptrtest.c (revision 8058) @@ -0,0 +1,35 @@ +#include + +void reverse_int_array(int * data, unsigned int dataobjs) +{ + int i, t; + + for(i=0; i + +// First set of tuturial functions + +void +void_void_test(void) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Exited %s:\n", __FUNCTION__); +} + +signed char +sc_sc_test(signed char data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %d\n", (signed int)data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} + +unsigned char +uc_uc_test(unsigned char data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %d\n", (signed int)data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} + +// Second set of tutorial functions + +int +si_si_test(int data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %d\n", data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} + +long +sl_sl_test(long data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %ld\n", data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} + +long long +sll_sll_test(long long data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %lld\n", data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} + +float +f_f_test(float data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %e\n", data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} + +double +d_d_test(double data) +{ + printf("Entered %s:\n", __FUNCTION__); + printf("Data In: %e\n", data); + printf("Exited %s:\n", __FUNCTION__); + return data; +} Index: /branches/experimentation/later/source/examples/FFI/Using-basic-calls-and-types/typetest.lisp =================================================================== --- /branches/experimentation/later/source/examples/FFI/Using-basic-calls-and-types/typetest.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/FFI/Using-basic-calls-and-types/typetest.lisp (revision 8058) @@ -0,0 +1,118 @@ +(defun message (string) + (format t "~a~%~%" string) + (force-output)) + +;; Setup +(message "*** Building the shared library") +(run-program (namestring + (translate-logical-pathname #P"ccl:examples;FFI;Using-basic-calls-and-types;typetest-compile.sh")) + (list + (namestring + (translate-logical-pathname #P"ccl:examples;FFI;Using-basic-calls-and-types"))) + :output t) +(message (format nil "*** Shared libraries (before load): ~a~%~%*** Loading the shared library"ccl::*shared-libraries*)) +(open-shared-library (namestring + (translate-logical-pathname #P"ccl:examples;FFI;Using-basic-calls-and-types;libtypetest.dylib"))) +(message (format nil "*** Shared libraries (after load): ~a"ccl::*shared-libraries*)) + +;; First set of tutorial function calls +(message "*** Calling first group of test functions") +; test the basics +(message + (format nil + "_void_void_test: ~a" + (external "_void_void_test"))) +(message + (format nil + "_sc_sc_test: ~a" + (external "_sc_sc_test"))) +(message + (format nil + "_uc_uc_test: ~a" + (external "_uc_uc_test"))) +(message + (format nil + "functiondoesnotexist: ~a" +(external "functiondoesnotexist"))) +(message + (format nil + "_void_void_test returned: ~a" + (external-call "_void_void_test" + :void))) +(message + (format nil + "_sc_sc_test returned: ~a" + (external-call "_sc_sc_test" + :signed-byte -128 + :signed-byte))) +; value exceeding limit and clips +(message "* The following calls will exceed limits and clip results:") +(message + (format nil + "_sc_sc_test returned: ~a" + (external-call "_sc_sc_test" + :signed-byte -567 + :signed-byte))) +(message + (format nil + "_uc_uc_test returned: ~a" + (external-call "_uc_uc_test" + :unsigned-byte 255 + :unsigned-byte))) +(message + (format nil + "_uc_uc_test returned: ~a" + (external-call "_uc_uc_test" + :unsigned-byte 567 + :unsigned-byte))) +(message + (format nil + "_uc_uc_test returned: ~a" + (external-call "_uc_uc_test" + :unsigned-byte -567 + :unsigned-byte))) + +;; Second set of tutorial function calls +(message "*** Calling second group of test functions") +(message + (format nil + "_si_si_test returned: ~a" + (external-call "_si_si_test" + :signed-fullword -178965 + :signed-fullword))) +(message "* Longs are the same size as ints") +(message + (format nil + "_sl_sl_test returned: ~a" + (external-call "_sl_sl_test" + :signed-fullword -178965 + :signed-fullword))) +(message + (format nil + "_sll_sll_test returned: ~a" + (external-call "_sll_sll_test" + :signed-doubleword -973891578912 + :signed-doubleword))) +(message "* Mistakenly calling sl_sl_test() for sll_sll_test(), thinking that a long is actually a doubleword:") +(message + (format nil + "_sl_sl_test returned: ~a" + (external-call "_sl_sl_test" + :signed-doubleword -973891578912 + :signed-doubleword))) + +;; Third set of tutuorial function calls +(message "*** Calling the third group of test functions") + +(message + (format nil + "_f_f_test returned: ~a" + (external-call "_f_f_test" + :single-float -1.256791e+11 + :single-float))) +(message + (format nil + "_d_d_test returned: ~a" + (external-call "_d_d_test" + :double-float -1.256791d+290 + :double-float))) Index: /branches/experimentation/later/source/examples/README-OPENMCL-EXAMPLES =================================================================== --- /branches/experimentation/later/source/examples/README-OPENMCL-EXAMPLES (revision 8058) +++ /branches/experimentation/later/source/examples/README-OPENMCL-EXAMPLES (revision 8058) @@ -0,0 +1,184 @@ + +LinuxPPC-specific examples: + +Prerequisites. + All of these example programs require OpenMCL 0.9 or later. + Most additionally require that X11 runtime libraries are installed, + and that OpenMCL is running under an X server. + Additional libraries may also be required. One way to check for + the presence of a shared library named "LIBNAME.so" is to do: + +% /sbin/ldconfig -p | fgrep LIBNAME.so + + If that returns a line of the form: + + LIBNAME.so () => /path/to/some/lib/on/your/system + + you're in luck; if it doesn't, you may have to hunt around to + find a package (.deb, .rpm, ...) which contains the library in + a form that's appropriate for your Linux distribution. Different + distributions package things differently, and packages often + depend on other packages; it's hard to be specific about what a + given distribution needs, but I'll try to provide some hints. + + Beginning with release 0.9, OpenMCL uses "interface directories", + to try to modularize its interface database somewhat. If any of + these examples need interface directories that aren't distributed + with OpenMCL, the example's description will note that. ("interface + directories" are subdirectories of "ccl:headers;" that contain - + among other things - a set of files whose extension is "db".) + +---------------------------------------------------------------------- +file: "opengl-ffi.lisp" +description: 2d Gasket example taken from + "Interactive Computer Graphics: + A Top-Down Approach with OpenGL" by Ed Angel +contributor: Hamilton Link +interface-dir: gl ; distributed with OpenMCL +libraries: libGL.so ; may be part of a "mesa" or "opengl" package + libGLU.so ; may be part of a "mesa" or "opengl" package + libglut.so ; may be part of a "glutg3" or "glutg3-dev" package +invocation: +? (require "opengl-ffi") +? (2dgasket::main) +notes: +OpenGL doesn't seem to provide a way to do event handling incrementally +or concurrently with OpenMCL; when its event handling function finishes +(when the OpenGL window closes), the OpenMCL process will exit and when +the OpenGL event-loop is active, OpenMCL isn't responsive.) +It's possible that the "gtkglarea" package would provide a way of doing +OpenGL graphics in a way that's a little less intrusive. +---------------------------------------------------------------------- +file: "gtk-clock.lisp" +description: A double-buffered analog clock, derived from the + double-buffered clock example in "Developing Linux Applications + with GDK and GTK+", Eric Harlow, (c) 1999 New Riders Publishing. +contributor: Clozure +interface-dir: gtk ; distributed with OpenMCL +libraries: libgtk.so ; may be part of a "libgtk-1.2" package +invocation: +? (require "gtk-clock") +? (ccl::gtk-clock) +notes: +The clock is reentrant: it should be possible to call (ccl::gtk-clock) +multiple times, and clutter your desktop with way too many +clocks. +---------------------------------------------------------------------- +file: "gtk-minesweepr.lisp" +description: An implementation of the Minesweeper game, derived from the + Minesweeper example in "Developing Linux Applications + with GDK and GTK+", Eric Harlow, (c) 1999 New Riders Publishing. +contributor: Clozure +interface-dir: gtk ; distributed with OpenMCL +libraries: libgtk.so ; may be part of a "libgtk-1.2" package +invocation: +? (require "gtk-minesweeper") +? (minesweeper:minesweeper) +notes: +Minesweeper -isn't- reentrant (too much state is kept in global variables); +if you try to invoke (minesweeper:minesweeper) while a minesweeper window +is already active, it'll let you close the old window or abort the attempt +to open a new one. + +I found that there were display issues with the way that GtkToggleButtons +were used in the original program and made a subclass - GtkQuietToggelButton - +that handles "enter" and "leave" events differently. The quiet buttons are +probably better (you can do + +? (setq MINESWEEPER::*MINESWEEPER-USE-QUIET-TOGGLE-BUTTONS* nil) + +to use the original implementation), but some display artifacts remain. +There may be a better approach to the problem than the one I took, and +I'd have to assume that GTK is flexible enough to offer a solution. + +Maybe not the world's best Minesweeper game, but the only one I know of +that allows you to develop CL programs while you're playing ... + +---------------------------------------------------------------------- +file: "gtk-step.lisp" +description: An alternate user interface to OpenMCL's STEP command. +contributor: Clozure +interface-dir: gtk ; distributed with OpenMCL +libraries: libgtk.so ; may be part of a "libgtk-1.2" package +invocation: +? (require "gtk-step") +? (step ) +Notes: +Since OpenMCL is essentially a "compile-only" implementation, one has +to take special ... steps to ensure that STEP will step through evaluated +code. (This is true regardless of what user interface STEP uses.) + +Most of the STEP output is displayed in a GtkText widget; it often feels +like it's dragging a reluctant vertical scrollbar with it, fighting tooth +and nail to convince that scrollbar to scroll to where the most recent +output is. I sincerely hope that I'm doing something wrong here ... + +------------- +MacOSX-specific examples: +(These currently depend on the Cocoa application framework, which is part +of MacOSX. In the future, they may also work under Linux and/or Darwin +with the GNUstep application framework (an opensource implementation of +the OpenSTEP framework on which Cocoa is based.) + +---------------------------------------------------------------------- +file: "cocoa.lisp" +description: A preliminary Cocoa-based lisp development system +contributor: Clozure +interface-dir: cocoa ; distributed with OpenMCL +libraries: /System/Library/Frameworks/Cocoa.framework/Cocoa +invocation: +? (require "COCOA") +After a few seconds, an "OpenMCL" dock entry should appear, identifying +a new window layer in which a Cocoa-based listener and OpenMCL menubar +should be present. There's a text editor that supports basic Emacs-style +key bindings for cursor movement, etc.; it isn't (yet) very lisp-aware. + +---------------------------------------------------------------------- +file: "cocoa-inspector.lisp" +description: A browser-style inspector for the preliminary Cocoa IDE. +contributor: Clozure +interface-dir: cocoa ; distributed with OpenMCL +libraries: /System/Library/Frameworks/Cocoa.framework/Cocoa +invocation: +? (require "COCOA-INSPECTOR") +This loads the Cocoa IDE and adds support for graphically inspecting +Lisp objects: +? (ccl::cinspect
) + +Hopefully, we'll be able to tie this in (to the Cocoa editor/listener, +to the menubar, to the CL:INSPECT function ...) in the near future. + +---------------------------------------------------------------------- +file: "cocoa-application.lisp" +description: Save the "preliminary Cocoa IDE" as a double-clickable + MacOSX application bundle +contributor: Clozure +interface-dir: cocoa ; distributed with OpenMCL +libraries: /System/Library/Frameworks/Cocoa.framework/Cocoa +invocation: +? (require "COCOA-APPLICATION") ; after first carefully reading the + ; comments in that file. + +It may be a little premature to worry about this (since the Cocoa IDE +is still pretty feature-starved.) It -does- demonstrate that it's +possible to make .nib-based, double-clickable applications in OpenMCL, +and I think that it's reasonable to assume that the process will get +smoother in the future. + +Platform-neutral examples: + + +file: "finger.lisp" +description: An RFC 1288 "finger" protocol client and server +contributor: Barry Perryman +interface-dir: libc ; distributed with OpenMCL +libraries: +invocation: (require "FINGER") + +This is a clear, self-contained example of TCP programming in OpenMCL. +Note that it may not be possible to run a FINGER server on the standard +port (79), since doing so may require root privileges (and since there +may already be a finger service running on that port, via inetd/xinetd.) + +I suppose that I should also say that one should always exercise caution +when running any type of server on a machine connected to the Internet. Index: /branches/experimentation/later/source/examples/addressbook.lisp =================================================================== --- /branches/experimentation/later/source/examples/addressbook.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/addressbook.lisp (revision 8058) @@ -0,0 +1,30 @@ +;;; This code is adapted from the webkit example and with help +;;; from Richard Cook and Gary Byers on the OpenMCL list. +;;; Things have changed since then, and it's hopefully easier +;;; to use add-on Cocoa frameworks than it once was. +;;; All this does is to try to make it possible to use AddressBook + +(in-package ccl) + +;;; We need to be able to point the CoreFoundation and Cocoa libraries +;;; at some bundle very early in the process. If you want to use some +;;; other bundle path, you may need to change the call to FAKE-CFBUNDLE-PATH +;;; below. + +#+darwin-target +(progn + (require "FAKE-CFBUNDLE-PATH") + (fake-cfbundle-path "ccl:OpenMCL.app;Contents;MacOS;dppccl")) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "OBJC-SUPPORT")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (objc:load-framework "AddressBook" :addressbook)) + +;;; Now, someone should write some code which tries to +;;; actually -use- AddessBook, perhaps via Bosco. It's +;;; probably easier to experiment with AddressBook if +;;; the demo IDE is loaded. + Index: /branches/experimentation/later/source/examples/cocoa/.cvsignore =================================================================== --- /branches/experimentation/later/source/examples/cocoa/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/CurrencyConverter.nib/designable.nib =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/CurrencyConverter.nib/designable.nib (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/CurrencyConverter.nib/designable.nib (revision 8058) @@ -0,0 +1,2923 @@ + + + + 1050 + 9A581 + 629 + 949 + 343.00 + + YES + + + + + YES + com.apple.InterfaceBuilder.CocoaPlugin + + + YES + + NSApplication + + + FirstResponder + + + + + + AMainMenu + + YES + + + Currency Converter + + 1048576 + 2147483647 + + NSImage + NSMenuCheckmark + + + + NSMenuMixedState + + submenuAction: + + + + YES + + + About Currency Converter + + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + UHJlZmVyZW5jZXPigKY + , + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Services + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + _NSServicesMenu + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Hide Currency Converter + h + 1048576 + 2147483647 + + + + + + Hide Others + + 1572864 + 2147483647 + + + + + + Show All + + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Quit Currency Converter + q + 1048576 + 2147483647 + + + + + _NSAppleMenu + + + + + File + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + New + n + 1048576 + 2147483647 + + + + + + T3BlbuKApg + o + 1048576 + 2147483647 + + + + + + Open Recent + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Clear Menu + + 1048576 + 2147483647 + + + + + _NSRecentDocumentsMenu + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Close + w + 1048576 + 2147483647 + + + + + + Save + s + 1048576 + 2147483647 + + + + + + U2F2ZSBBc+KApg + S + 1179648 + 2147483647 + + + + + + Revert to Saved + + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Page Setup... + P + 1179648 + 2147483647 + + + + + + + UHJpbnTigKY + p + 1048576 + 2147483647 + + + + + + + + + Edit + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Undo + z + 1048576 + 2147483647 + + + + + + Redo + Z + 1179648 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Cut + x + 1048576 + 2147483647 + + + + + + Copy + c + 1048576 + 2147483647 + + + + + + Paste + v + 1048576 + 2147483647 + + + + + + Delete + + 1048576 + 2147483647 + + + + + + Select All + a + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Find + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + RmluZOKApg + f + 1048576 + 2147483647 + + + 1 + + + + Find Next + g + 1048576 + 2147483647 + + + 2 + + + + Find Previous + G + 1179648 + 2147483647 + + + 3 + + + + Use Selection for Find + e + 1048576 + 2147483647 + + + 7 + + + + Jump to Selection + j + 1048576 + 2147483647 + + + + + + + + + Spelling and Grammar + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + U2hvdyBTcGVsbGluZ+KApg + : + 1048576 + 2147483647 + + + + + + Check Spelling + ; + 1048576 + 2147483647 + + + + + + Check Spelling While Typing + + 1048576 + 2147483647 + + + + + + Check Grammar With Spelling + + 1048576 + 2147483647 + + + + + + + + + Substitutions + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Smart Copy/Paste + + 2147483647 + + + 1 + + + + Smart Quotes + + 2147483647 + + + 2 + + + + Smart Links + + 2147483647 + + + 3 + + + + + + + Speech + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Start Speaking + + 1048576 + 2147483647 + + + + + + Stop Speaking + + 1048576 + 2147483647 + + + + + + + + + + + + Format + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Show Fonts + t + 1048576 + 2147483647 + + + + + + Show Colors + C + 1179648 + 2147483647 + + + + + + + + + View + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Show Toolbar + + 1572864 + 2147483647 + + + + + + Q3VzdG9taXplIFRvb2xiYXLigKY + + 1048576 + 2147483647 + + + + + + + + + Window + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Minimize + m + 1048576 + 2147483647 + + + + + + Zoom + + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Bring All to Front + + 1048576 + 2147483647 + + + + + _NSWindowsMenu + + + + + Help + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Currency Converter Help + ? + 1048576 + 2147483647 + + + + + + + + _NSMainMenu + + + 7 + 2 + {{306, 767}, {350, 189}} + 611844096 + + NSWindow + + + + 256 + + YES + + + 268 + {{195, 147}, {135, 22}} + + + YES + + -1804468671 + 272630784 + + + LucidaGrande + 1.300000e+01 + 1044 + + + YES + + 6 + System + textBackgroundColor + + 3 + MQA + + + + 6 + + textColor + + 3 + MAA + + + + + + + 268 + {{195, 115}, {135, 22}} + + + YES + + -1804468671 + 272630784 + + + + YES + + + + + + + 268 + {{195, 83}, {135, 22}} + + + YES + + -2072904127 + 272630784 + + + + YES + + + + + + + 268 + {{47, 149}, {143, 17}} + + + YES + + 67239488 + 71304192 + Exchange rate per $1: + + + + 6 + + controlColor + + 3 + MC42NjY2NjY2OQA + + + + 6 + + controlTextColor + + + + + + + 268 + {{67, 115}, {123, 17}} + + + YES + + 67239488 + 71304192 + Dollars to Convert: + + + + + + + + + 268 + {{17, 83}, {173, 17}} + + + YES + + 67239488 + 71304192 + Amount in other Currency: + + + + + + + + + 268 + {{214, 12}, {96, 32}} + + + YES + + 67239424 + 134217728 + Convert + + + -2038284033 + 129 + + DQ + 200 + 25 + + + + + 12 + {{20, 58}, {310, 5}} + + + {0, 0} + + 67239424 + 0 + Box + + + + 3 + MCAwLjgwMDAwMDAxAA + + + 3 + 2 + 0 + NO + + + {350, 189} + + + + {{0, 0}, {1920, 1178}} + + + Converter + + + ConverterController + + + + + YES + + + performMiniaturize: + + + + 37 + + + + arrangeInFront: + + + + 39 + + + + print: + + + + 86 + + + + runPageLayout: + + + + 87 + + + + clearRecentDocuments: + + + + 127 + + + + orderFrontStandardAboutPanel: + + + + 142 + + + + performClose: + + + + 193 + + + + toggleContinuousSpellChecking: + + + + 222 + + + + undo: + + + + 223 + + + + copy: + + + + 224 + + + + checkSpelling: + + + + 225 + + + + paste: + + + + 226 + + + + stopSpeaking: + + + + 227 + + + + cut: + + + + 228 + + + + showGuessPanel: + + + + 230 + + + + redo: + + + + 231 + + + + selectAll: + + + + 232 + + + + startSpeaking: + + + + 233 + + + + delete: + + + + 235 + + + + performZoom: + + + + 240 + + + + performFindPanelAction: + + + + 241 + + + + centerSelectionInVisibleArea: + + + + 245 + + + + toggleGrammarChecking: + + + + 347 + + + + toggleSmartInsertDelete: + + + + 355 + + + + toggleAutomaticQuoteSubstitution: + + + + 356 + + + + toggleAutomaticLinkDetection: + + + + 357 + + + + showHelp: + + + + 360 + + + + orderFrontColorPanel: + + + + 361 + + + + saveDocument: + + + + 362 + + + + saveDocumentAs: + + + + 363 + + + + revertDocumentToSaved: + + + + 364 + + + + runToolbarCustomizationPalette: + + + + 365 + + + + toggleToolbarShown: + + + + 366 + + + + hide: + + + + 369 + + + + hideOtherApplications: + + + + 370 + + + + terminate: + + + + 371 + + + + unhideAllApplications: + + + + 372 + + + + nextKeyView + + + + 390 + + + + + + + + 391 + + + + initialFirstResponder + + + + 392 + + + + rateField + + + + 396 + + + + dollarField + + + + 397 + + + + amountField + + + + 398 + + + + converter + + + + 399 + + + + convert: + + + + 400 + + + + + YES + + 0 + + YES + + + + + + -2 + + + RmlsZSdzIE93bmVyA + + + -1 + + + First Responder + + + -3 + + + Application + + + 29 + + + YES + + + + + + + + + + MainMenu + + + 19 + + + YES + + + + + + 56 + + + YES + + + + + + 103 + + + YES + + + + 1 + + + 217 + + + YES + + + + + + 83 + + + YES + + + + + + 81 + + + YES + + + + + + + + + + + + + + + + 75 + + + 3 + + + 80 + + + 8 + + + 78 + + + 6 + + + 72 + + + + + 82 + + + 9 + + + 124 + + + YES + + + + + + 77 + + + 5 + + + 73 + + + + + + 79 + + + 7 + + + 112 + + + 10 + + + 74 + + + 2 + + + 125 + + + YES + + + + + + 126 + + + + + 205 + + + YES + + + + + + + + + + + + + + + + + + 202 + + + + + 198 + + + + + 207 + + + + + 214 + + + + + 199 + + + + + 203 + + + + + 197 + + + + + 206 + + + + + 215 + + + + + 218 + + + YES + + + + + + 216 + + + YES + + + + + + 200 + + + YES + + + + + + + + + 219 + + + + + 201 + + + + + 204 + + + + + 220 + + + YES + + + + + + + + + + 213 + + + + + 210 + + + + + 221 + + + + + 208 + + + + + 209 + + + + + 106 + + + YES + + + + + + + 111 + + + + + 57 + + + YES + + + + + + + + + + + + + + + + 58 + + + + + 134 + + + + + 150 + + + + + 136 + + + 1111 + + + 144 + + + + + 129 + + + 121 + + + 143 + + + + + 236 + + + + + 131 + + + YES + + + + + + 149 + + + + + 145 + + + + + 130 + + + + + 24 + + + YES + + + + + + + + + 92 + + + + + 5 + + + + + 239 + + + + + 23 + + + + + 295 + + + YES + + + + + + 296 + + + YES + + + + + + + 297 + + + + + 298 + + + + + 299 + + + YES + + + + + + 300 + + + YES + + + + + + + 344 + + + + + 345 + + + + + 211 + + + YES + + + + + + 212 + + + YES + + + + + + + 195 + + + + + 196 + + + + + 346 + + + + + 348 + + + YES + + + + + + 349 + + + YES + + + + + + + + 350 + + + + + 351 + + + + + 354 + + + + + 367 + + + YES + + + + + + 368 + + + YES + + + + + + + + + + + + + 373 + + + YES + + + + + + 374 + + + + + 375 + + + YES + + + + + + 376 + + + + + 377 + + + YES + + + + + + 378 + + + + + 379 + + + YES + + + + + + 380 + + + + + 381 + + + YES + + + + + + 382 + + + + + 383 + + + YES + + + + + + 384 + + + + + 385 + + + YES + + + + + + 386 + + + + + 389 + + + + + 394 + + + + + 395 + + + + + + + YES + + YES + -1.IBPluginDependency + -2.IBPluginDependency + -3.IBPluginDependency + 103.IBPluginDependency + 103.ImportedFromIB2 + 106.IBPluginDependency + 106.ImportedFromIB2 + 106.editorWindowContentRectSynchronizationRect + 111.IBPluginDependency + 111.ImportedFromIB2 + 112.IBPluginDependency + 112.ImportedFromIB2 + 124.IBPluginDependency + 124.ImportedFromIB2 + 125.IBPluginDependency + 125.ImportedFromIB2 + 125.editorWindowContentRectSynchronizationRect + 126.IBPluginDependency + 126.ImportedFromIB2 + 129.IBPluginDependency + 129.ImportedFromIB2 + 130.IBPluginDependency + 130.ImportedFromIB2 + 130.editorWindowContentRectSynchronizationRect + 131.IBPluginDependency + 131.ImportedFromIB2 + 134.IBPluginDependency + 134.ImportedFromIB2 + 136.IBPluginDependency + 136.ImportedFromIB2 + 143.IBPluginDependency + 143.ImportedFromIB2 + 144.IBPluginDependency + 144.ImportedFromIB2 + 145.IBPluginDependency + 145.ImportedFromIB2 + 149.IBPluginDependency + 149.ImportedFromIB2 + 150.IBPluginDependency + 150.ImportedFromIB2 + 19.IBPluginDependency + 19.ImportedFromIB2 + 195.IBPluginDependency + 195.ImportedFromIB2 + 196.IBPluginDependency + 196.ImportedFromIB2 + 197.IBPluginDependency + 197.ImportedFromIB2 + 198.IBPluginDependency + 198.ImportedFromIB2 + 199.IBPluginDependency + 199.ImportedFromIB2 + 200.IBPluginDependency + 200.ImportedFromIB2 + 200.editorWindowContentRectSynchronizationRect + 201.IBPluginDependency + 201.ImportedFromIB2 + 202.IBPluginDependency + 202.ImportedFromIB2 + 203.IBPluginDependency + 203.ImportedFromIB2 + 204.IBPluginDependency + 204.ImportedFromIB2 + 205.IBPluginDependency + 205.ImportedFromIB2 + 205.editorWindowContentRectSynchronizationRect + 206.IBPluginDependency + 206.ImportedFromIB2 + 207.IBPluginDependency + 207.ImportedFromIB2 + 208.IBPluginDependency + 208.ImportedFromIB2 + 209.IBPluginDependency + 209.ImportedFromIB2 + 210.IBPluginDependency + 210.ImportedFromIB2 + 211.IBPluginDependency + 211.ImportedFromIB2 + 212.IBPluginDependency + 212.ImportedFromIB2 + 212.editorWindowContentRectSynchronizationRect + 213.IBPluginDependency + 213.ImportedFromIB2 + 214.IBPluginDependency + 214.ImportedFromIB2 + 215.IBPluginDependency + 215.ImportedFromIB2 + 216.IBPluginDependency + 216.ImportedFromIB2 + 217.IBPluginDependency + 217.ImportedFromIB2 + 218.IBPluginDependency + 218.ImportedFromIB2 + 219.IBPluginDependency + 219.ImportedFromIB2 + 220.IBPluginDependency + 220.ImportedFromIB2 + 220.editorWindowContentRectSynchronizationRect + 221.IBPluginDependency + 221.ImportedFromIB2 + 23.IBPluginDependency + 23.ImportedFromIB2 + 236.IBPluginDependency + 236.ImportedFromIB2 + 239.IBPluginDependency + 239.ImportedFromIB2 + 24.IBPluginDependency + 24.ImportedFromIB2 + 24.editorWindowContentRectSynchronizationRect + 29.IBPluginDependency + 29.ImportedFromIB2 + 29.WindowOrigin + 29.editorWindowContentRectSynchronizationRect + 295.IBPluginDependency + 296.IBPluginDependency + 296.editorWindowContentRectSynchronizationRect + 297.IBPluginDependency + 298.IBPluginDependency + 299.IBPluginDependency + 300.IBPluginDependency + 300.editorWindowContentRectSynchronizationRect + 344.IBPluginDependency + 345.IBPluginDependency + 346.IBPluginDependency + 346.ImportedFromIB2 + 348.IBPluginDependency + 348.ImportedFromIB2 + 349.IBPluginDependency + 349.ImportedFromIB2 + 349.editorWindowContentRectSynchronizationRect + 350.IBPluginDependency + 350.ImportedFromIB2 + 351.IBPluginDependency + 351.ImportedFromIB2 + 354.IBPluginDependency + 354.ImportedFromIB2 + 367.IBPluginDependency + 367.IBWindowTemplateEditedContentRect + 367.NSWindowTemplate.visibleAtLaunch + 367.editorWindowContentRectSynchronizationRect + 368.IBPluginDependency + 373.IBPluginDependency + 374.IBPluginDependency + 375.IBPluginDependency + 376.IBPluginDependency + 377.IBPluginDependency + 378.IBPluginDependency + 379.IBPluginDependency + 380.IBPluginDependency + 381.IBPluginDependency + 382.IBPluginDependency + 383.IBPluginDependency + 384.IBPluginDependency + 385.IBPluginDependency + 386.IBPluginDependency + 389.IBPluginDependency + 394.IBPluginDependency + 395.IBPluginDependency + 5.IBPluginDependency + 5.ImportedFromIB2 + 56.IBPluginDependency + 56.ImportedFromIB2 + 57.IBPluginDependency + 57.ImportedFromIB2 + 57.editorWindowContentRectSynchronizationRect + 58.IBPluginDependency + 58.ImportedFromIB2 + 72.IBPluginDependency + 72.ImportedFromIB2 + 73.IBPluginDependency + 73.ImportedFromIB2 + 74.IBPluginDependency + 74.ImportedFromIB2 + 75.IBPluginDependency + 75.ImportedFromIB2 + 77.IBPluginDependency + 77.ImportedFromIB2 + 78.IBPluginDependency + 78.ImportedFromIB2 + 79.IBPluginDependency + 79.ImportedFromIB2 + 80.IBPluginDependency + 80.ImportedFromIB2 + 81.IBPluginDependency + 81.ImportedFromIB2 + 81.editorWindowContentRectSynchronizationRect + 82.IBPluginDependency + 82.ImportedFromIB2 + 83.IBPluginDependency + 83.ImportedFromIB2 + 92.IBPluginDependency + 92.ImportedFromIB2 + + + YES + + + + + + + + {{532, 981}, {242, 23}} + + + + + + + + + {{522, 812}, {146, 23}} + + + + + + + {{436, 809}, {64, 6}} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {{608, 612}, {275, 83}} + + + + + + + + + + + {{301, 761}, {243, 243}} + + + + + + + + + + + + + + + {{608, 612}, {167, 43}} + + + + + + + + + + + + + + + + + {{608, 612}, {241, 103}} + + + + + + + + + + + {{461, 931}, {197, 73}} + + + {74, 862} + {{88, 1004}, {505, 20}} + + + {{411, 961}, {234, 43}} + + + + + {{345, 961}, {176, 43}} + + + + + + + + + {{440, 714}, {177, 63}} + + + + + + + + {{87, 713}, {350, 189}} + + + + + + + + + + + + + + + + + + + + + + + + + + + {{100, 821}, {271, 183}} + + + + + + + + + + + + + + + + + + + + + {{259, 801}, {199, 203}} + + + + + + + + + + YES + + YES + + + YES + + + + + YES + + YES + + + YES + + + + 400 + + + + YES + + + + + + id + + + YES + + YES + + + + + + + YES + + + + + + + + IBUserSource + + + + + + + + myAction1: + + + + YES + + YES + + + YES + + + + + + + + + + 0 + + 3 + + YnBsaXN0MDDUAAEAAgADAAQABQAGAAkAClgkdmVyc2lvblQkdG9wWSRhcmNoaXZlclgkb2JqZWN0cxIA +AYag0QAHAAhdSUIub2JqZWN0ZGF0YYABXxAPTlNLZXllZEFyY2hpdmVyrxECfAALAAwAMQA1ADYAPAA9 +AEIAVgBXAFgAWQALAGYAcQB9AH4AkACRAJkAmgCdAKcAqACpAK4AsAC1ALYAuQC9AMMAywDMANQA3ADd +AOYA7gDvAPgA+QD+AP8BAgEHAQgBEAERARgBGQEhASIBKQEqATIBMwFGAUcBSAFLAU4BXwFgAWEBZwFo +AWsBbgFyAAsBcwF1AXYBeQF9Aa0BswHDAcgByQHKAc8B0AHRAdQB2AHZAdwB3QHhAecB6gHrAewB7wHz +AfsB/wIAAgECAgIGAg0CEQISAhMCFwIeAh8CIAIkAi0CLgIvAjACNAI7AjwCPQJCAkMCRwJOAlMCVAJV +AlYCWgJhAmUCZgJnAmgCbAJzAngCeQJ6AnsCfwKGAooCiwKMAo0CkQKaAp4CnwKgAqQCqwKsAq0CrgKy +ArkCugK7ArwCwALHAsgCyQLKAs4C1QLWAtcC2wLjAuQC5QLmAuoC8QL1AvYC9wL4AvwDAwMEAwUDCQMQ +AxUDFgMXAxsDIgMjAyQDJQMpAzADMQMyAzYDPQM+Az8DQANEA0sDTANNA1IDUwNXA14DYgNjA2QDZQNp +A3ADcQNyA3MDdwN+A38DgAOFA4gDiQOKA44DlQOWA5cDmwOiA6MDpAOlA6kDsAOxA7IDtwO4A7wDwwPE +A8UDyQPQA9ED0gPTA9cD3gPfA+AD4QPlA+wD7QPuA/MD+gP7A/wEAQQCBAYEDQQOBA8EFAQVBBkEIAQh +BCIEIwQoBCwEMwQ3BDgEOQQ6BKEErAS1BLYEvQTGBMcEyQTUBNUE1gTbBOQE6QTVBOoE+gUDBQwFFQTV +BRYFHgUlBSYFJwUuBS8FMAU3BTgFOQVCBNUFQwVKBVME1QVUBVoFXwVgBWMFZAVtBXQFdQV+BNUFfwWD +BYoFiwWMBZMFlAWVBNUFngWsBbUE1QW+BccFyAXPBdAF0QXSBeAF6QTVBeoF7gXvBfgE1QYBBgIGBwYQ +BNUGEQYWBNUGHwTVBigGKQYzBjQGNwY5BqAHCAdwB3EHcgdzB3QHdQd2B3cHeAd5B3oHewd8B30Hfgd/ +B4AHgQeCB4MHhAeFB4YHhweIB4kHigeLB4wHjQeOB48HkAeRB5IHkweUB5UHlgeXB5gHmQeaB5sHnAed +B54HnwegB6EHogejB6QHpQemB6cHqAepB6oHqwesB60HrgevB7AHsQeyB7MHtAe1B7YHtwe4B7kHuge7 +B7wHvQe+B78HwAfBB8IHwwfEB8UHxgfHB8gHyQfKB8sHzAfNB84DiAfPB9AH0QfSB9MH1AfXB9oIbwkE +CQUJBgkHCQgJCQkKCQsJDAkNCQ4JDwkQCREJEgkTCRQJFQkWCRcJGAkZCRoJGwkcCR0JHgkfCSAJIQki +CSMJJAklCSYJJwkoCSkJKgkrCSwJLQkuCS8JMAkxCTIJMwk0CTUJNgE+CTcJOAk5CToJOwk8CT0JPgk/ +CUAJQQlCCUMJRAlFCUYJRwlICUkJSglLCUwJTQlOCU8JUAlRAUMJUglTCVQJVQlWCVcJWAlZCVoJWwlc +CV0JXglfCWAJYQliCWMJZAllCWYJZwloCWkJaglrCWwJbQluCW8JcAlxCXIJcwl0CXUJdgl3CXgJeQl6 +CXsJfAl9CX4JfwmACYEJggmDCYQJhQmGCYcJiAmJCYoJiwmMCY0JjgmPCZAJkQmSCZMJlAmXCZoJnVUk +bnVsbN8QEgANAA4ADwAQABEAEgATABQAFQAWABcAGAAZABoAGwAcAB0AHgAfACAAIQAiACMAJAAlACYA +JwAoACkAKgArACwALQAuAC8AMFZOU1Jvb3RWJGNsYXNzXU5TT2JqZWN0c0tleXNfEA9OU0NsYXNzZXNW +YWx1ZXNfEBlOU0FjY2Vzc2liaWxpdHlPaWRzVmFsdWVzXU5TQ29ubmVjdGlvbnNbTlNOYW1lc0tleXNb +TlNGcmFtZXdvcmtdTlNDbGFzc2VzS2V5c1pOU09pZHNLZXlzXU5TTmFtZXNWYWx1ZXNfEBlOU0FjY2Vz +c2liaWxpdHlDb25uZWN0b3JzXU5TRm9udE1hbmFnZXJfEBBOU1Zpc2libGVXaW5kb3dzXxAPTlNPYmpl +Y3RzVmFsdWVzXxAXTlNBY2Nlc3NpYmlsaXR5T2lkc0tleXNZTlNOZXh0T2lkXE5TT2lkc1ZhbHVlc4AC +gQJ7gQEdgQHjgQJ6gEuBAXuABYEB4oEB5IEBfIECeIAAgAaBAXqBAnkRAZKBAeXSAA4AMgAzADRbTlND +bGFzc05hbWWABIADXU5TQXBwbGljYXRpb27SADcAOAA5ADpYJGNsYXNzZXNaJGNsYXNzbmFtZaIAOgA7 +Xk5TQ3VzdG9tT2JqZWN0WE5TT2JqZWN0XxAQSUJDb2NvYUZyYW1ld29ya9IADgA+AD8AQFpOUy5vYmpl +Y3RzgEqhAEGAB9oAQwAOAEQARQBGAEcASABJAEoASwBMAE0ATgBPAFAAUQBSAFMAVAArXE5TV2luZG93 +Vmlld1xOU1NjcmVlblJlY3RdTlNXaW5kb3dUaXRsZVlOU1dURmxhZ3NdTlNXaW5kb3dDbGFzc1xOU1dp +bmRvd1JlY3RfEA9OU1dpbmRvd0JhY2tpbmdfEBFOU1dpbmRvd1N0eWxlTWFza1tOU1ZpZXdDbGFzc4AL +gEmASIAJEiR4AACACoAIEAIQB4AAXxAYe3szMDYsIDc2N30sIHszNTAsIDE4OX19XxASQ3VycmVuY3kg +Q29udmVydGVyWE5TV2luZG931wBaAA4AWwBcAF0AWABeAF8AYABhAGIAYwBfAGVfEA9OU05leHRSZXNw +b25kZXJaTlNTdWJ2aWV3c1hOU3ZGbGFnc1tOU0ZyYW1lU2l6ZVtOU1N1cGVydmlld4AMgEeADREBAIBF +gAyARtIADgA+AGcAaIBEqABpAGoAawBsAG0AbgBvAHCADoAfgCKAJYAugDKANoA92ABaAA4AcgBzAFwA +dABYAF4ATAB2AHcAeAB5AHoAXwBMV05TRnJhbWVWTlNDZWxsWU5TRW5hYmxlZIALgB6AD4AQEQEMCYAM +gAtfEBd7ezE5NSwgMTQ3fSwgezEzNSwgMjJ9fdkAfwAOAIAAgQCCAIMAhACFAIYAhwCIAIkAigCLAGkA +jQB6AI9bTlNDZWxsRmxhZ3NfEBFOU0JhY2tncm91bmRDb2xvclpOU0NvbnRlbnRzWU5TU3VwcG9ydF1O +U0NvbnRyb2xWaWV3XE5TQ2VsbEZsYWdzMl8QEU5TRHJhd3NCYWNrZ3JvdW5kW05TVGV4dENvbG9yE/// +//+Ucf5BgB2AFYARgBKADhIQQAQACYAaUNQADgCSAJMAlACVAJYAlwCYVk5TU2l6ZVZOU05hbWVYTlNm +RmxhZ3OAFCNAKgAAAAAAAIATEQQUXEx1Y2lkYUdyYW5kZdIANwA4AJsAnKIAnAA7Vk5TRm9udNUADgCe +AJ8AoAChAKIAowCkAKUApldOU0NvbG9yXE5TQ29sb3JTcGFjZVtOU0NvbG9yTmFtZV1OU0NhdGFsb2dO +YW1lgBmAGBAGgBeAFlZTeXN0ZW1fEBN0ZXh0QmFja2dyb3VuZENvbG9y0wAOAJ8AqgCiAKwArVdOU1do +aXRlgBkQA0IxANIANwA4AK8AnqIAngA71QAOAJ4AnwCgAKEAogCyAKQAswCmgBmAHIAbgBZZdGV4dENv +bG9y0wAOAJ8AqgCiAKwAuIAZQjAA0gA3ADgAugC7pAC7ALwAcwA7XxAPTlNUZXh0RmllbGRDZWxsXE5T +QWN0aW9uQ2VsbNIANwA4AL4Av6UAvwDAAMEAwgA7W05TVGV4dEZpZWxkWU5TQ29udHJvbFZOU1ZpZXdb +TlNSZXNwb25kZXLYAFoADgByAHMAXAB0AFgAXgBMAHYAxgDHAHkAegBfAEyAC4AegCCAIQmADIALXxAX +e3sxOTUsIDExNX0sIHsxMzUsIDIyfX3ZAH8ADgCAAIEAggCDAIQAhQCGAIcAiACJAIoAiwBqAI0AegCP +gB2AFYARgBKAHwmAGtgAWgAOAHIAcwBcAHQAWABeAEwAdgDXANgAeQB6AF8ATIALgB6AI4AkCYAMgAtf +EBZ7ezE5NSwgODN9LCB7MTM1LCAyMn192QB/AA4AgACBAIIAgwCEAIUAhgDeAIgAiQCKAIsAawCNAHoA +jxP/////hHH+QYAdgBWAEYASgCIJgBrYAFoADgByAHMAXAB0AFgAXgBMAHYA6QDqAHkAegBfAEyAC4Ae +gCaAJwmADIALXxAWe3s0NywgMTQ5fSwgezE0MywgMTd9fdgAfwAOAIAAgQCCAIMAhACGAPAAiADyAPMA +iwBsAPYA9xIEAf5AgB2AKYAogBKAJRIEQAQAgCxfEBVFeGNoYW5nZSByYXRlIHBlciAkMTrVAA4AngCf +AKAAoQCiAPsApAD8AKaAGYArgCqAFlxjb250cm9sQ29sb3LTAA4AnwCqAKIArAEBgBlLMC42NjY2NjY2 +OQDVAA4AngCfAKAAoQCiALIApAEFAKaAGYAcgC2AFl8QEGNvbnRyb2xUZXh0Q29sb3LYAFoADgByAHMA +XAB0AFgAXgBMAHYBCwEMAHkAegBfAEyAC4AegC+AMAmADIALXxAWe3s2NywgMTE1fSwgezEyMywgMTd9 +fdgAfwAOAIAAgQCCAIMAhACGAPAAiADyARQAiwBtAPYA94AdgCmAMYASgC6ALF8QE0RvbGxhcnMgdG8g +Q29udmVydDrYAFoADgByAHMAXAB0AFgAXgBMAHYBHAEdAHkAegBfAEyAC4AegDOANAmADIALXxAVe3sx +NywgODN9LCB7MTczLCAxN3192AB/AA4AgACBAIIAgwCEAIYA8ACIAPIBJQCLAG4A9gD3gB2AKYA1gBKA +MoAsXxAZQW1vdW50IGluIG90aGVyIEN1cnJlbmN5OtgAWgAOAHIAcwBcAHQAWABeAEwBLAEtAS4AeQB6 +AF8ATIALgDyAN4A4CYAMgAtfEBV7ezIxNCwgMTJ9LCB7OTYsIDMyfX3cAH8ADgE0ATUBNgE3AIEAggCD +ATgAhAE5AToBOwCKAT0BPgE/AUAAiwBvAUMBRAFFXxATTlNBbHRlcm5hdGVDb250ZW50c18QEk5TUGVy +aW9kaWNJbnRlcnZhbF5OU0J1dHRvbkZsYWdzMl8QD05TS2V5RXF1aXZhbGVudF8QD05TUGVyaW9kaWNE +ZWxheV1OU0J1dHRvbkZsYWdzEgQB/gCAO4AREBkQgYA6gDmAEoA2EMgSCAAAABP/////hoJA/1dDb252 +ZXJ0UQ3SADcAOAFJAUqkAUoAvABzADtcTlNCdXR0b25DZWxs0gA3ADgBTAFNpQFNAMAAwQDCADtYTlNC +dXR0b27cAFoBTwAOAVAAcgFRAFwBUgBYAVMBVABeAEwAUwFWAVcBWAFZAVoArABfAVwBXQBMWU5TQm94 +VHlwZVtOU1RpdGxlQ2VsbF1OU1RyYW5zcGFyZW50XE5TQm9yZGVyVHlwZVlOU09mZnNldHNfEA9OU1Rp +dGxlUG9zaXRpb26AC4BDgECAPggQDIAMgD8QAIALXxAUe3syMCwgNTh9LCB7MzEwLCA1fX1WezAsIDB9 +1wB/AA4AgACBAIIAhACGAToAiACJAWQAiwFdAWaAHYAVgEGAEoBCU0JveNMADgCfAKoAogCsAWqAGU0w +IDAuODAwMDAwMDEA0gA3ADgBbAFtpAFtAMEAwgA7VU5TQm940gA3ADgBbwFwowFwAXEAO15OU011dGFi +bGVBcnJheVdOU0FycmF5WnszNTAsIDE4OX3SADcAOAF0AMGjAMEAwgA7XxAWe3swLCAwfSwgezE5MjAs +IDExNzh9fdIANwA4AXcBeKIBeAA7XxAQTlNXaW5kb3dUZW1wbGF0ZdIANwA4AXoBe6MBewF8ADtcTlNN +dXRhYmxlU2V0VU5TU2V00gAOAD4AZwF/gESvEC0BgAGBAYIBgwGEAYUBhgGHAYgBiQGKAYsBjAGNAY4B +jwGQAZEBkgGTAZQBlQGWAZcBmAGZAZoBmwGcAZ0BngGfAaABoQGiAaMBpAGlAaYBpwGoAakBqgGrAayA +TIBagF+AZYBqgG6Ac4B3gHmAf4CFgIuAkYCWgJuAoIClgKmAroC0gLiAvYDCgMaAy4DPgNGA14DcgOCA +5IDogO2A8YDzgPeA/IEBAYEBBYEBCYEBC4EBD4EBEYEBFoEBF9MADgGuAa8BsAGxAbJYTlNTb3VyY2VX +TlNMYWJlbIBZgE2AWNgADgG0AbUBtgG3AbgBuQG6AbsBvAG9Ab4BvwHAAcEBwldOU1RpdGxlXxARTlNL +ZXlFcXVpdk1vZE1hc2taTlNLZXlFcXVpdl1OU01uZW1vbmljTG9jWU5TT25JbWFnZVxOU01peGVkSW1h +Z2VWTlNNZW51gFeATxIAEgAAgFASf////4BRgFWATtMADgG0AcQBxQHGAcdbTlNNZW51SXRlbXOBASSB +AWGBAWJoAFMAYQB2AGUAIABBAHMgJlFT0wAOADIBywHMAc0Bzl5OU1Jlc291cmNlTmFtZYBUgFKAU1dO +U0ltYWdlXxAPTlNNZW51Q2hlY2ttYXJr0gA3ADgB0gHTogHTADtfEBBOU0N1c3RvbVJlc291cmNl0wAO +ADIBywHMAc0B14BUgFKAVl8QEE5TTWVudU1peGVkU3RhdGXSADcAOAHaAduiAdsAO1pOU01lbnVJdGVt +XxAPc2F2ZURvY3VtZW50QXM60gA3ADgB3gHfowHfAeAAO18QFU5TTmliQ29udHJvbENvbm5lY3Rvcl5O +U05pYkNvbm5lY3RvctQADgHiAa4BrwHjAGkB5QHmXU5TRGVzdGluYXRpb26AXoAOgFuAXdIADgAyADMB +6YAEgFxfEBNDb252ZXJ0ZXJDb250cm9sbGVyWXJhdGVGaWVsZNIANwA4Ae0B7qMB7gHgADtfEBROU05p +Yk91dGxldENvbm5lY3RvctMADgGuAa8BsAHxAfKAWYBggGTYAA4BtAG1AbYBtwG4AbkBugG7AfUB9gH3 +Ab8BwAHBAfqAV4BiEgAQAACAY4BRgFWAYdMADgG0AcQBxQH9Af6BASSBAT6BAUBeQ2hlY2sgU3BlbGxp +bmdRO15jaGVja1NwZWxsaW5nOtMADgGuAa8BsAIEAgWAWYBmgGnYAA4BtAG1AbYBtwG4AbkBugG7AggB +9gCKAb8BwAHBAgyAV4BogBGAUYBVgGfTAA4BtAHEAcUCDwIQgQEkgQEmgQEoXVN0b3AgU3BlYWtpbmdd +c3RvcFNwZWFraW5nOtMADgGuAa8BsAIVAhaAWYBrgG3YAA4BtAG1AbYBtwG4AbkBugG7AhkB9gCKAb8B +wAHBAgyAV4BsgBGAUYBVgGdeU3RhcnQgU3BlYWtpbmdec3RhcnRTcGVha2luZzrTAA4BrgGvAbACIgIj +gFmAb4By2QAOAiUBtAG1AbYBtwG4AbkBugG7AIoCKAG9AikBvwHAAcEBwllOU1Rvb2xUaXCAV4ARgHCA +cYBRgFWATl1QYWdlIFNldHVwLi4uUVBecnVuUGFnZUxheW91dDrTAA4BrgGvAbACMgIzgFmAdIB22AAO +AbQBtQG2AbcBuAG5AboBuwI2AfYAigG/AcABwQH6gFeAdYARgFGAVYBhXxAbQ2hlY2sgR3JhbW1hciBX +aXRoIFNwZWxsaW5nXxAWdG9nZ2xlR3JhbW1hckNoZWNraW5nOtQADgHiAa4BrwHjAGoAaQJBgF6AH4AO +gHhbbmV4dEtleVZpZXfTAA4BrgGvAbACRQJGgFmAeoB+2AAOAbQBtQG2AbcBuAG5AboBuwJJAfYCSgG/ +AcABwQJNgFeAfIB9gFGAVYB71AAOAbQAkwHEAcUCUAJRAlKBASSBASCBASOBASFYTWluaW1pemVRbV8Q +E3BlcmZvcm1NaW5pYXR1cml6ZTrTAA4BrgGvAbACWAJZgFmAgICE2AAOAbQBtQG2AbcBuAG5AboBuwJc +AfYCXQG/AcABwQJggFeAgoCDgFGAVYCB0wAOAbQBxAHFAmMCZIEBJIEBK4EBLVVQYXN0ZVF2VnBhc3Rl +OtMADgGuAa8BsAJqAmuAWYCGgIrYAA4BtAG1AbYBtwG4AbkBugG7Am4B9gJvAb8BwAHBAnKAV4CIgImA +UYBVgIfUAA4BtACTAcQBxQBPAnYCd4EBJIAJgQFdgQFYXxAXUXVpdCBDdXJyZW5jeSBDb252ZXJ0ZXJR +cVp0ZXJtaW5hdGU60wAOAa4BrwGwAn0CfoBZgIyAkNgADgG0AbUBtgG3AbgBuQG6AbsCgQG9AoIBvwHA +AcEChYBXgI6Aj4BRgFWAjdMADgG0AcQBxQKIAomBASSBAWuBAWxbU2hvdyBDb2xvcnNRQ18QFW9yZGVy +RnJvbnRDb2xvclBhbmVsOtMADgGuAa8BsAKPApCAWYCSgJXYAA4BtAG2AbcBuAG5AboCkgG7ApQAigG/ +AcABwQKYAplVTlNUYWeAV4CUgBGAUYBVgJMQAdMADgG0AcQBxQKcAp2BASSBAUKBAURfEBBTbWFydCBD +b3B5L1Bhc3RlXxAYdG9nZ2xlU21hcnRJbnNlcnREZWxldGU60wAOAa4BrwGwAqICo4BZgJeAmtgADgG0 +AbUBtgG3AbgBuQG6AbsCpgH2AqcBvwHAAcECYIBXgJiAmYBRgFWAgVNDdXRReFRjdXQ60wAOAa4BrwGw +ArACsYBZgJyAn9gADgG0AbUBtgG3AbgBuQG6AbsCtAH2ArUBvwHAAcEBwoBXgJ2AnoBRgFWATmYAUABy +AGkAbgB0ICZRcFZwcmludDrTAA4BrgGvAbACvgK/gFmAoYCk2AAOAbQBtQG2AbcBuAG5AboBuwLCAfYC +wwG/AcABwQHCgFeAooCjgFGAVYBOVFNhdmVRc11zYXZlRG9jdW1lbnQ60wAOAa4BrwGwAswCzYBZgKaA +qNgADgG0AbUBtgG3AbgBuQG6AbsC0AH2AIoBvwHAAcEB+oBXgKeAEYBRgFWAYV8QG0NoZWNrIFNwZWxs +aW5nIFdoaWxlIFR5cGluZ18QHnRvZ2dsZUNvbnRpbnVvdXNTcGVsbENoZWNraW5nOtMADgGuAa8BsALZ +AtqAWYCqgK3YAA4BtAG1AbYBtwG4AbkBugG7At0C3gLfAb8BwAHBAnKAV4CrEgAYAACArIBRgFWAh1tI +aWRlIE90aGVyc1FoXxAWaGlkZU90aGVyQXBwbGljYXRpb25zOtMADgGuAa8BsALoAumAWYCvgLPZAA4B +tAG1AbYBtwG4AbkBugKSAbsC7AH2Au0BvwHAAcEC8AKZgFeAsYCygFGAVYCw0wAOAbQBxAHFAvMC9IEB +JIEBMYEBM2UARgBpAG4AZCAmUWZfEBdwZXJmb3JtRmluZFBhbmVsQWN0aW9uOtMADgGuAa8BsAL6AvuA +WYC1gLfXAA4BtAG2AbcBuAG5AboBuwL+AIoBvwHAAcEBwoBXgLaAEYBRgFWATl8QD1JldmVydCB0byBT +YXZlZF8QFnJldmVydERvY3VtZW50VG9TYXZlZDrTAA4BrgGvAbADBwMIgFmAuYC82AAOAbQBtQG2AbcB +uAG5AboBuwMLAfYAigG/AcABwQMPgFeAu4ARgFGAVYC61AAOAbQAkwHEAcUDEgMTAxSBASSBAWSBAWeB +AWZaQ2xlYXIgTWVudV8QFWNsZWFyUmVjZW50RG9jdW1lbnRzOtMADgGuAa8BsAMZAxqAWYC+gMHYAA4B +tAG1AbYBtwG4AbkBugG7Ax0B9gMeAb8BwAHBAfqAV4C/gMCAUYBVgGFuAFMAaABvAHcAIABTAHAAZQBs +AGwAaQBuAGcgJlE6XxAPc2hvd0d1ZXNzUGFuZWw60wAOAa4BrwGwAycDKIBZgMOAxdgADgG0AbYBtwG4 +AbkBugKSAbsDKwCKAb8BwAHBApgArIBXgMSAEYBRgFWAk1tTbWFydCBMaW5rc18QHXRvZ2dsZUF1dG9t +YXRpY0xpbmtEZXRlY3Rpb2460wAOAa4BrwGwAzQDNYBZgMeAytgADgG0AbUBtgG3AbgBuQG6AbsDOAH2 +AzkBvwHAAcECYIBXgMiAyYBRgFWAgVpTZWxlY3QgQWxsUWFac2VsZWN0QWxsOtMADgGuAa8BsANCA0OA +WYDMgM7YAA4BtAG1AbYBtwG4AbkBugG7A0YB9gLfAb8BwAHBAnKAV4DNgKyAUYBVgIdfEBdIaWRlIEN1 +cnJlbmN5IENvbnZlcnRlclVoaWRlOtQADgHiAa4BrwHjAGsB5QNRgF6AIoBbgNBbYW1vdW50RmllbGTT +AA4BrgGvAbADVQNWgFmA0oDW2AAOAbQBtQG2AbcBuAG5AboBuwNZAt4DWgG/AcABwQNdgFeA1IDVgFGA +VYDT0wAOAbQBxAHFA2ADYYEBJIEBboEBcFxTaG93IFRvb2xiYXJRdF8QE3RvZ2dsZVRvb2xiYXJTaG93 +bjrTAA4BrgGvAbADZwNogFmA2IDb2AAOAbQBtQG2AbcBuAG5AboBuwNrAfYDbAG/AcABwQJggFeA2YDa +gFGAVYCBVFVuZG9RelV1bmRvOtMADgGuAa8BsAN1A3aAWYDdgN/YAA4BtAG1AbYBtwG4AbkBugG7A3kB +9gCKAb8BwAHBAmCAV4DegBGAUYBVgIFWRGVsZXRlV2RlbGV0ZTrUAA4B4gGuAa8B4wOCAeUDhIBegOGA +W4Dj0gAOADIAMwOHgASA4llDb252ZXJ0ZXJZY29udmVydGVy0wAOAa4BrwGwA4wDjYBZgOWA59gADgG0 +AbUBtgG3AbgBuQG6AbsDkAH2AIoBvwHAAcECcoBXgOaAEYBRgFWAh1hTaG93IEFsbF8QFnVuaGlkZUFs +bEFwcGxpY2F0aW9uczrTAA4BrgGvAbADmQOagFmA6YDs2AAOAbQBtQG2AbcBuAG5AboBuwOdAfYDngG/ +AcABwQHCgFeA6oDrgFGAVYBOVUNsb3NlUXddcGVyZm9ybUNsb3NlOtMADgGuAa8BsAOnA6iAWYDugPDY +AA4BtAG1AbYBtwG4AbkBugG7A6sB9gCKAb8BwAHBAk2AV4DvgBGAUYBVgHtUWm9vbVxwZXJmb3JtWm9v +bTrUAA4B4gGuAa8BsAHlAG8DtoBZgFuANoDyWGNvbnZlcnQ60wAOAa4BrwGwA7oDu4BZgPSA9tgADgG0 +AbYBtwG4AbkBugKSAbsDvgCKAb8BwAHBApgAU4BXgPWAEYBRgFWAk1xTbWFydCBRdW90ZXNfECF0b2dn +bGVBdXRvbWF0aWNRdW90ZVN1YnN0aXR1dGlvbjrTAA4BrgGvAbADxwPIgFmA+ID72AAOAbQBtQG2AbcB +uAG5AboBuwPLAfYDzAG/AcABwQJggFeA+YD6gFGAVYCBVENvcHlRY1Vjb3B5OtMADgGuAa8BsAPVA9aA +WYD9gQEA2AAOAbQBtQG2AbcBuAG5AboBuwPZAfYD2gG/AcABwQLwgFeA/oD/gFGAVYCwXxARSnVtcCB0 +byBTZWxlY3Rpb25Ral8QHWNlbnRlclNlbGVjdGlvbkluVmlzaWJsZUFyZWE60wAOAa4BrwGwA+MD5IBZ +gQECgQEE2AAOAbQBtQG2AbcBuAG5AboBuwPnAfYAigG/AcABwQJNgFeBAQOAEYBRgFWAe18QEkJyaW5n +IEFsbCB0byBGcm9udF8QD2FycmFuZ2VJbkZyb250OtQADgHiAa4BrwGwAB8D8QPygFmAAoEBBoEBCNcA +DgG0AbYBtwG4AbkBugG7A/UAigG/AcABwQJygFeBAQeAEYBRgFWAh18QGEFib3V0IEN1cnJlbmN5IENv +bnZlcnRlcl8QHW9yZGVyRnJvbnRTdGFuZGFyZEFib3V0UGFuZWw61AAOAeIBrgGvAeMAagHlBACAXoAf +gFuBAQpbZG9sbGFyRmllbGTTAA4BrgGvAbAEBAQFgFmBAQyBAQ7YAA4BtAG1AbYBtwG4AbkBugG7BAgB +9gCKAb8BwAHBA12AV4EBDYARgFGAVYDTbxASAEMAdQBzAHQAbwBtAGkAegBlACAAVABvAG8AbABiAGEA +ciAmXxAfcnVuVG9vbGJhckN1c3RvbWl6YXRpb25QYWxldHRlOtQADgHiAa4BrwHjAGkAQQQTgF6ADoAH +gQEQXxAVaW5pdGlhbEZpcnN0UmVzcG9uZGVy0wAOAa4BrwGwBBcEGIBZgQESgQEV2AAOAbQBtQG2AbcB +uAG5AboBuwQbAb0EHAG/AcABwQJggFeBAROBARSAUYBVgIFUUmVkb1FaVXJlZG861AAOAeIBrgGvAeMA +aQBqAkGAXoAOgB+AeNMADgGuAa8BsAQqBCuAWYEBGIEBHNgADgG0AbUBtgG3AbgBuQG6AbsELgH2BC8B +vwHAAcEEMoBXgQEagQEbgFGAVYEBGdMADgG0AcQBxQQ1BDaBASSBAU2BAU9fEBdDdXJyZW5jeSBDb252 +ZXJ0ZXIgSGVscFE/WXNob3dIZWxwOtIADgA+BDsEPIEBea8QZAIyBD4C2QQEBEEEFwBuAk0A2ARGAmoC +IgRJA2cCzARMA/EATARPBFAAcAHlA5kBHQBsAGkC8AKwA8cEWgRbAOoEXQOMAHgEMgRhBGIDNAJYBGUD +JwMHAmAEaQN1AGsDGQRtBG4CDAHCA7oEcgBtAoUEdQH6A10D1QGxBHoEewR8BH0EfgLoA1UAQQJyBIMA +bwJFAvoEhwMPAGoEigNCA+MEjQQqAMcEkAEMA6cEkwKYAr4CjwEuAfECFQKiA4ICBASdBJ4CfQSggHSB +AR6AqoEBDIEBH4EBEoAygHuAJIEBJYCGgG+BASmA2ICmgQFFgQEGgAuBAUmBAUqAPYBbgOmANIAlgA6A +sICcgPiBAS+BAS6AJ4EBTIDlgBCBARmBAVCBATSAx4CAgQFBgMOAuYCBgQFTgN2AIoC+gQFWgQFegGeA +ToD0gQFpgC6AjYEBbYBhgNOA/YBNgQE3gQE9gQFxgQFzgQFagK+A0oAHgIeBATqANoB6gLWBAWOAuoAf +gQEigMyBAQKBAVmBARiAIYEBXIAwgO6BASqAk4ChgJKAOIBggGuAl4DhgGaBAWiBAXiAjIEBMNoADgG0 +AbUEogG2BKMBtwG4AbkBugG7AIoB9gB6AIoAegG/AcABwQJyXU5TSXNTZXBhcmF0b3JcTlNJc0Rpc2Fi +bGVkgFeAEQmAEQmAUYBVgIfaAA4BtAG1BKIBtgSjAbcBuAG5AboBuwCKAfYAegCKAHoBvwHAAcECcoBX +gBEJgBEJgFGAVYCHVldpbmRvd9IADgA+AGcEuIBEpAJFA6cEigPjgHqA7oEBIoEBAtoADgG0AbUEogG2 +BKMBtwG4AbkBugG7AIoB9gB6AIoAegG/AcABwQJNgFeAEQmAEQmAUYBVgHteX05TV2luZG93c01lbnXS +ADcAOATIAbqiAboAO9oADgTKAbQBtQG2AbcBuAG5AboEywG7AgwCDwH2AIoBvwHAAcECYATTWU5TU3Vi +bWVudVhOU0FjdGlvboBXgGeBASaAEYBRgFWAgYEBJ1ZTcGVlY2hec3VibWVudUFjdGlvbjrSAA4APgBn +BNiARKICFQIEgGuAZtoADgTKAbQBtQG2AbcBuAG5AboEywG7AmACYwH2AIoBvwHAAcEEkwTjgFeAgYEB +K4ARgFGAVYEBKoEBLNQADgG0AJMBxAHFBOYE5wTogQEkgQF1gQF3gQF2VEVkaXTSAA4APgBnBOyARK0D +ZwQXBFsCogPHAlgDdQM0BFoEoAR7BGUERoDYgQESgQEugJeA+ICAgN2Ax4EBL4EBMIEBPYEBQYEBJdoA +DgG0AbUEogG2BKMBtwG4AbkBugG7AIoB9gB6AIoAegG/AcABwQJggFeAEQmAEQmAUYBVgIHaAA4BtAG1 +BKIBtgSjAbcBuAG5AboBuwCKAfYAegCKAHoBvwHAAcECYIBXgBEJgBEJgFGAVYCB2gAOBMoBtAG1AbYB +twG4AbkBugTLAbsC8ALzAfYAigG/AcABwQJgBRSAV4CwgQExgBGAUYBVgIGBATJURmluZNIADgA+AGcF +GIBEpQLoBGIEegSDA9WAr4EBNIEBN4EBOoD92QAOAbQBtQG2AbcBuAG5AboCkgG7BSAB9gUhAb8BwAHB +AvAAU4BXgQE1gQE2gFGAVYCwWUZpbmQgTmV4dFFn2QAOAbQBtQG2AbcBuAG5AboCkgG7BSkBvQUqAb8B +wAHBAvAArIBXgQE4gQE5gFGAVYCwXUZpbmQgUHJldmlvdXNRR9kADgG0AbUBtgG3AbgBuQG6ApIBuwUy +AfYFMwG/AcABwQLwAFSAV4EBO4EBPIBRgFWAsF8QFlVzZSBTZWxlY3Rpb24gZm9yIEZpbmRRZdoADgTK +AbQBtQG2AbcBuAG5AboEywG7AfoB/QH2AIoBvwHAAcECYAVBgFeAYYEBPoARgFGAVYCBgQE/XxAUU3Bl +bGxpbmcgYW5kIEdyYW1tYXLSAA4APgBnBUWARKQDGQHxAswCMoC+gGCApoB02gAOBMoBtAG1AbYBtwG4 +AbkBugTLAbsCmAKcAfYAigG/AcABwQJgBVKAV4CTgQFCgBGAUYBVgIGBAUNdU3Vic3RpdHV0aW9uc9IA +DgA+AGcFVoBEowKPA7oDJ4CSgPSAw9QADgG0AJMBxAHFBVwFXQVegQEkgQFGgQFIgQFHWFNlcnZpY2Vz +0gAOAD4AZwVigESgXxAPX05TU2VydmljZXNNZW512gAOAbQBtQSiAbYEowG3AbgBuQG6AbsAigH2AHoA +igB6Ab8BwAHBAcKAV4ARCYARCYBRgFWATtgADgG0AbUBtgG3AbgBuQG6AbsFbwH2A1oBvwHAAcEChYBX +gQFLgNWAUYBVgI1aU2hvdyBGb250c9oADgTKAbQBtQG2AbcBuAG5AboEywG7BDIENQH2AIoBvwHAAcEE +kwV9gFeBARmBAU2AEYBRgFWBASqBAU5USGVscNIADgA+AGcFgYBEoQQqgQEY2AAOAbQBtQG2AbcBuAG5 +AboBuwWFAfYFhgG/AcABwQJygFeBAVGBAVKAUYBVgIdsAFAAcgBlAGYAZQByAGUAbgBjAGUAcyAmUSzY +AA4BtAG1AbYBtwG4AbkBugG7BY4B9gWPAb8BwAHBAcKAV4EBVIEBVYBRgFWATlNOZXdRbtoADgTKAbQB +tQG2AbcBuAG5AboEywG7AnIATwH2AIoBvwHAAcEEkwWdgFeAh4AJgBGAUYBVgQEqgQFX0gAOAD4AZwWg +gESrA/EEjQRhBD4EfgSQA0IC2QOMBEECaoEBBoEBWYEBUIEBHoEBWoEBXIDMgKqA5YEBH4CG2gAOAbQB +tQSiAbYEowG3AbgBuQG6AbsAigH2AHoAigB6Ab8BwAHBAnKAV4ARCYARCYBRgFWAh9oADgTKAbQBtQG2 +AbcBuAG5AboEywG7BEwFXAH2AIoBvwHAAcECcgW9gFeBAUWBAUaAEYBRgFWAh4EBW9oADgG0AbUEogG2 +BKMBtwG4AbkBugG7AIoB9gB6AIoAegG/AcABwQJygFeAEQmAEQmAUYBVgIdcX05TQXBwbGVNZW512AAO +AbQBtQG2AbcBuAG5AboBuwXKAfYFywG/AcABwQHCgFeBAV+BAWCAUYBVgE5lAE8AcABlAG4gJlFvVEZp +bGXSAA4APgBnBdSARKsEaQRuBIcEnQOZAr4BsQL6BE8CIgKwgQFTgQFegQFjgQFogOmAoYBNgLWBAUmA +b4Cc2gAOBMoBtAG1AbYBtwG4AbkBugTLAbsDDwMSAfYAigG/AcABwQHCBeiAV4C6gQFkgBGAUYBVgE6B +AWVbT3BlbiBSZWNlbnTSAA4APgBnBeyARKEDB4C5XxAWX05TUmVjZW50RG9jdW1lbnRzTWVuddoADgG0 +AbUEogG2BKMBtwG4AbkBugG7AIoB9gB6AIoAegG/AcABwQHCgFeAEQmAEQmAUYBVgE7aAA4EygG0AbUB +tgG3AbgBuQG6BMsBuwJNAlAB9gCKAb8BwAHBBJMGAIBXgHuBASCAEYBRgFWBASqBAWpWRm9ybWF00gAO +AD4AZwYEgESiBFACfYEBSoCM2gAOBMoBtAG1AbYBtwG4AbkBugTLAbsDXQNgAfYAigG/AcABwQSTBg+A +V4DTgQFugBGAUYBVgQEqgQFvVFZpZXfSAA4APgBnBhOARKIDVQQEgNKBAQzaAA4EygG0AbUBtgG3AbgB +uQG6BMsBuwHCAcYB9gCKAb8BwAHBBJMGHoBXgE6BAWGAEYBRgFWBASqBAXLaAA4EygG0AbUBtgG3AbgB +uQG6BMsBuwKFAogB9gCKAb8BwAHBBJMGJ4BXgI2BAWuAEYBRgFWBASqBAXRZQU1haW5NZW510gAOAD4A +ZwYrgESnBG0EfARJBH0EdQRyBF2BAVaBAXGBASmBAXOBAW2BAWmBAUxbX05TTWFpbk1lbnXSAA4AMgAz +ADSABIAD0gA3ADgGOAFxogFxADvSAA4APgQ7BjuBAXmvEGQB+gJyAnIDXQJyAmAATARyAGsCYAJyAcIE +kwJgAfoEfgJyAEEBwgKFAEwAHwHCAG4ATABMBKABwgJgAmACYABsBJMCcgBpBF0CcgLwAmACYAJgApgD +DwRJAcICYABMAfoEkwHCBEYEfAKYBJMATAR9BJMEewR1AvABwgLwAmAEkwSTAnIC8ANdAB8EbQLwAEwC +TQHCAcIEhwBMAk0CcgJNAnIEMgBqAnIAbQJNAB8EZQHCApgAbwH6AgwCYAAfAgwBwgAfAoUCYIBhgIeA +h4DTgIeAgYALgQFpgCKAgYCHgE6BASqAgYBhgQFagIeAB4BOgI2AC4ACgE6AMoALgAuBATCAToCBgIGA +gYAlgQEqgIeADoEBTICHgLCAgYCBgIGAk4C6gQEpgE6AgYALgGGBASqAToEBJYEBcYCTgQEqgAuBAXOB +ASqBAT2BAW2AsIBOgLCAgYEBKoEBKoCHgLCA04ACgQFWgLCAC4B7gE6AToEBY4ALgHuAh4B7gIeBARmA +H4CHgC6Ae4ACgQFBgE6Ak4A2gGGAZ4CBgAKAZ4BOgAKAjYCB0gAOAD4EOwaigQF5rxBlAjIEPgLZBAQE +FwBuBEECTQDYBEYCagIiBEkATAPxA2cAcARMBE8EUALMAeUDmQEdAGwAaQKwAvADxwRaBFsA6gRdA4wA +eAQyBGEEYgM0AlgEZQMnAwcCYARpA3UAawMZBG0EbgIMAcIDugRyAG0ChQR1AfoDXQGxA9UEewR9BHwE +egR+A1UAQQLoAnIEgwBvAkUAagL6BIcDDwSKA0ID4wQqBI0AxwSQAQwDpwSTApgCvgKPAS4B8QIVAqIA +HwOCAgQEnQSeAn0EoIB0gQEegKqBAQyBARKAMoEBH4B7gCSBASWAhoBvgQEpgAuBAQaA2IA9gQFFgQFJ +gQFKgKaAW4DpgDSAJYAOgJyAsID4gQEvgQEugCeBAUyA5YAQgQEZgQFQgQE0gMeAgIEBQYDDgLmAgYEB +U4DdgCKAvoEBVoEBXoBngE6A9IEBaYAugI2BAW2AYYDTgE2A/YEBPYEBc4EBcYEBN4EBWoDSgAeAr4CH +gQE6gDaAeoAfgLWBAWOAuoEBIoDMgQECgQEYgQFZgCGBAVyAMIDugQEqgJOAoYCSgDiAYIBrgJeAAoDh +gGaBAWiBAXiAjIEBMNIADgA+BDsHCoEBea8QZQcLBwwHDQcOBw8HEAcRBxIHEwcUBxUHFgcXBxgHGQca +BxsHHAcdBx4HHwcgByEHIgcjByQHJQcmBycHKAcpByoHKwcsBy0HLgcvBzAHMQcyBzMHNAc1BzYHNwc4 +BzkHOgc7BzwHPQc+Bz8HQAdBB0IHQwdEB0UHRgdHB0gHSQdKB0sHTAdNB04HTwdQB1EHUgdTB1QHVQdW +B1cHWAdZB1oHWwdcB10HXgdfB2AHYQdiB2MHZAdlB2YHZwdoB2kHagdrB2wHbQduB2+BAX2BAX6BAX+B +AYCBAYGBAYKBAYOBAYSBAYWBAYaBAYeBAYiBAYmBAYqBAYuBAYyBAY2BAY6BAY+BAZCBAZGBAZKBAZOB +AZSBAZWBAZaBAZeBAZiBAZmBAZqBAZuBAZyBAZ2BAZ6BAZ+BAaCBAaGBAaKBAaOBAaSBAaWBAaaBAaeB +AaiBAamBAaqBAauBAayBAa2BAa6BAa+BAbCBAbGBAbKBAbOBAbSBAbWBAbaBAbeBAbiBAbmBAbqBAbuB +AbyBAb2BAb6BAb+BAcCBAcGBAcKBAcOBAcSBAcWBAcaBAceBAciBAcmBAcqBAcuBAcyBAc2BAc6BAc+B +AdCBAdGBAdKBAdOBAdSBAdWBAdaBAdeBAdiBAdmBAdqBAduBAdyBAd2BAd6BAd+BAeCBAeFfECdNZW51 +IEl0ZW0gKENoZWNrIEdyYW1tYXIgV2l0aCBTcGVsbGluZylbU2VwYXJhdG9yLTJfEBdNZW51IEl0ZW0g +KEhpZGUgT3RoZXJzKW8QHgBNAGUAbgB1ACAASQB0AGUAbQAgACgAQwB1AHMAdABvAG0AaQB6AGUAIABU +AG8AbwBsAGIAYQByICYAKV8QEE1lbnUgSXRlbSAoUmVkbylfECdTdGF0aWMgVGV4dCAoQW1vdW50IGlu +IG90aGVyIEN1cnJlbmN5OilbU2VwYXJhdG9yLTNdTWVudSAoV2luZG93KV8QEVRleHQgRmllbGQgQ2Vs +bC0xXxASTWVudSBJdGVtIChTcGVlY2gpVDExMTFRNV8QEE1lbnUgSXRlbSAoRWRpdClcQ29udGVudCBW +aWV3XxAkTWVudSBJdGVtIChBYm91dCBDdXJyZW5jeSBDb252ZXJ0ZXIpXxAQTWVudSBJdGVtIChVbmRv +KV8QD0hvcml6b250YWwgTGluZV8QD01lbnUgKFNlcnZpY2VzKVMyLTFfEBZNZW51IEl0ZW0gKFNob3cg +Rm9udHMpXxAnTWVudSBJdGVtIChDaGVjayBTcGVsbGluZyBXaGlsZSBUeXBpbmcpXxAUQ29udmVydGVy +IENvbnRyb2xsZXJTMS0xXxArVGV4dCBGaWVsZCBDZWxsIChBbW91bnQgaW4gb3RoZXIgQ3VycmVuY3k6 +KV8QI1N0YXRpYyBUZXh0IChFeGNoYW5nZSByYXRlIHBlciAkMTopWlRleHQgRmllbGRRNltNZW51IChG +aW5kKV8QEE1lbnUgSXRlbSAoQ29weSlZU2VwYXJhdG9yW1NlcGFyYXRvci0xXxAnVGV4dCBGaWVsZCBD +ZWxsIChFeGNoYW5nZSByYXRlIHBlciAkMTopUTFfEBRNZW51IEl0ZW0gKFNob3cgQWxsKV8QD1RleHQg +RmllbGQgQ2VsbFEyUzEyMV8QFU1lbnUgSXRlbSAoRmluZCBOZXh0KV8QFk1lbnUgSXRlbSAoU2VsZWN0 +IEFsbClfEBFNZW51IEl0ZW0gKFBhc3RlKV8QGU1lbnUgSXRlbSAoU3Vic3RpdHV0aW9ucylfEBdNZW51 +IEl0ZW0gKFNtYXJ0IExpbmtzKV8QFk1lbnUgSXRlbSAoQ2xlYXIgTWVudSlbTWVudSAoRWRpdClROV8Q +Ek1lbnUgSXRlbSAoRGVsZXRlKVxUZXh0IEZpZWxkLTFvEBoATQBlAG4AdQAgAEkAdABlAG0AIAAoAFMA +aABvAHcAIABTAHAAZQBsAGwAaQBuAGcgJgApXxAeTWVudSBJdGVtIChDdXJyZW5jeSBDb252ZXJ0ZXIp +bxARAE0AZQBuAHUAIABJAHQAZQBtACAAKABPAHAAZQBuICYAKV1NZW51IChTcGVlY2gpW01lbnUgKEZp +bGUpXxAYTWVudSBJdGVtIChTbWFydCBRdW90ZXMpXxASTWVudSBJdGVtIChXaW5kb3cpXxAhU3RhdGlj +IFRleHQgKERvbGxhcnMgdG8gQ29udmVydDopXU1lbnUgKEZvcm1hdClfEBBNZW51IEl0ZW0gKFZpZXcp +XxAbTWVudSAoU3BlbGxpbmcgYW5kIEdyYW1tYXIpW01lbnUgKFZpZXcpUThfEB1NZW51IEl0ZW0gKEp1 +bXAgdG8gU2VsZWN0aW9uKV8QIE1lbnUgSXRlbSAoU3BlbGxpbmcgYW5kIEdyYW1tYXIpXxASTWVudSBJ +dGVtIChGb3JtYXQpXxAQTWVudSBJdGVtIChGaWxlKV8QGU1lbnUgSXRlbSAoRmluZCBQcmV2aW91cylf +EBRNZW51IEl0ZW0gKFNlcnZpY2VzKV8QGE1lbnUgSXRlbSAoU2hvdyBUb29sYmFyKV8QG1dpbmRvdyAo +Q3VycmVuY3kgQ29udmVydGVyKW8QEQBNAGUAbgB1ACAASQB0AGUAbQAgACgARgBpAG4AZCAmAClfEBlN +ZW51IChDdXJyZW5jeSBDb252ZXJ0ZXIpXxAiTWVudSBJdGVtIChVc2UgU2VsZWN0aW9uIGZvciBGaW5k +KV8QFVB1c2ggQnV0dG9uIChDb252ZXJ0KV8QFE1lbnUgSXRlbSAoTWluaW1pemUpXFRleHQgRmllbGQt +MlIxMF8QF01lbnUgSXRlbSAoT3BlbiBSZWNlbnQpXxASTWVudSAoT3BlbiBSZWNlbnQpW1NlcGFyYXRv +ci02XxAjTWVudSBJdGVtIChIaWRlIEN1cnJlbmN5IENvbnZlcnRlcilfEB5NZW51IEl0ZW0gKEJyaW5n +IEFsbCB0byBGcm9udClfECNNZW51IEl0ZW0gKEN1cnJlbmN5IENvbnZlcnRlciBIZWxwKVtTZXBhcmF0 +b3ItNF8QEVRleHQgRmllbGQgQ2VsbC0yW1NlcGFyYXRvci01XxAlVGV4dCBGaWVsZCBDZWxsIChEb2xs +YXJzIHRvIENvbnZlcnQ6KV8QEE1lbnUgSXRlbSAoWm9vbSlYTWFpbk1lbnVfEBRNZW51IChTdWJzdGl0 +dXRpb25zKVEzXxAcTWVudSBJdGVtIChTbWFydCBDb3B5L1Bhc3RlKV8QFUJ1dHRvbiBDZWxsIChDb252 +ZXJ0KV8QGk1lbnUgSXRlbSAoQ2hlY2sgU3BlbGxpbmcpXxAaTWVudSBJdGVtIChTdGFydCBTcGVha2lu +ZylfEA9NZW51IEl0ZW0gKEN1dClcRmlsZSdzIE93bmVyXxAZTWVudSBJdGVtIChTdG9wIFNwZWFraW5n +KVE3W0FwcGxpY2F0aW9uXxAXTWVudSBJdGVtIChTaG93IENvbG9ycylfEBBNZW51IEl0ZW0gKEZpbmQp +0gAOAD4EOwfWgQF5oNIADgA+BDsH2YEBeaDSAA4APgQ7B9yBAXmvEJICMgGUAakEPgLZBAQEQQQXAG4B +nQGRAacBgQJNANgERgJqAiIBmQGGAZwBiQGlBEkDZwLMBEwD8QBMBE8EUABwAeUBlQGEA5kBHQBsAGkC +8AKwA8cEWgRbAaIBmwDqBF0DjAB4BDIEYQGDAZYEYgM0AlgEZQMnAwcCYARpAZgDdQBrAxkEbQRuAgwB +kgGaAcIDugRyAG0BpAKFAY8EdQH6A10D1QGxBHoEewR8BH0EfgLoA1UAQQGMAZ4BqgJyAawEgwBvAkUC ++gSHAw8AagGCBIoDQgGLA+MBlwSNBCoAxwSQAQwDpwGNAZMBnwSTAYABoAGoAaMBpgKYAZACvgKPAS4B +8QIVAqIBigGIAasBhwGFAB8BoQOCAgQEnQSeAn0EoAGOgHSAuIEBD4EBHoCqgQEMgQEfgQESgDKA4ICp +gQEJgFqAe4AkgQElgIaAb4DPgHOA3IB/gQEBgQEpgNiApoEBRYEBBoALgQFJgQFKgD2AW4C9gGqA6YA0 +gCWADoCwgJyA+IEBL4EBLoDzgNeAJ4EBTIDlgBCBARmBAVCAZYDCgQE0gMeAgIEBQYDDgLmAgYEBU4DL +gN2AIoC+gQFWgQFegGeAroDRgE6A9IEBaYAugPyAjYCggQFtgGGA04D9gE2BATeBAT2BAXGBAXOBAVqA +r4DSgAeAkYDkgQERgIeBAReBATqANoB6gLWBAWOAuoAfgF+BASKAzICLgQECgMaBAVmBARiAIYEBXIAw +gO6AloC0gOiBASqATIDtgQELgPeBAQWAk4ClgKGAkoA4gGCAa4CXgIWAeYEBFoB3gG6AAoDxgOGAZoEB +aIEBeICMgQEwgJvSAA4APgQ7CHGBAXmvEJIIcghzCHQIdQh2CHcIeAh5CHoIewh8CH0Ifgh/CIAIgQiC +CIMIhAiFCIYIhwiICIkIigiLCIwIjQiOCI8IkAiRCJIIkwiUCJUIlgiXCJgImQiaCJsInAidCJ4Inwig +CKEIogijCKQIpQimCKcIqAipCKoIqwisCK0IrgivCLAIsQiyCLMItAi1CLYItwi4CLkIugi7CLwIvQi+ +CL8IwAjBCMIIwwjECMUIxgjHCMgIyQjKCMsIzAjNCM4IzwjQCNEI0gjTCNQI1QjWCNcI2AjZCNoI2wjc +CN0I3gjfCOAI4QjiCOMI5AjlCOYI5wjoCOkI6gjrCOwI7QjuCO8I8AjxCPII8wj0CPUI9gj3CPgI+Qj6 +CPsI/Aj9CP4I/wkACQEJAgkDgQHmgQHngQHogQHpgQHqgQHrgQHsgQHtgQHugQHvgQHwgQHxgQHygQHz +gQH0gQH1gQH2gQH3gQH4gQH5gQH6gQH7gQH8gQH9gQH+gQH/gQIAgQIBgQICgQIDgQIEgQIFgQIGgQIH +gQIIgQIJgQIKgQILgQIMgQINgQIOgQIPgQIQgQIRgQISgQITgQIUgQIVgQIWgQIXgQIYgQIZgQIagQIb +gQIcgQIdgQIegQIfgQIggQIhgQIigQIjgQIkgQIlgQImgQIngQIogQIpgQIqgQIrgQIsgQItgQIugQIv +gQIwgQIxgQIygQIzgQI0gQI1gQI2gQI3gQI4gQI5gQI6gQI7gQI8gQI9gQI+gQI/gQJAgQJBgQJCgQJD +gQJEgQJFgQJGgQJHgQJIgQJJgQJKgQJLgQJMgQJNgQJOgQJPgQJQgQJRgQJSgQJTgQJUgQJVgQJWgQJX +gQJYgQJZgQJagQJbgQJcgQJdgQJegQJfgQJggQJhgQJigQJjgQJkgQJlgQJmgQJngQJogQJpgQJqgQJr +gQJsgQJtgQJugQJvgQJwgQJxgQJygQJzgQJ0gQJ1gQJ2gQJ3EQFaEH8RAYgQjxCREQEqEJUQ1xEBfxEB +jxEBchEBjREBjBAYEQF6ENMQiBBNEQGOEQFbEOsQ4hAnENkQzxDbEIIQOhEBcBBKEQFYEQGFEQGLEOYQ +6RBJEQGAEQF7EQF1ENwQThDFENYQzhEBZBDfEQF8EGcQlhEBdhBqEOMRAWUQ0BDGEMsRAVwRAWIQfhDN +EFIRAXEQyhEBeRDMEDgQSBDUEPERAW4QUREBXxATEQF9EPURASwRAWoRAScRASgQ0hBQENUQ2BBTEQEr +EIMQ0REBKREBbxEBYxEBdBDnEDkRAWgQ3REBgRAXEHAQfBB9EQF3EOEQXBCGEQFpEAUQ6BDsEG8RAXgQ +kBEBfhDvEOQRAWwQwRAdEQFrEPARAW0Q4BCOEQFdEN4QSxEBXhEBghDJEMQQxxEBcxAlEQGHEQGGEFcR +AZERAZARAYoQwxBPE//////////9EQFZENoQVtIADgA+AGcJloBEoNIADgA+BDsJmYEBeaDSAA4APgQ7 +CZyBAXmg0gA3ADgJngmfogmfADteTlNJQk9iamVjdERhdGEACAAZACIAJwAxADoAPwBEAFIAVABmBWIF +aAWzBboFwQXPBeEF/QYLBhcGIwYxBjwGSgZmBnQGhwaZBrMGvQbKBswGzwbSBtUG2AbaBt0G3wbiBuUG +6AbrBu0G7wbyBvUG+Ab7BwQHEAcSBxQHIgcrBzQHPwdEB1MHXAdvB3gHgweFB4gHigezB8AHzQfbB+UH +8wgACBIIJggyCDQINgg4CDoIPwhBCEMIRQhHCEkIZAh5CIIInwixCLwIxQjRCN0I3wjhCOMI5gjoCOoI +7Aj1CPcJCAkKCQwJDgkQCRIJFAkWCRgJOQlBCUgJUglUCVYJWAlaCV0JXglgCWIJfAmhCa0JwQnMCdYJ +5AnxCgUKEQoaChwKHgogCiIKJAopCioKLAotCj4KRQpMClUKVwpgCmIKZQpyCnsKgAqHCpwKpAqxCr0K +ywrNCs8K0QrTCtUK3AryCv8LBwsJCwsLDgsXCxwLMQszCzULNws5C0MLUAtSC1ULXgtnC3kLhguPC5oL +pguwC7cLwwvkC+YL6AvqC+wL7QvvC/EMCwwwDDIMNAw2DDgMOgw7DD0MXgxgDGIMZAxmDGcMaQxrDIQM +qQyyDLQMtgy4DLoMvAy9DL8M4AziDOQM5gzoDOkM6wztDQYNJw0sDS4NMA0yDTQNNg07DT0NVQ1qDWwN +bg1wDXINfw2MDY4Nmg2vDbENsw21DbcNyg3rDe0N7w3xDfMN9A32DfgOEQ4yDjQONg44DjoOPA4+DlQO +dQ53DnkOew59Dn4OgA6CDpoOuw69Dr8OwQ7DDsUOxw7jDwQPBg8IDwoPDA8NDw8PEQ8pD1oPcA+FD5QP +pg+4D8YPyw/ND88P0Q/TD9UP1w/ZD9sP3Q/iD+sP8w/1D/4QBxAUEB0QKBAxEGIQbBB4EIYQkxCdEK8Q +sRCzELUQtxC4ELoQvBC+EMAQwhDZEOAQ/RD/EQERAxEFEQcRCxEYERoRKBExEToRQBFJEVARXxFnEXIR +exGCEZsRpBGpEbwRxRHMEdkR3xHoEeoSRxJJEksSTRJPElESUxJVElcSWRJbEl0SXxJhEmMSZRJnEmkS +axJtEm8ScRJzEnUSdxJ5EnsSfRJ/EoESgxKFEocSiRKLEo0SjxKREpQSlxKaEp0SoBKjEqYSqRK2Er8S +xxLJEssSzRLuEvYTChMVEyMTLRM6E0ETQxNFE0oTTBNRE1MTVRNXE2QTcBNzE3YTeROKE4wTmROoE6oT +rBOuE7YTyBPRE9YT6RP2E/gT+hP8FA8UGBQdFCgUOhRDFEoUYhRxFIIUkBSSFJQUlhSYFKEUoxSlFLsU +xRTOFNUU7BT5FPsU/RT/FSAVIhUkFSkVKxUtFS8VMRU+FUEVRBVHFVYVWBVnFXQVdhV4FXoVmxWdFZ8V +oRWjFaUVpxW0FbcVuhW9FcsV2RXmFegV6hXsFg0WDxYRFhMWFRYXFhkWKBY3FkQWRhZIFkoWbxZ5FnsW +fRZ/FoEWgxaFFocWlRaXFqYWsxa1FrcWuRbaFtwW3hbgFuIW5BbmFwQXHRcuFzAXMhc0FzYXQhdPF1EX +UxdVF3YXeBd6F3wXfheAF4IXkxeWF5kXnBefF6gXqhfAF80XzxfRF9MX9Bf2F/gX+hf8F/4YABgNGBAY +ExgWGBwYHhglGDIYNBg2GDgYWRhbGF0YXxhhGGMYZRh2GHkYexh+GIEYmxidGKgYtRi3GLkYuxjcGN4Y +4BjiGOQY5hjoGPUY+Bj7GP4ZChkMGSQZMRkzGTUZNxlYGV4ZYBliGWQZZhloGWoZbBl5GXwZfxmCGZUZ +sBm9Gb8ZwRnDGeQZ5hnoGeoZ7BnuGfAZ9Bn2GfsaCBoKGgwaDhovGjEaMxo1GjcaORo7GkgaShpRGl4a +YBpiGmQahRqHGokaixqNGo8akRqWGpgaphqzGrUatxq5Gtoa3BreGuAa4hrkGuYbBBslGzIbNBs2Gzgb +WRtbG10bYhtkG2YbaBtqG3YbeBuRG54boBuiG6QbyRvLG80bzxvRG9Mb1RviG+Ub6BvrG/Yb+BwSHB8c +IRwjHCUcQhxEHEYcSBxKHEwcThxgHHkchhyIHIocjBytHK8csRyzHLUctxy5HMoczRzQHNMc1hzhHPkd +Bh0IHQodDB0tHS8dMR0zHTUdNx05HVYdWB1qHXcdeR17HX0dnh2gHaIdpB2mHagdqh22HdYd4x3lHecd +6R4KHgweDh4QHhIeFB4WHiEeIx4uHjsePR4/HkEeYh5kHmYeaB5qHmwebh6IHo4enx6hHqMepR6nHrMe +wB7CHsQexh7nHuke6x7tHu8e8R7zHwAfAx8GHwkfFh8YHy4fOx89Hz8fQR9iH2QfZh9oH2ofbB9uH3Mf +dR97H4gfih+MH44frx+xH7MftR+3H7kfux/CH8of2x/dH98f4R/jH+wf7h/wH/ogBCARIBMgFSAXIDgg +OiA8ID4gQCBCIEQgTSBmIHMgdSB3IHkgmiCcIJ4goCCiIKQgpiCsIK4gvCDJIMsgzSDPIPAg8iD0IPYg ++CD6IPwhASEOIR8hISEjISUhJyEwIT0hPyFBIUMhZCFmIWghaiFsIW4hcCF9IaEhriGwIbIhtCHVIdch +2SHbId0h3yHhIeYh6CHuIfsh/SH/IgIiIyIlIiciKSIrIi0iLyJDIkUiZSJyInQidyJ6IpsinSKgIqIi +pCKmIqgivSLPIuAi4iLkIuci6iMHIwkjDCMOIxAjEiMUIy8jTyNgI2IjZCNmI2kjdSOCI4QjhyOKI6sj +rSOwI7IjtCO2I7gj3yQBJBIkFCQWJBgkGyQzJEAkQiRFJEgkaSRrJG4kcSRzJHUkdyR8JH4khCSVJJck +mSSbJJ0kqiSsJK8ksiTTJNUk2CTbJN0k3yTiJO8k8iT1JPglEiUUJR4lJyUqJfUl9yX6Jfwl/yYCJgUm +ByYJJgsmDiYQJhImFSYXJhkmHCYfJiEmJCYnJikmKyYtJi8mMSYzJjUmNyY5JjwmPyZBJkQmRiZIJksm +TiZRJlMmVSZYJlomXCZeJmEmYyZlJmcmaiZtJm8mcSZzJnYmeCZ6Jn0mfyaBJoMmhSaIJosmjiaRJpQm +liaYJpomnCafJqEmoyalJqgmqiasJq8msSa0Jrcmuia8Jr8mwSbDJsYmyCbKJswmzibQJtIm1CbWJtgm +2ybeJuAm4ycMJxonJycpJysnLCcuJy8nMSczJzUnXidgJ2InYydlJ2YnaCdqJ2wncyd8J34nhyeJJ4sn +jieRJ7onvCe+J78nwSfCJ8QnxifIJ9cn4CflKA4oGCghKCMoJSgoKCooLCguKDAoMyg6KEkoUihUKFko +WyhdKIYoiCiKKI0ojyiRKJMoliiZKKoorSiwKLMotii7KMQoxijhKOMo5ijpKOso7SjvKPEo8yj2KPko +/Cj/KQIpKyktKS8pMCkyKTMpNSk3KTkpYilkKWYpZylpKWopbCluKXApmSmbKZ0poCmiKaQppimoKasp +sCm5KbspxinIKcspzinRKdMp+Cn6Kf0qACoCKgQqBioQKhIqNyo5KjwqPypBKkMqRSpTKlUqeip8Kn8q +giqEKoYqiCqhKqMqzCrOKtAq0yrVKtcq2SrbKt4q9Sr+KwArCSsLKw0rDysRKzorPCs+K0ErQytFK0cr +SStMK1orYytlK2wrbitwK3IrgyuGK4krjCuPK5groSujK6QrtivfK+Er4yvkK+Yr5yvpK+sr7SwOLBAs +EywVLBcsGSwbLCYsTyxRLFQsVyxZLFssXSxgLGMsaCxxLHMsdix5LJosnCyfLKIspCymLKgswSzDLOQs +5izpLOws7izwLPIs9iz4LSEtIy0lLSctKS0rLS0tMC0zLTwtPi1VLVgtWy1eLWEtZC1nLWktay1tLXAt +ci2bLZ0tny2gLaItoy2lLactqS3SLdQt1y3aLdwt3i3gLeIt5S4OLhAuEi4TLhUuFi4YLhouHC4pLkou +TC5PLlIuVC5WLlguYy5lLmoucy51Lowujy6SLpUumC6aLpwuni6gLqMupS6nLtAu0i7ULtcu2S7bLt0u +3y7iLu4u9y75Lvwu/i8XL0AvQi9EL0UvRy9IL0ovTC9OL3cveS97L34vgC+CL4Qvhy+KL5Evmi+cL6Ev +pC+mL88v0S/TL9Yv2C/aL9wv3y/iL+cv8C/yL/cv+S/8MCUwJzApMCwwLjAwMDIwNTA4MGEwYzBlMGgw +ajBsMG4wcTB0MH4whzCJMJgwmzCeMKEwpDCnMKowrTC5MMIwxDDGMM8w1DDdMOAxqzGtMa8xsTGzMbUx +tzG5MbwxvjHAMcIxxDHHMckxyzHOMdAx0jHUMdYx2DHaMdwx3jHgMeIx5THnMekx6zHtMe8x8jH0MfYx ++TH7Mf0x/zIBMgMyBTIHMgoyDDIOMhAyEjIVMhcyGjIdMh8yIjIkMicyKjItMjAyMjI0MjYyODI7Mj4y +QDJCMkQyRjJJMksyTTJPMlEyUzJWMlgyWjJcMl4yYDJjMmUyZzJpMmsybTJwMnIydDJ2MngyejJ8Mn4y +gDKCMoQyhjKIMpEylDNhM2MzZjNoM2szbjNwM3MzdTN3M3ozfDN+M4EzgzOGM4gzijONM5AzkzOVM5cz +mTObM50znzOhM6MzpTOoM6szrTOwM7IztDO3M7ozvTO/M8EzxDPGM8gzyjPNM88z0TPTM9Yz2TPbM90z +3zPiM+Qz5jPpM+sz7TPvM/Ez9DP3M/oz/TQANAI0BDQGNAg0CzQNNA80ETQTNBY0GDQbNB00IDQjNCY0 +KDQrNC00LzQyNDQ0NjQ4NDo0PDQ+NEA0QjRENEY0STRMNE40UTRaNF01KjUtNTA1MzU2NTk1PDU/NUI1 +RTVINUs1TjVRNVQ1VzVaNV01YDVjNWY1aTVsNW81cjV1NXg1ezV+NYE1hDWHNYo1jTWQNZM1ljWZNZw1 +nzWiNaU1qDWrNa41sTW0Nbc1ujW9NcA1wzXGNck1zDXPNdI11TXYNds13jXhNeQ15zXqNe018DXzNfY1 ++TX8Nf82AjYFNgg2CzYONhE2FDYXNho2HTYgNiM2JjYpNiw2LzYyNjU2ODY7Nj42QTZENkc2SjZNNlA2 +UzZWNlk2gzaPNqk26Db7NyU3MTc/N1M3aDdtN283gjePN7Y3yTfbN+038TgKODQ4SzhPOH04oziuOLA4 +vDjPONk45TkPORE5KDk6OTw5QDlYOXE5hTmhObs51DngOeI59zoEOjs6XDqBOo86mzq2Oss67zr9OxA7 +Ljs6Ozw7XDt/O5Q7pzvDO9o79TwTPDg8VDx5PJE8qDy1PLg80jznPPM9GT06PWA9bD2APYw9tD3HPdA9 +5z3pPgg+ID49Plo+bD55PpU+lz6jPr0+0D7ZPtw+3T7mPuk+6j7zPvZAHUAfQCFAJEAnQClALEAvQDJA +NEA2QDhAO0A9QD9AQUBEQEZASEBKQExATkBQQFNAVkBYQFpAXUBgQGJAZUBoQGpAbEBuQHBAckB0QHZA +eEB6QHxAfkCBQIRAhkCIQIpAjUCPQJFAlECXQJlAm0CeQKBAokClQKdAqUCrQK5AsECyQLRAtkC5QLxA +vkDAQMJAxEDGQMlAy0DNQM9A0UDUQNZA2EDaQNxA30DiQOVA6EDrQO1A70DxQPNA9UD4QPpA/UEAQQJB +BEEGQQlBC0ENQQ9BEkEUQRZBGUEbQR5BIUEjQSZBKEEqQSxBLkEwQTNBNUE3QTpBPEE/QUFBQ0FFQUdB +SUFLQU1BT0FRQVNBVkFYQVpBXEFeQWBBYkFlQWhBakFtQW9BeEF7QqJCpUKoQqtCrkKxQrRCt0K6Qr1C +wELDQsZCyULMQs9C0kLVQthC20LeQuFC5ELnQupC7ULwQvNC9kL5QvxC/0MCQwVDCEMLQw5DEUMUQxdD +GkMdQyBDI0MmQylDLEMvQzJDNUM4QztDPkNBQ0RDR0NKQ01DUENTQ1ZDWUNcQ19DYkNlQ2hDa0NuQ3FD +dEN3Q3pDfUOAQ4NDhkOJQ4xDj0OSQ5VDmEObQ55DoUOkQ6dDqkOtQ7BDs0O2Q7lDvEO/Q8JDxUPIQ8tD +zkPRQ9RD10PaQ91D4EPjQ+ZD6UPsQ+9D8kP1Q/hD+0P+RAFEBEQHRApEDUQQRBNEFkQZRBxEH0QiRCVE +KEQrRC5EMUQ0RDdEOkQ9REBEQ0RGRElETERPRFJEVURYRFtEXURgRGJEZERnRGlEa0RuRHFEdER3RHpE +fER/RIFEg0SFRIhEi0SNRI9EkUSTRJVEl0SZRJtEnkSgRKNEpkSpRKtErUSvRLJEtUS4RLpEvES+RMBE +wkTFRMdEykTMRM5E0UTTRNVE2ETaRNxE3kThRORE5kToROpE7UTvRPJE9ET2RPhE+kT8RP9FAUUERQZF +CUULRQ5FEUUURRdFGUUbRR1FH0UhRSRFJkUoRStFLkUxRTRFNkU4RTtFPUVARUJFREVGRUhFS0VNRU9F +UUVURVZFWEVaRVxFX0VhRWRFZkVoRWtFbUVvRXJFdEV3RXlFe0V+RYBFgkWFRYhFikWMRY5FkUWTRZZF +mUWbRZ5FoUWkRaZFqEWxRbRFtkW4RcFFw0XERc1F0EXRRdpF3UXeRedF7AAAAAAAAAICAAAAAAAACaAA +AAAAAAAAAAAAAAAAAEX7A + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/CurrencyConverter.xib =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/CurrencyConverter.xib (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/CurrencyConverter.xib (revision 8058) @@ -0,0 +1,2923 @@ + + + + 1050 + 9A581 + 629 + 949 + 343.00 + + YES + + + + + YES + com.apple.InterfaceBuilder.CocoaPlugin + + + YES + + NSApplication + + + FirstResponder + + + + + + AMainMenu + + YES + + + Currency Converter + + 1048576 + 2147483647 + + NSImage + NSMenuCheckmark + + + + NSMenuMixedState + + submenuAction: + + + + YES + + + About Currency Converter + + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + UHJlZmVyZW5jZXPigKY + , + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Services + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + _NSServicesMenu + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Hide Currency Converter + h + 1048576 + 2147483647 + + + + + + Hide Others + + 1572864 + 2147483647 + + + + + + Show All + + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Quit Currency Converter + q + 1048576 + 2147483647 + + + + + _NSAppleMenu + + + + + File + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + New + n + 1048576 + 2147483647 + + + + + + T3BlbuKApg + o + 1048576 + 2147483647 + + + + + + Open Recent + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Clear Menu + + 1048576 + 2147483647 + + + + + _NSRecentDocumentsMenu + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Close + w + 1048576 + 2147483647 + + + + + + Save + s + 1048576 + 2147483647 + + + + + + U2F2ZSBBc+KApg + S + 1179648 + 2147483647 + + + + + + Revert to Saved + + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Page Setup... + P + 1179648 + 2147483647 + + + + + + + UHJpbnTigKY + p + 1048576 + 2147483647 + + + + + + + + + Edit + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Undo + z + 1048576 + 2147483647 + + + + + + Redo + Z + 1179648 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Cut + x + 1048576 + 2147483647 + + + + + + Copy + c + 1048576 + 2147483647 + + + + + + Paste + v + 1048576 + 2147483647 + + + + + + Delete + + 1048576 + 2147483647 + + + + + + Select All + a + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Find + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + RmluZOKApg + f + 1048576 + 2147483647 + + + 1 + + + + Find Next + g + 1048576 + 2147483647 + + + 2 + + + + Find Previous + G + 1179648 + 2147483647 + + + 3 + + + + Use Selection for Find + e + 1048576 + 2147483647 + + + 7 + + + + Jump to Selection + j + 1048576 + 2147483647 + + + + + + + + + Spelling and Grammar + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + U2hvdyBTcGVsbGluZ+KApg + : + 1048576 + 2147483647 + + + + + + Check Spelling + ; + 1048576 + 2147483647 + + + + + + Check Spelling While Typing + + 1048576 + 2147483647 + + + + + + Check Grammar With Spelling + + 1048576 + 2147483647 + + + + + + + + + Substitutions + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Smart Copy/Paste + + 2147483647 + + + 1 + + + + Smart Quotes + + 2147483647 + + + 2 + + + + Smart Links + + 2147483647 + + + 3 + + + + + + + Speech + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Start Speaking + + 1048576 + 2147483647 + + + + + + Stop Speaking + + 1048576 + 2147483647 + + + + + + + + + + + + Format + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Show Fonts + t + 1048576 + 2147483647 + + + + + + Show Colors + C + 1179648 + 2147483647 + + + + + + + + + View + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Show Toolbar + + 1572864 + 2147483647 + + + + + + Q3VzdG9taXplIFRvb2xiYXLigKY + + 1048576 + 2147483647 + + + + + + + + + Window + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Minimize + m + 1048576 + 2147483647 + + + + + + Zoom + + 1048576 + 2147483647 + + + + + + YES + YES + + + 1048576 + 2147483647 + + + + + + Bring All to Front + + 1048576 + 2147483647 + + + + + _NSWindowsMenu + + + + + Help + + 1048576 + 2147483647 + + + submenuAction: + + + + YES + + + Currency Converter Help + ? + 1048576 + 2147483647 + + + + + + + + _NSMainMenu + + + 7 + 2 + {{306, 767}, {350, 189}} + 611844096 + + NSWindow + + + + 256 + + YES + + + 268 + {{195, 147}, {135, 22}} + + + YES + + -1804468671 + 272630784 + + + LucidaGrande + 1.300000e+01 + 1044 + + + YES + + 6 + System + textBackgroundColor + + 3 + MQA + + + + 6 + + textColor + + 3 + MAA + + + + + + + 268 + {{195, 115}, {135, 22}} + + + YES + + -1804468671 + 272630784 + + + + YES + + + + + + + 268 + {{195, 83}, {135, 22}} + + + YES + + -2072904127 + 272630784 + + + + YES + + + + + + + 268 + {{47, 149}, {143, 17}} + + + YES + + 67239488 + 71304192 + Exchange rate per $1: + + + + 6 + + controlColor + + 3 + MC42NjY2NjY2OQA + + + + 6 + + controlTextColor + + + + + + + 268 + {{67, 115}, {123, 17}} + + + YES + + 67239488 + 71304192 + Dollars to Convert: + + + + + + + + + 268 + {{17, 83}, {173, 17}} + + + YES + + 67239488 + 71304192 + Amount in other Currency: + + + + + + + + + 268 + {{214, 12}, {96, 32}} + + + YES + + 67239424 + 134217728 + Convert + + + -2038284033 + 129 + + DQ + 200 + 25 + + + + + 12 + {{20, 58}, {310, 5}} + + + {0, 0} + + 67239424 + 0 + Box + + + + 3 + MCAwLjgwMDAwMDAxAA + + + 3 + 2 + 0 + NO + + + {350, 189} + + + + {{0, 0}, {1920, 1178}} + + + Converter + + + ConverterController + + + + + YES + + + performMiniaturize: + + + + 37 + + + + arrangeInFront: + + + + 39 + + + + print: + + + + 86 + + + + runPageLayout: + + + + 87 + + + + clearRecentDocuments: + + + + 127 + + + + orderFrontStandardAboutPanel: + + + + 142 + + + + performClose: + + + + 193 + + + + toggleContinuousSpellChecking: + + + + 222 + + + + undo: + + + + 223 + + + + copy: + + + + 224 + + + + checkSpelling: + + + + 225 + + + + paste: + + + + 226 + + + + stopSpeaking: + + + + 227 + + + + cut: + + + + 228 + + + + showGuessPanel: + + + + 230 + + + + redo: + + + + 231 + + + + selectAll: + + + + 232 + + + + startSpeaking: + + + + 233 + + + + delete: + + + + 235 + + + + performZoom: + + + + 240 + + + + performFindPanelAction: + + + + 241 + + + + centerSelectionInVisibleArea: + + + + 245 + + + + toggleGrammarChecking: + + + + 347 + + + + toggleSmartInsertDelete: + + + + 355 + + + + toggleAutomaticQuoteSubstitution: + + + + 356 + + + + toggleAutomaticLinkDetection: + + + + 357 + + + + showHelp: + + + + 360 + + + + orderFrontColorPanel: + + + + 361 + + + + saveDocument: + + + + 362 + + + + saveDocumentAs: + + + + 363 + + + + revertDocumentToSaved: + + + + 364 + + + + runToolbarCustomizationPalette: + + + + 365 + + + + toggleToolbarShown: + + + + 366 + + + + hide: + + + + 369 + + + + hideOtherApplications: + + + + 370 + + + + terminate: + + + + 371 + + + + unhideAllApplications: + + + + 372 + + + + nextKeyView + + + + 390 + + + + + + + + 391 + + + + initialFirstResponder + + + + 392 + + + + rateField + + + + 396 + + + + dollarField + + + + 397 + + + + amountField + + + + 398 + + + + converter + + + + 399 + + + + convert: + + + + 400 + + + + + YES + + 0 + + YES + + + + + + -2 + + + RmlsZSdzIE93bmVyA + + + -1 + + + First Responder + + + -3 + + + Application + + + 29 + + + YES + + + + + + + + + + MainMenu + + + 19 + + + YES + + + + + + 56 + + + YES + + + + + + 103 + + + YES + + + + 1 + + + 217 + + + YES + + + + + + 83 + + + YES + + + + + + 81 + + + YES + + + + + + + + + + + + + + + + 75 + + + 3 + + + 80 + + + 8 + + + 78 + + + 6 + + + 72 + + + + + 82 + + + 9 + + + 124 + + + YES + + + + + + 77 + + + 5 + + + 73 + + + + + + 79 + + + 7 + + + 112 + + + 10 + + + 74 + + + 2 + + + 125 + + + YES + + + + + + 126 + + + + + 205 + + + YES + + + + + + + + + + + + + + + + + + 202 + + + + + 198 + + + + + 207 + + + + + 214 + + + + + 199 + + + + + 203 + + + + + 197 + + + + + 206 + + + + + 215 + + + + + 218 + + + YES + + + + + + 216 + + + YES + + + + + + 200 + + + YES + + + + + + + + + 219 + + + + + 201 + + + + + 204 + + + + + 220 + + + YES + + + + + + + + + + 213 + + + + + 210 + + + + + 221 + + + + + 208 + + + + + 209 + + + + + 106 + + + YES + + + + + + + 111 + + + + + 57 + + + YES + + + + + + + + + + + + + + + + 58 + + + + + 134 + + + + + 150 + + + + + 136 + + + 1111 + + + 144 + + + + + 129 + + + 121 + + + 143 + + + + + 236 + + + + + 131 + + + YES + + + + + + 149 + + + + + 145 + + + + + 130 + + + + + 24 + + + YES + + + + + + + + + 92 + + + + + 5 + + + + + 239 + + + + + 23 + + + + + 295 + + + YES + + + + + + 296 + + + YES + + + + + + + 297 + + + + + 298 + + + + + 299 + + + YES + + + + + + 300 + + + YES + + + + + + + 344 + + + + + 345 + + + + + 211 + + + YES + + + + + + 212 + + + YES + + + + + + + 195 + + + + + 196 + + + + + 346 + + + + + 348 + + + YES + + + + + + 349 + + + YES + + + + + + + + 350 + + + + + 351 + + + + + 354 + + + + + 367 + + + YES + + + + + + 368 + + + YES + + + + + + + + + + + + + 373 + + + YES + + + + + + 374 + + + + + 375 + + + YES + + + + + + 376 + + + + + 377 + + + YES + + + + + + 378 + + + + + 379 + + + YES + + + + + + 380 + + + + + 381 + + + YES + + + + + + 382 + + + + + 383 + + + YES + + + + + + 384 + + + + + 385 + + + YES + + + + + + 386 + + + + + 389 + + + + + 394 + + + + + 395 + + + + + + + YES + + YES + -1.IBPluginDependency + -2.IBPluginDependency + -3.IBPluginDependency + 103.IBPluginDependency + 103.ImportedFromIB2 + 106.IBPluginDependency + 106.ImportedFromIB2 + 106.editorWindowContentRectSynchronizationRect + 111.IBPluginDependency + 111.ImportedFromIB2 + 112.IBPluginDependency + 112.ImportedFromIB2 + 124.IBPluginDependency + 124.ImportedFromIB2 + 125.IBPluginDependency + 125.ImportedFromIB2 + 125.editorWindowContentRectSynchronizationRect + 126.IBPluginDependency + 126.ImportedFromIB2 + 129.IBPluginDependency + 129.ImportedFromIB2 + 130.IBPluginDependency + 130.ImportedFromIB2 + 130.editorWindowContentRectSynchronizationRect + 131.IBPluginDependency + 131.ImportedFromIB2 + 134.IBPluginDependency + 134.ImportedFromIB2 + 136.IBPluginDependency + 136.ImportedFromIB2 + 143.IBPluginDependency + 143.ImportedFromIB2 + 144.IBPluginDependency + 144.ImportedFromIB2 + 145.IBPluginDependency + 145.ImportedFromIB2 + 149.IBPluginDependency + 149.ImportedFromIB2 + 150.IBPluginDependency + 150.ImportedFromIB2 + 19.IBPluginDependency + 19.ImportedFromIB2 + 195.IBPluginDependency + 195.ImportedFromIB2 + 196.IBPluginDependency + 196.ImportedFromIB2 + 197.IBPluginDependency + 197.ImportedFromIB2 + 198.IBPluginDependency + 198.ImportedFromIB2 + 199.IBPluginDependency + 199.ImportedFromIB2 + 200.IBPluginDependency + 200.ImportedFromIB2 + 200.editorWindowContentRectSynchronizationRect + 201.IBPluginDependency + 201.ImportedFromIB2 + 202.IBPluginDependency + 202.ImportedFromIB2 + 203.IBPluginDependency + 203.ImportedFromIB2 + 204.IBPluginDependency + 204.ImportedFromIB2 + 205.IBPluginDependency + 205.ImportedFromIB2 + 205.editorWindowContentRectSynchronizationRect + 206.IBPluginDependency + 206.ImportedFromIB2 + 207.IBPluginDependency + 207.ImportedFromIB2 + 208.IBPluginDependency + 208.ImportedFromIB2 + 209.IBPluginDependency + 209.ImportedFromIB2 + 210.IBPluginDependency + 210.ImportedFromIB2 + 211.IBPluginDependency + 211.ImportedFromIB2 + 212.IBPluginDependency + 212.ImportedFromIB2 + 212.editorWindowContentRectSynchronizationRect + 213.IBPluginDependency + 213.ImportedFromIB2 + 214.IBPluginDependency + 214.ImportedFromIB2 + 215.IBPluginDependency + 215.ImportedFromIB2 + 216.IBPluginDependency + 216.ImportedFromIB2 + 217.IBPluginDependency + 217.ImportedFromIB2 + 218.IBPluginDependency + 218.ImportedFromIB2 + 219.IBPluginDependency + 219.ImportedFromIB2 + 220.IBPluginDependency + 220.ImportedFromIB2 + 220.editorWindowContentRectSynchronizationRect + 221.IBPluginDependency + 221.ImportedFromIB2 + 23.IBPluginDependency + 23.ImportedFromIB2 + 236.IBPluginDependency + 236.ImportedFromIB2 + 239.IBPluginDependency + 239.ImportedFromIB2 + 24.IBPluginDependency + 24.ImportedFromIB2 + 24.editorWindowContentRectSynchronizationRect + 29.IBPluginDependency + 29.ImportedFromIB2 + 29.WindowOrigin + 29.editorWindowContentRectSynchronizationRect + 295.IBPluginDependency + 296.IBPluginDependency + 296.editorWindowContentRectSynchronizationRect + 297.IBPluginDependency + 298.IBPluginDependency + 299.IBPluginDependency + 300.IBPluginDependency + 300.editorWindowContentRectSynchronizationRect + 344.IBPluginDependency + 345.IBPluginDependency + 346.IBPluginDependency + 346.ImportedFromIB2 + 348.IBPluginDependency + 348.ImportedFromIB2 + 349.IBPluginDependency + 349.ImportedFromIB2 + 349.editorWindowContentRectSynchronizationRect + 350.IBPluginDependency + 350.ImportedFromIB2 + 351.IBPluginDependency + 351.ImportedFromIB2 + 354.IBPluginDependency + 354.ImportedFromIB2 + 367.IBPluginDependency + 367.IBWindowTemplateEditedContentRect + 367.NSWindowTemplate.visibleAtLaunch + 367.editorWindowContentRectSynchronizationRect + 368.IBPluginDependency + 373.IBPluginDependency + 374.IBPluginDependency + 375.IBPluginDependency + 376.IBPluginDependency + 377.IBPluginDependency + 378.IBPluginDependency + 379.IBPluginDependency + 380.IBPluginDependency + 381.IBPluginDependency + 382.IBPluginDependency + 383.IBPluginDependency + 384.IBPluginDependency + 385.IBPluginDependency + 386.IBPluginDependency + 389.IBPluginDependency + 394.IBPluginDependency + 395.IBPluginDependency + 5.IBPluginDependency + 5.ImportedFromIB2 + 56.IBPluginDependency + 56.ImportedFromIB2 + 57.IBPluginDependency + 57.ImportedFromIB2 + 57.editorWindowContentRectSynchronizationRect + 58.IBPluginDependency + 58.ImportedFromIB2 + 72.IBPluginDependency + 72.ImportedFromIB2 + 73.IBPluginDependency + 73.ImportedFromIB2 + 74.IBPluginDependency + 74.ImportedFromIB2 + 75.IBPluginDependency + 75.ImportedFromIB2 + 77.IBPluginDependency + 77.ImportedFromIB2 + 78.IBPluginDependency + 78.ImportedFromIB2 + 79.IBPluginDependency + 79.ImportedFromIB2 + 80.IBPluginDependency + 80.ImportedFromIB2 + 81.IBPluginDependency + 81.ImportedFromIB2 + 81.editorWindowContentRectSynchronizationRect + 82.IBPluginDependency + 82.ImportedFromIB2 + 83.IBPluginDependency + 83.ImportedFromIB2 + 92.IBPluginDependency + 92.ImportedFromIB2 + + + YES + + + + + + + + {{532, 981}, {242, 23}} + + + + + + + + + {{522, 812}, {146, 23}} + + + + + + + {{436, 809}, {64, 6}} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {{608, 612}, {275, 83}} + + + + + + + + + + + {{301, 761}, {243, 243}} + + + + + + + + + + + + + + + {{608, 612}, {167, 43}} + + + + + + + + + + + + + + + + + {{608, 612}, {241, 103}} + + + + + + + + + + + {{461, 931}, {197, 73}} + + + {74, 862} + {{88, 1004}, {505, 20}} + + + {{411, 961}, {234, 43}} + + + + + {{345, 961}, {176, 43}} + + + + + + + + + {{440, 714}, {177, 63}} + + + + + + + + {{87, 713}, {350, 189}} + + + + + + + + + + + + + + + + + + + com.apple.InterfaceBuilder.CocoaPlugin + com.apple.InterfaceBuilder.CocoaPlugin + + + + + + + {{100, 821}, {271, 183}} + + + + + + + + + + + + + + + + + + + + + {{259, 801}, {199, 203}} + + + + + + + + + + YES + + YES + + + YES + + + + + YES + + YES + + + YES + + + + 400 + + + + YES + + + + + + id + + + YES + + YES + + + + + + + YES + + + + + + + + IBUserSource + + + + + + + + myAction1: + + + + YES + + YES + + + YES + + + + + + + + + + 0 + + 3 + + YnBsaXN0MDDUAAEAAgADAAQABQAGAAkAClgkdmVyc2lvblQkdG9wWSRhcmNoaXZlclgkb2JqZWN0cxIA +AYag0QAHAAhdSUIub2JqZWN0ZGF0YYABXxAPTlNLZXllZEFyY2hpdmVyrxECfAALAAwAMQA1ADYAPAA9 +AEIAVgBXAFgAWQALAGYAcQB9AH4AkACRAJkAmgCdAKcAqACpAK4AsAC1ALYAuQC9AMMAywDMANQA3ADd +AOYA7gDvAPgA+QD+AP8BAgEHAQgBEAERARgBGQEhASIBKQEqATIBMwFGAUcBSAFLAU4BXwFgAWEBZwFo +AWsBbgFyAAsBcwF1AXYBeQF9Aa0BswHDAcgByQHOAc8B0AHTAdcB2AHbAdwB4AHkAesB7wHwAfEB8gH2 +Af0CAgIDAgQCCAIQAhQCFQIWAhcCGwIiAiYCJwIoAikCLwIyAjMCNgI3AjgCOwJAAkECRgJHAksCUgJX +AlgCWQJdAmQCZQJmAmcCawJyAnMCdAJ4AoEChQKGAocCiAKMApMCmAKZApoCnwKgAqQCqwKvArACsQK2 +Ar0CvgK/AsMCywLMAs0CzgLSAtkC2gLbAtwC4ALnAusC7ALtAvIC8wL3Av4C/wMAAwEDBQMMAw0DDgMP +AxMDGgMbAxwDIQMiAyYDLQMuAy8DMwM6AzsDPANAA0cDSANJA0oDTgNVA1YDVwNbA2IDYwNkA2UDaQNw +A3QDdQN2A3cDewOCA4MDhAOFA4kDkAORA5IDlgOdA6EDogOjA6QDqAOvA7ADsQOyA7YDvQO+A78DwwPK +A8sDzAPNA9ED2APZA9oD2wPfA+YD5wPoA+wD8wP0A/UD9gP7A/wEAAQHBAgECQQOBBIEGQQaBBsEHAQg +BCkEKgQrBCwEMAQ3BDgEOQQ6BKEEogSoBKoEqwSvBLAEtQTABMkEygTPBNYE1wTiBOcE6ATpBPAE+QT6 +BQMFBAUIBQkFEgToBRsFHgToBScFNQU+BUUFRgVHBVAE6AVRBVYFWQVaBWMFZAVrBWwFbQToBXYFdwWH +BZAFmQToBZoFogWpBaoFqwWyBbMFtAW9BOgFvgXFBc4E6AXPBdQF2wXcBd0E6AXmBe8E6AXwBf4GBQYG +BgcE6AYQBhkE6AYiBiMGLQToBjYGNwY5BqAHCAdwB3EHcgdzB3QHdQd2B3cHeAd5B3oHewd8B30Hfgd/ +B4AHgQeCB4MHhAeFB4YHhweIB4kHigeLB4wHjQeOB48HkAeRB5IHkweUB5UHlgeXB5gHmQeaB5sHnAed +B54HnwegB6EHogejB6QHpQemB6cHqAepB6oHqwesB60HrgevB7AHsQeyB7MHtAe1B7YHtwe4B7kHuge7 +B7wHvQe+B78HwAfBB8IHwwfEB8UHxgfHB8gHyQfKB8sHzAfNB84HzwfQB9ECNgfSB9MH1AfXB9oIbwkE +CQUJBgkHCQgJCQkKCQsJDAkNCQ4JDwkQCREJEgkTCRQJFQkWCRcJGAkZCRoJGwkcCR0JHgkfCSAJIQki +CSMJJAklCSYJJwkoCSkJKgkrCSwJLQkuCS8JMAkxCTIJMwk0CTUJNgk3CTgJOQk6CTsJPAk9CT4JPwlA +CUEJQgFDCUMJRAlFCUYJRwlICUkJSglLCUwJTQlOCU8JUAlRCVIJUwlUCVUJVglXCVgJWQlaCVsJXAld +CV4JXwlgCWEJYgljCWQJZQlmCWcJaAlpCWoJawlsCW0JbglvCXAJcQlyCXMJdAl1CXYJdwl4AT4JeQl6 +CXsJfAl9CX4JfwmACYEJggmDCYQJhQmGCYcJiAmJCYoJiwmMCY0JjgmPCZAJkQmSCZMJlAmXCZoJnVUk +bnVsbN8QEgANAA4ADwAQABEAEgATABQAFQAWABcAGAAZABoAGwAcAB0AHgAfACAAIQAiACMAJAAlACYA +JwAoACkAKgArACwALQAuAC8AMFZOU1Jvb3RWJGNsYXNzXU5TT2JqZWN0c0tleXNfEA9OU0NsYXNzZXNW +YWx1ZXNfEBlOU0FjY2Vzc2liaWxpdHlPaWRzVmFsdWVzXU5TQ29ubmVjdGlvbnNbTlNOYW1lc0tleXNb +TlNGcmFtZXdvcmtdTlNDbGFzc2VzS2V5c1pOU09pZHNLZXlzXU5TTmFtZXNWYWx1ZXNfEBlOU0FjY2Vz +c2liaWxpdHlDb25uZWN0b3JzXU5TRm9udE1hbmFnZXJfEBBOU1Zpc2libGVXaW5kb3dzXxAPTlNPYmpl +Y3RzVmFsdWVzXxAXTlNBY2Nlc3NpYmlsaXR5T2lkc0tleXNZTlNOZXh0T2lkXE5TT2lkc1ZhbHVlc4AC +gQJ7gQEdgQHjgQJ6gEuBAXuABYEB4oEB5IEBfIECeIAAgAaBAXqBAnkRAZKBAeXSAA4AMgAzADRbTlND +bGFzc05hbWWABIADXU5TQXBwbGljYXRpb27SADcAOAA5ADpYJGNsYXNzZXNaJGNsYXNzbmFtZaIAOgA7 +Xk5TQ3VzdG9tT2JqZWN0WE5TT2JqZWN0XxAQSUJDb2NvYUZyYW1ld29ya9IADgA+AD8AQFpOUy5vYmpl +Y3RzgEqhAEGAB9oAQwAOAEQARQBGAEcASABJAEoASwBMAE0ATgBPAFAAUQBSAFMAVAArXE5TV2luZG93 +Vmlld1xOU1NjcmVlblJlY3RdTlNXaW5kb3dUaXRsZVlOU1dURmxhZ3NdTlNXaW5kb3dDbGFzc1xOU1dp +bmRvd1JlY3RfEA9OU1dpbmRvd0JhY2tpbmdfEBFOU1dpbmRvd1N0eWxlTWFza1tOU1ZpZXdDbGFzc4AL +gEmASIAJEiR4AACACoAIEAIQB4AAXxAYe3szMDYsIDc2N30sIHszNTAsIDE4OX19XxASQ3VycmVuY3kg +Q29udmVydGVyWE5TV2luZG931wBaAA4AWwBcAF0AWABeAF8AYABhAGIAYwBfAGVfEA9OU05leHRSZXNw +b25kZXJaTlNTdWJ2aWV3c1hOU3ZGbGFnc1tOU0ZyYW1lU2l6ZVtOU1N1cGVydmlld4AMgEeADREBAIBF +gAyARtIADgA+AGcAaIBEqABpAGoAawBsAG0AbgBvAHCADoAfgCKAJYAugDKANoA92ABaAA4AcgBzAFwA +dABYAF4ATAB2AHcAeAB5AHoAXwBMV05TRnJhbWVWTlNDZWxsWU5TRW5hYmxlZIALgB6AD4AQEQEMCYAM +gAtfEBd7ezE5NSwgMTQ3fSwgezEzNSwgMjJ9fdkAfwAOAIAAgQCCAIMAhACFAIYAhwCIAIkAigCLAGkA +jQB6AI9bTlNDZWxsRmxhZ3NfEBFOU0JhY2tncm91bmRDb2xvclpOU0NvbnRlbnRzWU5TU3VwcG9ydF1O +U0NvbnRyb2xWaWV3XE5TQ2VsbEZsYWdzMl8QEU5TRHJhd3NCYWNrZ3JvdW5kW05TVGV4dENvbG9yE/// +//+Ucf5BgB2AFYARgBKADhIQQAQACYAaUNQADgCSAJMAlACVAJYAlwCYVk5TU2l6ZVZOU05hbWVYTlNm +RmxhZ3OAFCNAKgAAAAAAAIATEQQUXEx1Y2lkYUdyYW5kZdIANwA4AJsAnKIAnAA7Vk5TRm9udNUADgCe +AJ8AoAChAKIAowCkAKUApldOU0NvbG9yXE5TQ29sb3JTcGFjZVtOU0NvbG9yTmFtZV1OU0NhdGFsb2dO +YW1lgBmAGBAGgBeAFlZTeXN0ZW1fEBN0ZXh0QmFja2dyb3VuZENvbG9y0wAOAJ8AqgCiAKwArVdOU1do +aXRlgBkQA0IxANIANwA4AK8AnqIAngA71QAOAJ4AnwCgAKEAogCyAKQAswCmgBmAHIAbgBZZdGV4dENv +bG9y0wAOAJ8AqgCiAKwAuIAZQjAA0gA3ADgAugC7pAC7ALwAcwA7XxAPTlNUZXh0RmllbGRDZWxsXE5T +QWN0aW9uQ2VsbNIANwA4AL4Av6UAvwDAAMEAwgA7W05TVGV4dEZpZWxkWU5TQ29udHJvbFZOU1ZpZXdb +TlNSZXNwb25kZXLYAFoADgByAHMAXAB0AFgAXgBMAHYAxgDHAHkAegBfAEyAC4AegCCAIQmADIALXxAX +e3sxOTUsIDExNX0sIHsxMzUsIDIyfX3ZAH8ADgCAAIEAggCDAIQAhQCGAIcAiACJAIoAiwBqAI0AegCP +gB2AFYARgBKAHwmAGtgAWgAOAHIAcwBcAHQAWABeAEwAdgDXANgAeQB6AF8ATIALgB6AI4AkCYAMgAtf +EBZ7ezE5NSwgODN9LCB7MTM1LCAyMn192QB/AA4AgACBAIIAgwCEAIUAhgDeAIgAiQCKAIsAawCNAHoA +jxP/////hHH+QYAdgBWAEYASgCIJgBrYAFoADgByAHMAXAB0AFgAXgBMAHYA6QDqAHkAegBfAEyAC4Ae +gCaAJwmADIALXxAWe3s0NywgMTQ5fSwgezE0MywgMTd9fdgAfwAOAIAAgQCCAIMAhACGAPAAiADyAPMA +iwBsAPYA9xIEAf5AgB2AKYAogBKAJRIEQAQAgCxfEBVFeGNoYW5nZSByYXRlIHBlciAkMTrVAA4AngCf +AKAAoQCiAPsApAD8AKaAGYArgCqAFlxjb250cm9sQ29sb3LTAA4AnwCqAKIArAEBgBlLMC42NjY2NjY2 +OQDVAA4AngCfAKAAoQCiALIApAEFAKaAGYAcgC2AFl8QEGNvbnRyb2xUZXh0Q29sb3LYAFoADgByAHMA +XAB0AFgAXgBMAHYBCwEMAHkAegBfAEyAC4AegC+AMAmADIALXxAWe3s2NywgMTE1fSwgezEyMywgMTd9 +fdgAfwAOAIAAgQCCAIMAhACGAPAAiADyARQAiwBtAPYA94AdgCmAMYASgC6ALF8QE0RvbGxhcnMgdG8g +Q29udmVydDrYAFoADgByAHMAXAB0AFgAXgBMAHYBHAEdAHkAegBfAEyAC4AegDOANAmADIALXxAVe3sx +NywgODN9LCB7MTczLCAxN3192AB/AA4AgACBAIIAgwCEAIYA8ACIAPIBJQCLAG4A9gD3gB2AKYA1gBKA +MoAsXxAZQW1vdW50IGluIG90aGVyIEN1cnJlbmN5OtgAWgAOAHIAcwBcAHQAWABeAEwBLAEtAS4AeQB6 +AF8ATIALgDyAN4A4CYAMgAtfEBV7ezIxNCwgMTJ9LCB7OTYsIDMyfX3cAH8ADgE0ATUBNgE3AIEAggCD +ATgAhAE5AToBOwCKAT0BPgE/AUAAiwBvAUMBRAFFXxATTlNBbHRlcm5hdGVDb250ZW50c18QEk5TUGVy +aW9kaWNJbnRlcnZhbF5OU0J1dHRvbkZsYWdzMl8QD05TS2V5RXF1aXZhbGVudF8QD05TUGVyaW9kaWNE +ZWxheV1OU0J1dHRvbkZsYWdzEgQB/gCAO4AREBkQgYA6gDmAEoA2EMgSCAAAABP/////hoJA/1dDb252 +ZXJ0UQ3SADcAOAFJAUqkAUoAvABzADtcTlNCdXR0b25DZWxs0gA3ADgBTAFNpQFNAMAAwQDCADtYTlNC +dXR0b27cAFoBTwAOAVAAcgFRAFwBUgBYAVMBVABeAEwAUwFWAVcBWAFZAVoArABfAVwBXQBMWU5TQm94 +VHlwZVtOU1RpdGxlQ2VsbF1OU1RyYW5zcGFyZW50XE5TQm9yZGVyVHlwZVlOU09mZnNldHNfEA9OU1Rp +dGxlUG9zaXRpb26AC4BDgECAPggQDIAMgD8QAIALXxAUe3syMCwgNTh9LCB7MzEwLCA1fX1WezAsIDB9 +1wB/AA4AgACBAIIAhACGAToAiACJAWQAiwFdAWaAHYAVgEGAEoBCU0JveNMADgCfAKoAogCsAWqAGU0w +IDAuODAwMDAwMDEA0gA3ADgBbAFtpAFtAMEAwgA7VU5TQm940gA3ADgBbwFwowFwAXEAO15OU011dGFi +bGVBcnJheVdOU0FycmF5WnszNTAsIDE4OX3SADcAOAF0AMGjAMEAwgA7XxAWe3swLCAwfSwgezE5MjAs +IDExNzh9fdIANwA4AXcBeKIBeAA7XxAQTlNXaW5kb3dUZW1wbGF0ZdIANwA4AXoBe6MBewF8ADtcTlNN +dXRhYmxlU2V0VU5TU2V00gAOAD4AZwF/gESvEC0BgAGBAYIBgwGEAYUBhgGHAYgBiQGKAYsBjAGNAY4B +jwGQAZEBkgGTAZQBlQGWAZcBmAGZAZoBmwGcAZ0BngGfAaABoQGiAaMBpAGlAaYBpwGoAakBqgGrAayA +TIBZgF+AZIBqgHCAd4B5gHuAgICFgImAj4CUgJaAm4CfgKSAqYCugLCAtYC6gL6AwIDEgMiAzYDRgNaA +3IDhgOWA64DwgPSA+YD+gQECgQEHgQEJgQENgQEOgQETgQEY0wAOAa4BrwGwAbEBslhOU1NvdXJjZVdO +U0xhYmVsgFiATYBX2AAOAbQBtQG2AbcBuAG5AboBuwG8Ab0AigG/AcABwQHCV05TVGl0bGVfEBFOU0tl +eUVxdWl2TW9kTWFza1pOU0tleUVxdWl2XU5TTW5lbW9uaWNMb2NZTlNPbkltYWdlXE5TTWl4ZWRJbWFn +ZVZOU01lbnWAVoBPEgAQAACAERJ/////gFCAVIBO0wAOAbQBxAHFAcYBx1tOU01lbnVJdGVtc4EBIIEB +YIEBYl5TdGFydCBTcGVha2luZ9MADgAyAcoBywHMAc1eTlNSZXNvdXJjZU5hbWWAU4BRgFJXTlNJbWFn +ZV8QD05TTWVudUNoZWNrbWFya9IANwA4AdEB0qIB0gA7XxAQTlNDdXN0b21SZXNvdXJjZdMADgAyAcoB +ywHMAdaAU4BRgFVfEBBOU01lbnVNaXhlZFN0YXRl0gA3ADgB2QHaogHaADtaTlNNZW51SXRlbV5zdGFy +dFNwZWFraW5nOtIANwA4Ad0B3qMB3gHfADtfEBVOU05pYkNvbnRyb2xDb25uZWN0b3JeTlNOaWJDb25u +ZWN0b3LTAA4BrgGvAbAB4gHjgFiAWoBe2AAOAbQBtQG2AbcBuAG5AboBuwHmAb0B5wG/AcABwQHqgFaA +XIBdgFCAVIBb0wAOAbQBxAHFAe0B7oEBIIEBaYEBa1RTYXZlUXNdc2F2ZURvY3VtZW50OtMADgGuAa8B +sAH0AfWAWIBggGPYAA4BtAG1AbYBtwG4AbkBugG7AfgBvQCKAb8BwAHBAfyAVoBigBGAUIBUgGHUAA4B +tACTAcQBxQBPAgACAYEBIIAJgQFIgQE8WFNob3cgQWxsXxAWdW5oaWRlQWxsQXBwbGljYXRpb25zOtMA +DgGuAa8BsAIGAgeAWIBlgGnYAA4BtAG1AbYBtwG4AbkBugG7AgoCCwIMAb8BwAHBAg+AVoBnEgAYAACA +aIBQgFSAZtMADgG0AcQBxQISAhOBASCBASOBASRcU2hvdyBUb29sYmFyUXRfEBN0b2dnbGVUb29sYmFy +U2hvd2460wAOAa4BrwGwAhkCGoBYgGuAb9gADgG0AbUBtgG3AbgBuQG6AbsCHQG9Ah4BvwHAAcECIYBW +gG2AboBQgFSAbNMADgG0AcQBxQIkAiWBASCBAU6BAU9aU2VsZWN0IEFsbFFhWnNlbGVjdEFsbDrUAA4C +KgGuAa8CKwIsAi0CLl1OU0Rlc3RpbmF0aW9ugHaAc4BxgHXSAA4AMgAzAjGABIByXxATQ29udmVydGVy +Q29udHJvbGxlctIADgAyADMCNYAEgHRZQ29udmVydGVyWWNvbnZlcnRlctIANwA4AjkCOqMCOgHfADtf +EBROU05pYk91dGxldENvbm5lY3RvctQADgIqAa4BrwIrAGkCLQI/gHaADoBxgHhZcmF0ZUZpZWxk1AAO +AioBrgGvAisAawItAkWAdoAigHGAelthbW91bnRGaWVsZNMADgGuAa8BsAJJAkqAWIB8gH/YAA4BtAG1 +AbYBtwG4AbkBugG7Ak0BvQCKAb8BwAHBAlGAVoB+gBGAUIBUgH3UAA4BtACTAcQBxQJUAlUCVoEBIIEB +LYEBMYEBL1Rab29tXHBlcmZvcm1ab29tOtMADgGuAa8BsAJbAlyAWICBgITYAA4BtAG1AbYBtwG4AbkB +ugG7Al8BvQJgAb8BwAHBAiGAVoCCgIOAUIBUgGxVUGFzdGVRdlZwYXN0ZTrTAA4BrgGvAbACaQJqgFiA +hoCI1wAOAbQBtgG3AbgBuQG6AbsCbQCKAb8BwAHBAeqAVoCHgBGAUIBUgFtfEA9SZXZlcnQgdG8gU2F2 +ZWRfEBZyZXZlcnREb2N1bWVudFRvU2F2ZWQ60wAOAa4BrwGwAnYCd4BYgIqAjtkADgG0AbUBtgG3AbgB +uQG6AnkBuwJ7Ab0CfAG/AcABwQJ/AoBVTlNUYWeAVoCMgI2AUIBUgIsQAdMADgG0AcQBxQKDAoSBASCB +AVKBAVRlAEYAaQBuAGQgJlFmXxAXcGVyZm9ybUZpbmRQYW5lbEFjdGlvbjrTAA4BrgGvAbACigKLgFiA +kICT2AAOAbQBtQG2AbcBuAG5AboBuwKOAb0AigG/AcABwQKSgFaAkoARgFCAVICR1AAOAbQAkwHEAcUC +lQKWApeBASCBATOBATWBATRaQ2xlYXIgTWVudV8QFWNsZWFyUmVjZW50RG9jdW1lbnRzOtQADgIqAa4B +rwIrAGoAaQKegHaAH4AOgJVbbmV4dEtleVZpZXfTAA4BrgGvAbACogKjgFiAl4Ca2AAOAbQBtQG2AbcB +uAG5AboBuwKmAb0AigG/AcABwQKqgFaAmYARgFCAVICY0wAOAbQBxAHFAq0CroEBIIEBXIEBXl8QG0No +ZWNrIEdyYW1tYXIgV2l0aCBTcGVsbGluZ18QFnRvZ2dsZUdyYW1tYXJDaGVja2luZzrUAA4CKgGuAa8B +sAAfArQCtYBYgAKAnICe1wAOAbQBtgG3AbgBuQG6AbsCuACKAb8BwAHBAfyAVoCdgBGAUIBUgGFfEBhB +Ym91dCBDdXJyZW5jeSBDb252ZXJ0ZXJfEB1vcmRlckZyb250U3RhbmRhcmRBYm91dFBhbmVsOtMADgGu +Aa8BsALBAsKAWICggKPYAA4BtAG1AbYBtwG4AbkBugG7AsUCxgLHAb8BwAHBAiGAVoChEgASAACAooBQ +gFSAbFRSZWRvUVpVcmVkbzrTAA4BrgGvAbAC0ALRgFiApYCo2AAOAbQBtQG2AbcBuAG5AboBuwLUAb0C +1QG/AcABwQH8gFaApoCngFCAVIBhXxAXSGlkZSBDdXJyZW5jeSBDb252ZXJ0ZXJRaFVoaWRlOtMADgGu +Aa8BsALeAt+AWICqgK3YAA4BtAG2AbcBuAG5AboCeQG7AuIAigG/AcABwQLmAFOAVoCsgBGAUIBUgKvT +AA4BtAHEAcUC6QLqgQEggQEegQEfXFNtYXJ0IFF1b3Rlc18QIXRvZ2dsZUF1dG9tYXRpY1F1b3RlU3Vi +c3RpdHV0aW9uOtQADgIqAa4BrwIrAGkAQQLxgHaADoAHgK9fEBVpbml0aWFsRmlyc3RSZXNwb25kZXLT +AA4BrgGvAbAC9QL2gFiAsYC02AAOAbQBtQG2AbcBuAG5AboBuwL5Ab0C+gG/AcABwQKqgFaAsoCzgFCA +VICYXkNoZWNrIFNwZWxsaW5nUTteY2hlY2tTcGVsbGluZzrTAA4BrgGvAbADAwMEgFiAtoC52AAOAbQB +tQG2AbcBuAG5AboBuwMHAsYDCAG/AcABwQHqgFaAt4C4gFCAVIBbaABTAGEAdgBlACAAQQBzICZRU18Q +D3NhdmVEb2N1bWVudEFzOtMADgGuAa8BsAMRAxKAWIC7gL3YAA4BtAG2AbcBuAG5AboCeQG7AxUAigG/ +AcABwQLmAKyAVoC8gBGAUIBUgKtbU21hcnQgTGlua3NfEB10b2dnbGVBdXRvbWF0aWNMaW5rRGV0ZWN0 +aW9uOtQADgIqAa4BrwGwAi0AbwMggFiAcYA2gL9YY29udmVydDrTAA4BrgGvAbADJAMlgFiAwYDD2AAO +AbQBtQG2AbcBuAG5AboBuwMoAb0AigG/AcABwQJRgFaAwoARgFCAVIB9XxASQnJpbmcgQWxsIHRvIEZy +b250XxAPYXJyYW5nZUluRnJvbnQ60wAOAa4BrwGwAzEDMoBYgMWAx9gADgG0AbUBtgG3AbgBuQG6AbsD +NQG9AIoBvwHAAcECIYBWgMaAEYBQgFSAbFZEZWxldGVXZGVsZXRlOtMADgGuAa8BsAM+Az+AWIDJgMzY +AA4BtAG1AbYBtwG4AbkBugG7A0IBvQNDAb8BwAHBAeqAVoDKgMuAUIBUgFtmAFAAcgBpAG4AdCAmUXBW +cHJpbnQ60wAOAa4BrwGwA0wDTYBYgM6A0NgADgG0AbUBtgG3AbgBuQG6AbsDUAG9AIoBvwHAAcECD4BW +gM+AEYBQgFSAZm8QEgBDAHUAcwB0AG8AbQBpAHoAZQAgAFQAbwBvAGwAYgBhAHIgJl8QH3J1blRvb2xi +YXJDdXN0b21pemF0aW9uUGFsZXR0ZTrTAA4BrgGvAbADWQNagFiA0oDV2AAOAbQBtQG2AbcBuAG5AboB +uwNdAb0DXgG/AcABwQIhgFaA04DUgFCAVIBsVENvcHlRY1Vjb3B5OtMADgGuAa8BsANnA2iAWIDXgNvY +AA4BtAG1AbYBtwG4AbkBugG7A2sCxgNsAb8BwAHBA2+AVoDZgNqAUIBUgNjTAA4BtAHEAcUDcgNzgQEg +gQEngQEoW1Nob3cgQ29sb3JzUUNfEBVvcmRlckZyb250Q29sb3JQYW5lbDrTAA4BrgGvAbADeQN6gFiA +3YDg2AAOAbQBtQG2AbcBuAG5AboBuwN9Ab0DfgG/AcABwQJ/gFaA3oDfgFCAVICLXxARSnVtcCB0byBT +ZWxlY3Rpb25Ral8QHWNlbnRlclNlbGVjdGlvbkluVmlzaWJsZUFyZWE60wAOAa4BrwGwA4cDiIBYgOKA +5NgADgG0AbYBtwG4AbkBugJ5AbsDiwCKAb8BwAHBAuYCgIBWgOOAEYBQgFSAq18QEFNtYXJ0IENvcHkv +UGFzdGVfEBh0b2dnbGVTbWFydEluc2VydERlbGV0ZTrTAA4BrgGvAbADlAOVgFiA5oDq2AAOAbQBtQG2 +AbcBuAG5AboBuwOYAb0DmQG/AcABwQOcgFaA6IDpgFCAVIDn0wAOAbQBxAHFA58DoIEBIIEBIYEBIl8Q +F0N1cnJlbmN5IENvbnZlcnRlciBIZWxwUT9Zc2hvd0hlbHA60wAOAa4BrwGwA6YDp4BYgOyA79gADgG0 +AbUBtgG3AbgBuQG6AbsDqgG9A6sBvwHAAcECIYBWgO2A7oBQgFSAbFNDdXRReFRjdXQ60wAOAa4BrwGw +A7QDtYBYgPGA89gADgG0AbUBtgG3AbgBuQG6AbsDuAG9AIoBvwHAAcECqoBWgPKAEYBQgFSAmF8QG0No +ZWNrIFNwZWxsaW5nIFdoaWxlIFR5cGluZ18QHnRvZ2dsZUNvbnRpbnVvdXNTcGVsbENoZWNraW5nOtMA +DgGuAa8BsAPBA8KAWID1gPjYAA4BtAG1AbYBtwG4AbkBugG7A8UBvQPGAb8BwAHBAlGAVoD2gPeAUIBU +gH1YTWluaW1pemVRbV8QE3BlcmZvcm1NaW5pYXR1cml6ZTrTAA4BrgGvAbADzwPQgFiA+oD92AAOAbQB +tQG2AbcBuAG5AboBuwPTAb0D1AG/AcABwQIhgFaA+4D8gFCAVIBsVFVuZG9RelV1bmRvOtMADgGuAa8B +sAPdA96AWID/gQEB2AAOAbQBtQG2AbcBuAG5AboBuwPhAb0AigG/AcABwQHCgFaBAQCAEYBQgFSATl1T +dG9wIFNwZWFraW5nXXN0b3BTcGVha2luZzrTAA4BrgGvAbAD6gPrgFiBAQOBAQbYAA4BtAG1AbYBtwG4 +AbkBugG7A+4BvQPvAb8BwAHBAeqAVoEBBIEBBYBQgFSAW1VDbG9zZVF3XXBlcmZvcm1DbG9zZTrUAA4C +KgGuAa8CKwBqAi0D+oB2gB+AcYEBCFtkb2xsYXJGaWVsZNMADgGuAa8BsAP+A/+AWIEBCoEBDNgADgG0 +AbUBtgG3AbgBuQG6AbsEAgILAtUBvwHAAcEB/IBWgQELgKeAUIBUgGFbSGlkZSBPdGhlcnNfEBZoaWRl +T3RoZXJBcHBsaWNhdGlvbnM61AAOAioBrgGvAisAaQBqAp6AdoAOgB+AldMADgGuAa8BsAQQBBGAWIEB +D4EBEtgADgG0AbUBtgG3AbgBuQG6AbsEFAG9BBUBvwHAAcECqoBWgQEQgQERgFCAVICYbgBTAGgAbwB3 +ACAAUwBwAGUAbABsAGkAbgBnICZROl8QD3Nob3dHdWVzc1BhbmVsOtMADgGuAa8BsAQeBB+AWIEBFIEB +F9kADgQhAbQBtQG2AbcBuAG5AboBuwCKBCQCxgQlAb8BwAHBAepZTlNUb29sVGlwgFaAEYEBFYEBFoBQ +gFSAW11QYWdlIFNldHVwLi4uUVBecnVuUGFnZUxheW91dDrTAA4BrgGvAbAELgQvgFiBARmBARzYAA4B +tAG1AbYBtwG4AbkBugG7BDIBvQQzAb8BwAHBAfyAVoEBGoEBG4BQgFSAYV8QF1F1aXQgQ3VycmVuY3kg +Q29udmVydGVyUXFadGVybWluYXRlOtIADgA+BDsEPIEBea8QZALmA5wD6gPdA1kCDwRDAqIDhwRGA28E +SARJA2cCkgLQBB4ETgPPAkkCigJbAQwELgGxAgYDAwJ2BFkEWgRbBFwC3gHiBF8CIQLBBGIEEAO0AHAC +LQRnAG8EaQKqA3kAeAMRArQAbARwBHEB/ARzAEwB9AR2A5QDPgNMBHoEewDYAcICfwR/AvUAaQSCBIMA +agDqAyQDwQJpAS4AawSLBIwAbgP+BI8EkABBBJICUQOmBJUElgDHAhkB6gMxBJsBHQBtAiwEnwSggKuA +54EBA4D/gNKAZoEBJYCXgOKBASaA2IEBK4EBMoDXgJGApYEBFIEBNoD6gHyAkICBgDCBARmATYBlgLaA +ioEBN4EBOYEBOoEBSYCqgFqBAUyAbICggQFjgQEPgPGAPYBxgQFQgDaBASmAmIDdgBCAu4CcgCWBAUGB +AVWAYYEBZoALgGCBAUSA5oDJgM6BAWiBAVGAJIBOgIuBAXKAsYAOgQEsgQE9gB+AJ4DBgPWAhoA4gCKB +AWyBAW+AMoEBCoEBcYEBPoAHgQF2gH2A7IEBWIEBMIAhgGuAW4DFgQFfgDSALoBzgQFHgQFbXVN1YnN0 +aXR1dGlvbnPSAA4APgBnBKSARKMDhwLeAxGA4oCqgLvSADcAOASpAbqiAboAO1RIZWxw0gAOAD4AZwSt +gEShA5SA5lRWaWV30gAOAD4AZwSygESiAgYDTIBlgM7aAA4BtAG1BLYBtgS3AbcBuAG5AboBuwCKAb0A +egCKAHoBvwHAAcEB/F1OU0lzU2VwYXJhdG9yXE5TSXNEaXNhYmxlZIBWgBEJgBEJgFCAVIBh2gAOAbQB +tQS2AbYEtwG3AbgBuQG6AbsAigG9AHoAigB6Ab8BwAHBAiGAVoARCYARCYBQgFSAbFZGb3JtYXTSAA4A +PgBnBMyARKIEaQNngQEpgNfYAA4BtAG1AbYBtwG4AbkBugG7BNEBvQIMAb8BwAHBA2+AVoEBKoBogFCA +VIDYWlNob3cgRm9udHPaAA4E2AG0AbUBtgG3AbgBuQG6BNkBuwJRAlQBvQCKAb8BwAHBBIIE4VlOU1N1 +Ym1lbnVYTlNBY3Rpb26AVoB9gQEtgBGAUIBUgQEsgQEu1AAOAbQAkwHEAcUE5ATlBOaBASCBAXSBAXiB +AXVWV2luZG93XnN1Ym1lbnVBY3Rpb2460gAOAD4AZwTrgESkA8ECSQSWAySA9YB8gQEwgMHaAA4BtAG1 +BLYBtgS3AbcBuAG5AboBuwCKAb0AegCKAHoBvwHAAcECUYBWgBEJgBEJgFCAVIB9Xl9OU1dpbmRvd3NN +ZW512gAOAbQBtQS2AbYEtwG3AbgBuQG6AbsAigG9AHoAigB6Ab8BwAHBAeqAVoARCYARCYBQgFSAW1tP +cGVuIFJlY2VudNIADgA+AGcFBoBEoQKKgJBfEBZfTlNSZWNlbnREb2N1bWVudHNNZW512gAOAbQBtQS2 +AbYEtwG3AbgBuQG6AbsAigG9AHoAigB6Ab8BwAHBAfyAVoARCYARCYBQgFSAYdoADgTYAbQBtQG2AbcB +uAG5AboE2QG7AuYC6QG9AIoBvwHAAcECIQUagFaAq4EBHoARgFCAVIBsgQE40gAOADIAMwA0gASAA9oA +DgTYAbQBtQG2AbcBuAG5AboE2QG7AfwATwG9AIoBvwHAAcEEggUmgFaAYYAJgBGAUIBUgQEsgQE70gAO +AD4AZwUpgESrArQEgwSQBE4EcASfAtAD/gH0BEMELoCcgQE9gQE+gQE2gQFBgQFHgKWBAQqAYIEBJYEB +GdoADgG0AbUEtgG2BLcBtwG4AbkBugG7AIoBvQB6AIoAegG/AcABwQH8gFaAEQmAEQmAUIBUgGHYAA4B +tAG1AbYBtwG4AbkBugG7BUABvQVBAb8BwAHBAfyAVoEBP4EBQIBQgFSAYWwAUAByAGUAZgBlAHIAZQBu +AGMAZQBzICZRLNoADgTYAbQBtQG2AbcBuAG5AboE2QG7BHYFSgG9AIoBvwHAAcEB/AVPgFaBAUSBAUKA +EYBQgFSAYYEBQ1hTZXJ2aWNlc9QADgG0AJMBxAHFBUoFVAVVgQEggQFCgQFGgQFF0gAOAD4AZwVYgESg +XxAPX05TU2VydmljZXNNZW512gAOAbQBtQS2AbYEtwG3AbgBuQG6AbsAigG9AHoAigB6Ab8BwAHBAfyA +VoARCYARCYBQgFSAYVxfTlNBcHBsZU1lbnXZAA4BtAG1AbYBtwG4AbkBugJ5AbsFZgG9BWcBvwHAAcEC +fwBUgFaBAUqBAUuAUIBUgItfEBZVc2UgU2VsZWN0aW9uIGZvciBGaW5kUWXaAA4E2AG0AbUBtgG3AbgB +uQG6BNkBuwNvA3IBvQCKAb8BwAHBBIIFdYBWgNiBASeAEYBQgFSBASyBAU1URWRpdNIADgA+AGcFeYBE +rQPPAsEERgOmA1kCWwMxAhkEZwR7BKAEWQSbgPqAoIEBJoDsgNKAgYDFgGuBAVCBAVGBAVuBATeBAV/a +AA4BtAG1BLYBtgS3AbcBuAG5AboBuwCKAb0AegCKAHoBvwHAAcECIYBWgBEJgBEJgFCAVIBs2gAOBNgB +tAG1AbYBtwG4AbkBugTZAbsCfwKDAb0AigG/AcABwQIhBZiAVoCLgQFSgBGAUIBUgGyBAVNURmluZNIA +DgA+AGcFnIBEpQJ2BHEElQRcA3mAioEBVYEBWIEBSYDd2QAOAbQBtQG2AbcBuAG5AboCeQG7BaQBvQWl +Ab8BwAHBAn8AU4BWgQFWgQFXgFCAVICLWUZpbmQgTmV4dFFn2QAOAbQBtQG2AbcBuAG5AboCeQG7Ba0C +xgWuAb8BwAHBAn8ArIBWgQFZgQFagFCAVICLXUZpbmQgUHJldmlvdXNRR9oADgTYAbQBtQG2AbcBuAG5 +AboE2QG7AqoCrQG9AIoBvwHAAcECIQW8gFaAmIEBXIARgFCAVIBsgQFdXxAUU3BlbGxpbmcgYW5kIEdy +YW1tYXLSAA4APgBnBcCARKQEEAL1A7QCooEBD4CxgPGAl9oADgTYAbQBtQG2AbcBuAG5AboE2QG7AcIB +xgG9AIoBvwHAAcECIQXNgFaAToEBYIARgFCAVIBsgQFhVlNwZWVjaNIADgA+AGcF0YBEogGxA92ATYD/ +2AAOAbQBtQG2AbcBuAG5AboBuwXWAb0F1wG/AcABwQHqgFaBAWSBAWWAUIBUgFtTTmV3UW7aAA4E2AG0 +AbUBtgG3AbgBuQG6BNkBuwIPAhIBvQCKAb8BwAHBBIIF5YBWgGaBASOAEYBQgFSBASyBAWfaAA4E2AG0 +AbUBtgG3AbgBuQG6BNkBuwHqAe0BvQCKAb8BwAHBBIIF7oBWgFuBAWmAEYBQgFSBASyBAWpURmlsZdIA +DgA+AGcF8oBEqwRiBIsEjARJA+oB4gMDAmkEjwQeAz6BAWOBAWyBAW+BATKBAQOAWoC2gIaBAXGBARSA +ydgADgG0AbUBtgG3AbgBuQG6AbsGAAG9BgEBvwHAAcEB6oBWgQFtgQFugFCAVIBbZQBPAHAAZQBuICZR +b9oADgTYAbQBtQG2AbcBuAG5AboE2QG7ApIClQG9AIoBvwHAAcEB6gYPgFaAkYEBM4ARgFCAVIBbgQFw +2gAOAbQBtQS2AbYEtwG3AbgBuQG6AbsAigG9AHoAigB6Ab8BwAHBAeqAVoARCYARCYBQgFSAW9oADgTY +AbQBtQG2AbcBuAG5AboE2QG7AiECJAG9AIoBvwHAAcEEggYhgFaAbIEBToARgFCAVIEBLIEBc1lBTWFp +bk1lbnXSAA4APgBnBiWARKcEWwR6BH8EXwRzBEgEkoEBOoEBaIEBcoEBTIEBZoEBK4EBdtoADgTYAbQB +tQG2AbcBuAG5AboE2QG7A5wDnwG9AIoBvwHAAcEEggY1gFaA54EBIYARgFCAVIEBLIEBd1tfTlNNYWlu +TWVuddIANwA4BjgBcaIBcQA70gAOAD4EOwY7gQF5rxBkBFkEkgHqAcICIQRzAfwCqgLmAiEEXwSCAeoD +bwSMAfwB6gH8AiECUQKSAiEAbQH8AcICDwHqAn8CIQAfBIICfwLmAeoEggR/AiEB6gKqAqoATAAfAiEA +TANvBKACfwBpAuYB/ABMAfwCfwRbBIIAQQH8BHADnAHqAg8EggIhAGsEmwR7BIICqgBMAB8B/ABMAGwC +UQJRAeoAbwBMAeoB6gBMAfwB6gH8AB8EggRIAiECfwJRAGoCIQR6AiECIQBuAEwAHwH8AiGBATeBAXaA +W4BOgGyBAWaAYYCYgKuAbIEBTIEBLIBbgNiBAW+AYYBbgGGAbIB9gJGAbIAugGGAToBmgFuAi4BsgAKB +ASyAi4CrgFuBASyBAXKAbIBbgJiAmIALgAKAbIALgNiBAVuAi4AOgKuAYYALgGGAi4EBOoEBLIAHgGGB +AUGA54BbgGaBASyAbIAigQFfgQFRgQEsgJiAC4ACgGGAC4AlgH2AfYBbgDaAC4BbgFuAC4BhgFuAYYAC +gQEsgQErgGyAi4B9gB+AbIEBaIBsgGyAMoALgAKAYYBs0gAOAD4EOwaigQF5rxBlAuYDnAPqA90CDwNZ +BEMCogOHBEYDbwRIBEkDZwKSAtAEHgROA88CSQKKAlsBDAQuAbECBgMDAnYEWQRaBFsEXwHiAt4EXAIh +BGICwQQQA7QCLQBwBGcAbwRpAqoDeQB4AxEAbAK0BHAEcwH8BHEATAH0A5QEdgM+A0wEegR7ANgBwgJ/ +BH8C9QBpBIIAagSDAOoDJAPBAmkBLgBrBIsEjABuA/4EjwSQAEEEkgJRA6YAHwSVBJYAxwIZAeoDMQSb +AR0AbQIsBJ8EoICrgOeBAQOA/4BmgNKBASWAl4DigQEmgNiBASuBATKA14CRgKWBARSBATaA+oB8gJCA +gYAwgQEZgE2AZYC2gIqBATeBATmBATqBAUyAWoCqgQFJgGyBAWOAoIEBD4DxgHGAPYEBUIA2gQEpgJiA +3YAQgLuAJYCcgQFBgQFmgGGBAVWAC4BggOaBAUSAyYDOgQFogQFRgCSAToCLgQFygLGADoEBLIAfgQE9 +gCeAwYD1gIaAOIAigQFsgQFvgDKBAQqBAXGBAT6AB4EBdoB9gOyAAoEBWIEBMIAhgGuAW4DFgQFfgDSA +LoBzgQFHgQFb0gAOAD4EOwcKgQF5rxBlBwsHDAcNBw4HDwcQBxEHEgcTBxQHFQcWBxcHGAcZBxoHGwcc +Bx0HHgcfByAHIQciByMHJAclByYHJwcoBykHKgcrBywHLQcuBy8HMAcxBzIHMwc0BzUHNgc3BzgHOQc6 +BzsHPAc9Bz4HPwdAB0EHQgdDB0QHRQdGB0cHSAdJB0oHSwdMB00HTgdPB1AHUQdSB1MHVAdVB1YHVwdY +B1kHWgdbB1wHXQdeB18HYAdhB2IHYwdkB2UHZgdnB2gHaQdqB2sHbAdtB24Hb4EBfYEBfoEBf4EBgIEB +gYEBgoEBg4EBhIEBhYEBhoEBh4EBiIEBiYEBioEBi4EBjIEBjYEBjoEBj4EBkIEBkYEBkoEBk4EBlIEB +lYEBloEBl4EBmIEBmYEBmoEBm4EBnIEBnYEBnoEBn4EBoIEBoYEBooEBo4EBpIEBpYEBpoEBp4EBqIEB +qYEBqoEBq4EBrIEBrYEBroEBr4EBsIEBsYEBsoEBs4EBtIEBtYEBtoEBt4EBuIEBuYEBuoEBu4EBvIEB +vYEBvoEBv4EBwIEBwYEBwoEBw4EBxIEBxYEBxoEBx4EByIEByYEByoEBy4EBzIEBzYEBzoEBz4EB0IEB +0YEB0oEB04EB1IEB1YEB1oEB14EB2IEB2YEB2oEB24EB3IEB3YEB3oEB34EB4IEB4V8QFE1lbnUgKFN1 +YnN0aXR1dGlvbnMpUTJTMS0xXxAZTWVudSBJdGVtIChTdG9wIFNwZWFraW5nKVtNZW51IChWaWV3KV8Q +EE1lbnUgSXRlbSAoQ29weSlbU2VwYXJhdG9yLTFfECdNZW51IEl0ZW0gKENoZWNrIEdyYW1tYXIgV2l0 +aCBTcGVsbGluZylfEBxNZW51IEl0ZW0gKFNtYXJ0IENvcHkvUGFzdGUpW1NlcGFyYXRvci01XU1lbnUg +KEZvcm1hdClfEBJNZW51IEl0ZW0gKFdpbmRvdylRN18QF01lbnUgSXRlbSAoU2hvdyBDb2xvcnMpXxAS +TWVudSAoT3BlbiBSZWNlbnQpXxAjTWVudSBJdGVtIChIaWRlIEN1cnJlbmN5IENvbnZlcnRlcilRNVtT +ZXBhcmF0b3ItMl8QEE1lbnUgSXRlbSAoVW5kbylfEBBNZW51IEl0ZW0gKFpvb20pXxAWTWVudSBJdGVt +IChDbGVhciBNZW51KV8QEU1lbnUgSXRlbSAoUGFzdGUpXxAlVGV4dCBGaWVsZCBDZWxsIChEb2xsYXJz +IHRvIENvbnZlcnQ6KVQxMTExXxAaTWVudSBJdGVtIChTdGFydCBTcGVha2luZylfEBhNZW51IEl0ZW0g +KFNob3cgVG9vbGJhcilROG8QEQBNAGUAbgB1ACAASQB0AGUAbQAgACgARgBpAG4AZCAmAClfEBlNZW51 +IEl0ZW0gKFN1YnN0aXR1dGlvbnMpW0FwcGxpY2F0aW9uXxAeTWVudSBJdGVtIChDdXJyZW5jeSBDb252 +ZXJ0ZXIpXxASTWVudSBJdGVtIChGb3JtYXQpUTNfEBhNZW51IEl0ZW0gKFNtYXJ0IFF1b3RlcylfECJN +ZW51IEl0ZW0gKFVzZSBTZWxlY3Rpb24gZm9yIEZpbmQpW01lbnUgKEVkaXQpUTlfEBBNZW51IEl0ZW0g +KFJlZG8pbxAaAE0AZQBuAHUAIABJAHQAZQBtACAAKABTAGgAbwB3ACAAUwBwAGUAbABsAGkAbgBnICYA +KV8QJ01lbnUgSXRlbSAoQ2hlY2sgU3BlbGxpbmcgV2hpbGUgVHlwaW5nKV8QFENvbnZlcnRlciBDb250 +cm9sbGVyXxAPSG9yaXpvbnRhbCBMaW5lW1NlcGFyYXRvci02XxAVUHVzaCBCdXR0b24gKENvbnZlcnQp +XxAWTWVudSBJdGVtIChTaG93IEZvbnRzKV8QG01lbnUgKFNwZWxsaW5nIGFuZCBHcmFtbWFyKV8QHU1l +bnUgSXRlbSAoSnVtcCB0byBTZWxlY3Rpb24pXxAPVGV4dCBGaWVsZCBDZWxsXxAXTWVudSBJdGVtIChT +bWFydCBMaW5rcylfECNTdGF0aWMgVGV4dCAoRXhjaGFuZ2UgcmF0ZSBwZXIgJDE6KV8QJE1lbnUgSXRl +bSAoQWJvdXQgQ3VycmVuY3kgQ29udmVydGVyKV8QFE1lbnUgSXRlbSAoU2VydmljZXMpXxAQTWVudSBJ +dGVtIChWaWV3KV8QGU1lbnUgKEN1cnJlbmN5IENvbnZlcnRlcilfEBVNZW51IEl0ZW0gKEZpbmQgTmV4 +dClcQ29udGVudCBWaWV3XxAUTWVudSBJdGVtIChTaG93IEFsbClfECNNZW51IEl0ZW0gKEN1cnJlbmN5 +IENvbnZlcnRlciBIZWxwKV8QD01lbnUgKFNlcnZpY2VzKVE2bxAeAE0AZQBuAHUAIABJAHQAZQBtACAA +KABDAHUAcwB0AG8AbQBpAHoAZQAgAFQAbwBvAGwAYgBhAHIgJgApXxAQTWVudSBJdGVtIChGaWxlKV8Q +EE1lbnUgSXRlbSAoRmluZClfEBFUZXh0IEZpZWxkIENlbGwtMl1NZW51IChTcGVlY2gpW01lbnUgKEZp +bmQpXxAQTWVudSBJdGVtIChFZGl0KV8QGk1lbnUgSXRlbSAoQ2hlY2sgU3BlbGxpbmcpWlRleHQgRmll +bGRYTWFpbk1lbnVcVGV4dCBGaWVsZC0xW1NlcGFyYXRvci0zXxAnVGV4dCBGaWVsZCBDZWxsIChFeGNo +YW5nZSByYXRlIHBlciAkMTopXxAeTWVudSBJdGVtIChCcmluZyBBbGwgdG8gRnJvbnQpXxAUTWVudSBJ +dGVtIChNaW5pbWl6ZSlSMTBfEBVCdXR0b24gQ2VsbCAoQ29udmVydClcVGV4dCBGaWVsZC0ybxARAE0A +ZQBuAHUAIABJAHQAZQBtACAAKABPAHAAZQBuICYAKV8QF01lbnUgSXRlbSAoT3BlbiBSZWNlbnQpXxAn +U3RhdGljIFRleHQgKEFtb3VudCBpbiBvdGhlciBDdXJyZW5jeTopXxAXTWVudSBJdGVtIChIaWRlIE90 +aGVycylTMi0xUzEyMV8QG1dpbmRvdyAoQ3VycmVuY3kgQ29udmVydGVyKVExXU1lbnUgKFdpbmRvdylf +EA9NZW51IEl0ZW0gKEN1dClcRmlsZSdzIE93bmVyXxAZTWVudSBJdGVtIChGaW5kIFByZXZpb3VzKVlT +ZXBhcmF0b3JfEBFUZXh0IEZpZWxkIENlbGwtMV8QFk1lbnUgSXRlbSAoU2VsZWN0IEFsbClbTWVudSAo +RmlsZSlfEBJNZW51IEl0ZW0gKERlbGV0ZSlfEBJNZW51IEl0ZW0gKFNwZWVjaClfECtUZXh0IEZpZWxk +IENlbGwgKEFtb3VudCBpbiBvdGhlciBDdXJyZW5jeTopXxAhU3RhdGljIFRleHQgKERvbGxhcnMgdG8g +Q29udmVydDopW1NlcGFyYXRvci00XxAgTWVudSBJdGVtIChTcGVsbGluZyBhbmQgR3JhbW1hcinSAA4A +PgQ7B9aBAXmg0gAOAD4EOwfZgQF5oNIADgA+BDsH3IEBea8QkgLmAYwDnAPqAZMD3QGZA1kCDwRDAqID +hwGpBEYBowNvBEgESQGhA2cCkgLQBB4ETgGbAYoBjgGiA88BqgGYAkkCigJbAQwELgGxAgYDAwJ2BFkE +WgRbBFwC3gHiBF8BgwGVAaUBkQIhAaYCwQRiBBABoAO0AHACLQRnAG8EaQKqAYIBkgN5AZAAeAMRArQA +bAGIBHAEcQH8BHMATAGUAfQEdgOUAz4BnQGeA0wEegGABHsA2AGrAYUBwgJ/AaQBrAR/AvUBjwBpBIIE +gwBqAOoBnAGfAyQDwQJpAYsBLgBrBIsEjABuA/4EjwGEBJAAQQSSAZoBhgJRAYcBlgOmAB8ElQGNAYkE +lgDHAhkB6gGoAYEDMQSbAR0AbQIsAZcBpwSfBKCAq4CPgOeBAQOAroD/gMSA0oBmgQElgJeA4oEBDYEB +JoD0gNiBASuBATKA64DXgJGApYEBFIEBNoDNgIWAloDwgPqBAQ6AwIB8gJCAgYAwgQEZgE2AZYC2gIqB +ATeBATmBATqBAUmAqoBagQFMgGSAtYD+gKSAbIEBAoCggQFjgQEPgOWA8YA9gHGBAVCANoEBKYCYgF+A +qYDdgJ+AEIC7gJyAJYB7gQFBgQFVgGGBAWaAC4CwgGCBAUSA5oDJgNaA3IDOgQFogEyBAVGAJIEBE4Bw +gE6Ai4D5gQEYgQFygLGAm4AOgQEsgQE9gB+AJ4DRgOGAwYD1gIaAiYA4gCKBAWyBAW+AMoEBCoEBcYBq +gQE+gAeBAXaAyIB3gH2AeYC6gOyAAoEBWICUgICBATCAIYBrgFuBAQmAWYDFgQFfgDSALoBzgL6BAQeB +AUeBAVvSAA4APgQ7CHGBAXmvEJIIcghzCHQIdQh2CHcIeAh5CHoIewh8CH0Ifgh/CIAIgQiCCIMIhAiF +CIYIhwiICIkIigiLCIwIjQiOCI8IkAiRCJIIkwiUCJUIlgiXCJgImQiaCJsInAidCJ4InwigCKEIogij +CKQIpQimCKcIqAipCKoIqwisCK0IrgivCLAIsQiyCLMItAi1CLYItwi4CLkIugi7CLwIvQi+CL8IwAjB +CMIIwwjECMUIxgjHCMgIyQjKCMsIzAjNCM4IzwjQCNEI0gjTCNQI1QjWCNcI2AjZCNoI2wjcCN0I3gjf +COAI4QjiCOMI5AjlCOYI5wjoCOkI6gjrCOwI7QjuCO8I8AjxCPII8wj0CPUI9gj3CPgI+Qj6CPsI/Aj9 +CP4I/wkACQEJAgkDgQHmgQHngQHogQHpgQHqgQHrgQHsgQHtgQHugQHvgQHwgQHxgQHygQHzgQH0gQH1 +gQH2gQH3gQH4gQH5gQH6gQH7gQH8gQH9gQH+gQH/gQIAgQIBgQICgQIDgQIEgQIFgQIGgQIHgQIIgQIJ +gQIKgQILgQIMgQINgQIOgQIPgQIQgQIRgQISgQITgQIUgQIVgQIWgQIXgQIYgQIZgQIagQIbgQIcgQId +gQIegQIfgQIggQIhgQIigQIjgQIkgQIlgQImgQIngQIogQIpgQIqgQIrgQIsgQItgQIugQIvgQIwgQIx +gQIygQIzgQI0gQI1gQI2gQI3gQI4gQI5gQI6gQI7gQI8gQI9gQI+gQI/gQJAgQJBgQJCgQJDgQJEgQJF +gQJGgQJHgQJIgQJJgQJKgQJLgQJMgQJNgQJOgQJPgQJQgQJRgQJSgQJTgQJUgQJVgQJWgQJXgQJYgQJZ +gQJagQJbgQJcgQJdgQJegQJfgQJggQJhgQJigQJjgQJkgQJlgQJmgQJngQJogQJpgQJqgQJrgQJsgQJt +gQJugQJvgQJwgQJxgQJygQJzgQJ0gQJ1gQJ2gQJ3EQFdEH8QahBJEQGIEMMQ6xDFEQEoEJURAVoRAV4R +AYcQzhAlEQEsEBMQTxDkEQFZEH0QhhBNEI8RAW0RAWwRAVsQ3hDPEOYQJxDvEH4QyxEBfhCIEMQRASkQ +UBDREQFcE//////////9EDgQ3REBXxBLEQErEQFuEQFrEOMRAXEQzRDBENcQUhDMEQFoENsRAYURAYsQ +1hEBgREBWBEBdBEBZBDSEOcRAXYRAWIQOhEBexDwEIMQ0BA5EQEnEQFwEOEQlhCCEG8QThEBaRD1EQEq +EFMQ6RDaEQF6EFcRAY8Q1BDcEN8RAXMQ2RDJEI4RAXUQHRDsEQF3EQF8EOARAWMQBRAXEHAQ8REBghEB +eRBIEHwRAX8QkRBKEOgRAW8QZxBWEQGMEBgRAY4RAWUQxxEBkRDVEQGGEOIQXBEBeBDGEFERAXIRAWoQ +yhDTEQGAEQF9EQGKEQGQEQGNEJAQ2NIADgA+AGcJloBEoNIADgA+BDsJmYEBeaDSAA4APgQ7CZyBAXmg +0gA3ADgJngmfogmfADteTlNJQk9iamVjdERhdGEACAAZACIAJwAxADoAPwBEAFIAVABmBWIFaAWzBboF +wQXPBeEF/QYLBhcGIwYxBjwGSgZmBnQGhwaZBrMGvQbKBswGzwbSBtUG2AbaBt0G3wbiBuUG6AbrBu0G +7wbyBvUG+Ab7BwQHEAcSBxQHIgcrBzQHPwdEB1MHXAdvB3gHgweFB4gHigezB8AHzQfbB+UH8wgACBII +JggyCDQINgg4CDoIPwhBCEMIRQhHCEkIZAh5CIIInwixCLwIxQjRCN0I3wjhCOMI5gjoCOoI7Aj1CPcJ +CAkKCQwJDgkQCRIJFAkWCRgJOQlBCUgJUglUCVYJWAlaCV0JXglgCWIJfAmhCa0JwQnMCdYJ5AnxCgUK +EQoaChwKHgogCiIKJAopCioKLAotCj4KRQpMClUKVwpgCmIKZQpyCnsKgAqHCpwKpAqxCr0KywrNCs8K +0QrTCtUK3AryCv8LBwsJCwsLDgsXCxwLMQszCzULNws5C0MLUAtSC1ULXgtnC3kLhguPC5oLpguwC7cL +wwvkC+YL6AvqC+wL7QvvC/EMCwwwDDIMNAw2DDgMOgw7DD0MXgxgDGIMZAxmDGcMaQxrDIQMqQyyDLQM +tgy4DLoMvAy9DL8M4AziDOQM5gzoDOkM6wztDQYNJw0sDS4NMA0yDTQNNg07DT0NVQ1qDWwNbg1wDXIN +fw2MDY4Nmg2vDbENsw21DbcNyg3rDe0N7w3xDfMN9A32DfgOEQ4yDjQONg44DjoOPA4+DlQOdQ53DnkO +ew59Dn4OgA6CDpoOuw69Dr8OwQ7DDsUOxw7jDwQPBg8IDwoPDA8NDw8PEQ8pD1oPcA+FD5QPpg+4D8YP +yw/ND88P0Q/TD9UP1w/ZD9sP3Q/iD+sP8w/1D/4QBxAUEB0QKBAxEGIQbBB4EIYQkxCdEK8QsRCzELUQ +txC4ELoQvBC+EMAQwhDZEOAQ/RD/EQERAxEFEQcRCxEYERoRKBExEToRQBFJEVARXxFnEXIRexGCEZsR +pBGpEbwRxRHMEdkR3xHoEeoSRxJJEksSTRJPElESUxJVElcSWRJbEl0SXxJhEmMSZRJnEmkSaxJtEm8S +cRJzEnUSdxJ5EnsSfRJ/EoESgxKFEocSiRKLEo0SjxKREpMSlhKZEpwSnxKiEqUSqBK1Er4SxhLIEsoS +zBLtEvUTCRMUEyITLBM5E0ATQhNEE0kTSxNQE1ITVBNWE2MTbxNyE3UTeBOHE5QToxOlE6cTqROxE8MT +zBPRE+QT8RPzE/UT9xQKFBMUGBQjFDIUOxRCFFoUaRR2FHgUehR8FJ0UnxShFKMUpRSnFKkUthS5FLwU +vxTEFMYU1BThFOMU5RTnFQgVChUMFQ4VEBUSFRQVJRUoFSoVLRUwFTkVUhVfFWEVYxVlFYYViBWKFY8V +kRWTFZUVlxWkFacVqhWtFboVvBXSFd8V4RXjFeUWBhYIFgoWDBYOFhAWEhYfFiIWJRYoFjMWNRZAFlEW +XxZhFmMWZRZnFnAWchZ0FooWkxaVFpcWoRarFrQWuxbSFuMW5RbnFukW6xb1FwYXCBcKFwwXDhcaFycX +KRcrFy0XThdQF1IXVBdWF1gXWhdrF24XcRd0F3cXfBeJF5YXmBeaF5wXvRe/F8EXwxfFF8cXyRfPF9EX +2BflF+cX6RfrGAgYChgMGA4YEBgSGBQYJhg/GEwYThhQGFIYdxh9GH8YgRiDGIUYhxiJGIsYmBibGJ4Y +oRisGK4YyBjVGNcY2RjbGPwY/hkAGQIZBBkGGQgZGRkcGR8ZIhklGTAZSBlZGVsZXRlfGWEZbRl6GXwZ +fhmAGaEZoxmlGacZqRmrGa0Zuhm9GcAZwxnhGfoaCxoNGg8aERoTGjAaMho0GjYaOBo6GjwaVxp3GoQa +hhqIGooaqxqtGq8atBq2Grgauhq8GsEawxrJGtYa2BraGtwa/Rr/GwEbAxsFGwcbCRsjGyUbKxs4Gzob +PBs+G18bYRtjG2UbZxtpG2sbeBt7G34bgRuOG7IbwxvFG8cbyRvLG+Mb8BvyG/Qb9hwXHBkcGxwdHB8c +IRwjHDIcNBxDHFAcUhxUHFYcdxx5HHscfRx/HIEcgxyUHJYcqBy1HLccuRy7HNwc3hzgHOIc5BzmHOgc +9B0UHSUdJx0pHSsdLR02HUMdRR1HHUkdah1sHW4dcB1yHXQddh2LHZ0dqh2sHa4dsB3RHdMd1R3XHdkd +2x3dHeQd7B35Hfsd/R3/HiAeIh4kHiYeKB4qHiweOR47HkIeTx5RHlMeVR52Hngeeh58Hn4egB6CHqke +yx7YHtoe3B7eHv8fAR8DHwUfBx8JHwsfEB8SHxgfJR8nHykfKx9MH04fUB9SH1QfVh9YH2UfaB9rH24f +eh98H5QfoR+jH6Ufpx/IH8ofzB/OH9Af0h/UH+gf6iAKIBcgGSAbIB0gPiBAIEIgRCBGIEggSiBdIHgg +hSCHIIkgiyCsIK4gsCCyILQgtiC4IMUgyCDLIM4g6CDqIPQhASEDIQUhByEoISohLCEuITAhMiE0ITgh +OiE/IUwhTiFQIVIhcyF1IXcheSF7IX0hfyGdIb4hyyHNIc8h0SHyIfQh9iH4Ifoh/CH+IgciCSIfIiwi +LiIwIjIiUyJVIlciWSJbIl0iXyJkImYibCJ5InsifSKAIqEioyKmIqgiqiKsIq4ivCLKItci2SLcIt8j +ACMCIwUjCCMKIwwjDiMUIxYjJCM1IzcjOSM7Iz4jSiNXI1kjXCNfI4AjgiOFI4cjiSOLI40jmSOyI8Mj +xSPHI8kjyyPYI9oj3SPgJAEkAyQGJAkkCyQNJA8kLCQuJEAkTSRPJFIkVSR6JIQkhiSIJIskjiSQJJIk +lCSiJKQksyTAJMIkxSTIJOkk6yTuJPEk8yT1JPclESUTJR4lJyUqJfUl9yX5Jfwl/iYAJgImBSYHJgkm +DCYOJhEmFCYWJhgmGiYdJiAmIiYkJiYmKCYqJi0mLyYxJjMmNSY4JjsmPiZBJkMmRSZIJkomTCZPJlIm +VCZWJlgmWyZdJmAmYiZkJmYmaCZqJmwmbyZyJnQmdyZ5JnsmfiaAJoImhCaHJoomjCaOJpAmkyaVJpcm +miadJp8moSajJqUmpyapJqsmriaxJrMmtia5JrwmvibBJsMmxSbIJssmzSbPJtEm0ybWJtgm2ibcJt8m +4ibwJvkm+ycCJwQnBicIJxEnFicbJyQnJicpJysnMCc5JzsnQCdCJ0QnbSd7J4gniieMJ40njyeQJ5In +lCeWJ78nwSfDJ8QnxifHJ8knyyfNJ9Qn3SffJ+Qn5yfpKAooDCgPKBEoEygVKBcoIihLKFUoXihgKGIo +ZShnKGkoayhuKHEogiiFKIgoiyiOKJUopCitKK8ouCi6KLwovyjBKOoo7CjuKO8o8SjyKPQo9ij4KQcp +MCkyKTQpNSk3KTgpOik8KT4pSilTKVUpWClaKXMpnCmeKaApoSmjKaQppimoKaop0ynVKdcp2incKd4p +4CniKeUp7inwKfIqGyodKh8qISojKiUqJyoqKi0qNio4Kk8qUSpUKlcqWipdKmAqYiplKmcqaiptKpYq +mCqaKpsqnSqeKqAqoiqkKsUqxyrKKs0qzyrRKtMq7CruKxcrGSscKx8rISsjKyUrJysqKzMrRCtHK0or +TStQK1krWytcK24rlyuZK5srnCueK58roSujK6UrsivXK9kr3CvfK+Er4yvlK/4sACwpLCssLSwwLDIs +NCw2LDksPCxBLEosTCxnLGksayxuLHAscix0LHYseCx7LH4sgSyELIcssCyyLLQstSy3LLgsuiy8LL4s +5yzpLOss7izwLPIs9Cz2LPks/i0HLQktFC0WLRktHC0fLSEtRi1ILUstTi1QLVItVC1eLWAthS2HLYot +jS2PLZEtky2hLaMtzC3OLdAt0y3VLdct2S3bLd4t9S3+LgAuCS4MLg4uEC4SLjsuPS4/LkIuRC5GLkgu +Si5NLlQuXS5fLmQuZi5oLokuiy6OLpEuky6VLpcumy6dLsYuyC7KLs0uzy7RLtMu1i7ZLwIvBC8GLwkv +Cy8NLw8vEi8VLxovIy8lLzwvPy9CL0UvSC9LL00vTy9RL1QvVy9ZL3ovfC9/L4IvhC+GL4gvky+VL74v +wC/CL8Uvxy/JL8svzS/QL/kv+y/9L/4wADABMAMwBTAHMDAwMjA0MDcwOTA7MD0wQDBDME0wVjBYMGcw +ajBtMHAwczB2MHkwfDClMKcwqTCsMK4wsDCyMLUwuDDEMM0w0jDbMN4xqTGsMa8xsTGzMbUxuDG6Mbwx +vjHAMcMxxjHIMcoxzTHPMdEx0zHVMdcx2THbMd0x3zHhMeMx5THnMekx6zHuMfAx8jH0Mfcx+jH8Mf4y +ADICMgQyBjIIMgoyDDIPMhEyEzIVMhcyGTIbMh0yIDIjMiUyJzIqMiwyLjIwMjMyNTI3MjoyPTJAMkIy +RDJGMkgySjJMMk4yUDJSMlQyVjJYMloyXDJeMmAyYjJkMmcyajJsMm4ycDJyMnQydzJ5MnsyfTJ/MoEy +gzKFMo4ykTNeM2AzYjNlM2czaTNrM24zcDNyM3UzdzN6M30zfzOBM4MzhjOJM4szjTOPM5EzkzOWM5gz +mjOcM54zoTOkM6czqjOsM64zsTOzM7YzuDO7M70zvzPBM8QzxjPJM8szzTPPM9Ez0zPVM9gz2zPdM+Az +4jPkM+Yz6TPrM+0z8DPzM/Uz9zP5M/wz/jQANAM0BTQINAo0DDQONBA0EjQUNBc0GjQcNB80IjQlNCc0 +KjQsNC40MDQzNDY0ODQ6NDw0PjRBNEM0RTRHNEo0TTRWNFk1JjUpNSw1LzUyNTU1ODU7NT41QTVENUc1 +SjVNNVA1UzVWNVk1XDVfNWI1ZTVoNWs1bjVxNXQ1dzV6NX01gDWDNYY1iTWMNY81kjWVNZg1mzWeNaE1 +pDWnNao1rTWwNbM1tjW5Nbw1vzXCNcU1yDXLNc410TXUNdc12jXdNeA14zXmNek17DXvNfI19TX4Nfs1 +/jYBNgQ2BzYKNg02EDYTNhY2GTYcNh82IjYlNig2KzYuNjE2NDY3Njo2PTZANkM2RjZJNkw2TzZSNlU2 +bDZuNnI2jjaaNq02uTbjNwI3DjccNzE3MzdNN2I3iDeKN5Y3qTe8N9U36TgROBY4MzhOOFA4dTiROJ04 +vjjTONU48DkVOSE5Izk2OW05lzmuOcA5zDnkOf06Gzo7Ok06ZzqNOrQ6yzreOvo7EjsfOzY7XDtuO3A7 +rzvCO9U76Tv3PAM8FjwzPD48RzxUPGA8ijyrPMI8xTzdPOo9Dz0pPVM9bT1xPXU9kz2VPaM9tT3CPd49 +6D38PhU+IT42Pks+eT6dPqk+zD7VPtg+2T7iPuU+5j7vPvJAGUAbQB1AH0AiQCRAJkAoQCpALEAvQDFA +M0A2QDlAO0A9QEBAQ0BFQEdASUBLQE5AUUBTQFVAV0BZQFtAXkBgQGJAZEBmQGhAa0BtQG9AcUBzQHZA +eUB8QH9AgUCDQIZAiECKQIxAjkCQQJNAlUCYQJtAnUCfQKFAo0CmQKhAq0CtQK9AsUCzQLVAt0C5QLtA +vUC/QMJAxUDHQMpAzEDOQNBA00DVQNdA2UDbQN1A4EDiQOVA50DqQOxA7kDwQPJA9UD4QPpA/ED+QQFB +BEEGQQhBCkEMQQ5BEEESQRRBFkEYQRtBHkEgQSNBJkEoQStBLUEwQTJBNEE2QThBOkE8QT5BQUFDQUVB +SEFKQUxBTkFRQVNBVUFYQVpBXEFeQWBBY0FmQWlBckF1QpxCn0KiQqVCqEKrQq5CsUK0QrdCukK9QsBC +w0LGQslCzELPQtJC1ULYQttC3kLhQuRC50LqQu1C8ELzQvZC+UL8Qv9DAkMFQwhDC0MOQxFDFEMXQxpD +HUMgQyNDJkMpQyxDL0MyQzVDOEM7Qz5DQUNEQ0dDSkNNQ1BDU0NWQ1lDXENfQ2JDZUNoQ2tDbkNxQ3RD +d0N6Q31DgEODQ4ZDiUOMQ49DkkOVQ5hDm0OeQ6FDpEOnQ6pDrUOwQ7NDtkO5Q7xDv0PCQ8VDyEPLQ85D +0UPUQ9dD2kPdQ+BD40PmQ+lD7EPvQ/JD9UP4Q/tD/kQBRAREB0QKRA1EEEQTRBZEGUQcRB9EIkQlRChE +K0QuRDFENEQ3RDpEPURARENERkRJRExET0RSRFVEV0RZRFtEXkRgRGJEZERnRGlEbERvRHJEdER2RHlE +e0R9RH9EgkSERIZEiESKRI1EkESTRJVEl0SZRJtEnUSfRKFEpESmRKhEq0StRK9EskS7RL1Ev0TCRMRE +x0TKRM1Ez0TSRNRE1kTYRNpE3ETfROFE5ETnROlE7ETvRPJE9UT3RPlE/ET/RQFFBEUGRQhFCkUMRQ9F +EkUURRZFGEUaRRxFH0UhRSRFJkUoRSpFLUUvRTJFNEU2RThFO0U9RT9FQUVERUZFSEVLRU5FUEVTRVVF +V0VZRVtFXkVhRWNFZUVoRWpFbEVuRXFFc0V1RXhFekV9RYBFgkWFRYdFikWMRY5FkUWTRZVFmEWbRZ1F +n0WiRaVFqEWrRa5FsEWyRbtFvUW+RcdFykXLRdRF10XYReFF5gAAAAAAAAICAAAAAAAACaAAAAAAAAAA +AAAAAAAAAEX1A + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO.html (revision 8058) @@ -0,0 +1,122 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

CurrencyConverter HOWTO

+
+ +
+

Creating Apple's + Currency Converter example
+ with OpenMCL +

+ +
+ +
+ +
+

by mikel evins

+
+ +
+

This HOWTO guide explains how to use OpenMCL to create a + Cocoa application that is functionally identical to Apple's + + Currency Converter example. The most important + difference between Apple's example and this one is that this + one is implemented in Common Lisp instead of Objective C. It + uses OpenMCL's Objective-C bridge to provide communication + between the Lisp code that you write and Apple's Cocoa + frameworks. The resulting application looks and acts just + like any other Cocoa application.

+ +

This HOWTO doesn't discuss all the background information + that Apple's tutorial covers. Instead, we assume that you have + Apple's document handy for reference, and we just describe the + specific steps needed to build the example using + Apple's InterfaceBuilder application and OpenMCL.

+ +

The current version of the OpenMCL Objective-C bridge + includes code that was formerly distributed separately as the + "Bosco" application framework. Because that framework has been + integrated with OpenMCL proper, it no longer exists as a + separate project. "Bosco" now names only the decorative rodent + at the top of this page.

+
+ +
+

Apple's Currency Converter Example

+
+ +
+

It will be helpful in understanding this example if you can + easily refer to Apple's + Currency Converter example while working through this + HOWTO. You might consider opening a separate window or tab, and + keeping the Apple example handy while you work.

+ +

In some ways, the Lisp version of the example is simpler + than the Objective C example, but the basic concepts are the + same. In particular, the Lisp example follows the same + + Model-View-Controller paradigm that the Apple example + uses. If you are new to Cocoa programming, or if you are not + familiar with how it uses the Model-View-Controller paradigm, + it's probably a good idea to read through the Apple example + in full, paying special attention to the + Model-View-Controller section. Once you've done that, keep + the Apple pages handy in a window for easy reference.

+ +

This Common Lisp version of the Currency Converter example + uses Apple's InterfaceBuilder application to build a window and + main menu, and then uses Common Lisp code to load and operate + that user interface. The Common Lisp code relies on OpenMCL's + Objective-C bridge to provide communication between the running + Lisp code and Apple's Cocoa frameworks. Once the code is + complete, we use the BUILD-APPLICATION function to save a + working Cocoa application bundle. That bundle looks and acts + just like any other Cocoa application.

+ +
+ +
+

Requirements Before You Start

+
+ +
+

In order to build this example you will need:

+ +
    +

  • Mac OS X Tiger (version 10.4.x) or Mac OS X Leopard + (version 10.5.x)

    • +

  • Apple's XCode development tools

    • +

  • Apple's InterfaceBuilder application (included with XCode)

    • +

  • A recent version of OpenMCL

    • +

  • Clozure CL.app

    • +

  • The Apple + Currency Converter example, for reference

    • +
+
+ +
+

next

+
+ + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/build_app.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/build_app.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/build_app.html (revision 8058) @@ -0,0 +1,144 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Building the Application

+
+ +
+

Both the user interface and the behavior of the + CurrencyConverter are complete now. All that remains for us to + do is to build the application executable into a Cocoa + application bundle. Apple's tutorial relies on XCode to build + the application from Objective C source files; we will use the + Clozure CL IDE to build it from our Lisp source file.

+ +

We build the application using the optional + BUILD-APPLICATION feature, distributed as part of Clozure CL. The + steps to build the Cocoa application are:

+ +
    +

  • Load the application code into the IDE

    • +

  • Load the BUILD_APPLICATION feature

    • +

  • Run BUILD_APPLICATION with the proper arguments

    • +
+ +

This sequence of steps causes Clozure CL to construct a Cocoa + application bundle and write out the application executable to + it, then quit. If all goes well, you should be able to run the + application by double-clicking it, and use the UI you built in + InterfaceBuilder to convert currencies.

+
+ +
+

Building the Application, Step-by-Step

+
+ +
+
    +

  1. Launch the Clozure CL IDE. It's safest to build the + application with a fresh IDE session, so if you have it + running, you may wish to quit and relaunch before following + the rest of the steps.

    2. + +

  2. For convenience, set the working directory to your + "currency-converter" folder. For example, you can do + something like this (using your pathnames in place of mine, of + course:):

    +

    (setf (current-directory) "/Users/mikel/Valise/clozure/openmcl/example-code/currency-converter/")

    +
    3. + +

  3. Load the application code:

    +

    (load "currency-converter")

    +
    4. + +

  4. Load the BUILD-APPLICATION feature:

    +

    (require "build-application")

    +
    5. + +

  5. Run BUILD-APPLICATION (be sure to correct the pathname + to your CurrencyConverter nibfile. It is safest to use a full, + absolute pathname—not the relative pathname you see + below):

    + 

    +(ccl::build-application :name "CurrencyConverter"
+                        :main-nib-name "CurrencyConverter"
+                        :nibfiles 
+  '(#P"currency-converter/CurrencyConverter.nib"))

    +
    6. +
+ +

By default, BUILD-APPLICATION constructs the application + bundle in the current working directory. If you followed the + instructions here, that means it will build + CurrencyConverter.app in your currency-converter folder. You + can control where BUILD-APPLICATION puts the application bundle + by passing a pathname as the value of the keyword argument + :DIRECTORY, like so:

+ + 

+(ccl::build-application :name "CurrencyConverter"
+                        :directory #P"/Users/mikel/Desktop/"
+                        :main-nib-name "CurrencyConverter"
+                        :nibfiles 
+  '(#P"currency-converter/CurrencyConverter.nib"))

+ +

If all goes well, BUILD-APPLICATION constructs an + application bundle, copies "CurrencyConverter.nib" into it, + writes the application executable, and quits. You should now + be able to launch CurrencyConverter.app by double-clicking + the application icon:

+ +
+ +
+ +

CurrencyConverter.app launches and displays your user + interface, which you can then use to convert currencies:

+ +
+ +
+ + +
+ +
+

Correcting the Application Name

+
+ +
+

You'll notice when you run the application that, even though + you named it CurrencyConverter, the name in the main menu + appears as "Clozure CL". That's because OS X takes the + application's name, not from the application bundle's name, nor + from the running code, but from an InfoPlist.strings file hidden + inside the application bundle. To make the name appear + correctly in the running application, you need to edit the file

+ +

CurrencyConverter.app/Contents/Resources/English.lproj/InfoPlist.strings

+ +

Find the entry named "CFBundleName" and change its value + from "Clozure CL" to "CurrencyConverter". The application's name + in the main menu bar should now appear correctly, as + "CurrencyConverter". You may also want to change the other + strings in the "InfoPlist.strings" file.

+
+ +
+

start|next

+
+ + + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui.html (revision 8058) @@ -0,0 +1,324 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Building the User Interface

+
+ +
+

The next step in creating a Lisp version of the currency + converter application is to construct the user + interface. Apple's + tutorial + describes in detail how to do this.

+ +
+

Apple's Tutorial

+
+ +

Apple's tutorial explains how to use InterfaceBuilder to create the + user interface, and how to use XCode to create project files and + write Objective-C code. Our project uses Lisp instead of + Objective-C, and does not use XCode project files, so you can skip + the part of the tutorial that explains how to use XCode.

+ +
+

Using InterfaceBuilder to Create the UI

+
+ +

We'll begin by using Apple's InterfaceBuilder application to + create a nibfile. The nibfile contains + archived versions of the Objective C objects that define the + application's user interface. When you launch an application, + Mac OS X uses the archived objects in the nibfile to create the + windows and menus you see on the screen.

+ +

Start by locating Apple's InterfaceBuilder application. If + you installed Apple's Developer Tools, InterfaceBuilder should + be in the folder "/Developer/Applications/":

+ +
+ +
+ + +

NOTE: If you have not installed Apple's Developer Tools, you should + do that now. You will not be able to build the CurrencyConverter + example without them. The Developer Tools are distributed as an + optional install with Mac OS X 10.5 ("Leopard"). Look for the + "XCode Tools" package in the "Optional Installs" folder on the + Mac OS 10.5 install disk.

+ +

Once you have located InterfaceBuilder, double-click to launch + the application. InterfaceBuilder presents a window you can use + to choose a template for the nibfile you are going to create.

+ +
+ +
+ +

Click the "Application" icon and then click the "Choose" button to + create an application nibfile. InterfaceBuilder creates a new + application nibfile, but doesn't immediately save it. The + Objective C objects that represent the new application's + interface appear in a new untitled window:

+ +
+ +
+ +

The intial window and menubar also appear on the screen. The + new application's name appears in the menus as + "NewApplication". Save the new nibfile into the + "currency-converter" folder that you created earlier + (on this + page). InterfaceBuilder 3.0 gives you a choice of file + formats when you save a new nibfile; use the "NIB 3.x" + format—the "XIB 3.x" format works fine for editing your + user interface, but will not work correctly if you try to use it + in a working application. Give the new file the name + "CurrencyConverter.nib".

+ +
+

NOTE: Most Objective C application projects use a main + nibfile called "MainMenu.nib", and if you use XCode to create + a new application project, it creates a nibfile with that + name. Apple's CurrencyConverter tutorial assumes that the + name of the main nibfile is "MainMenu.nib".

+ +

So, why do we tell you to use a different name? Clozure CL + has a main nibfile built into it, whose name is + "MainMenu.nib". Normally you don't see it, and don't even + need to know that it exists. But the Clozure CL + application-building tools create a new application by + copying resources from the Clozure CL application, so that + your new application has available to it all the built-in + Clozure CL tools. We ask you to name your nibfile + "CurrencyConverter.nib" so that it can coexist with the + Clozure CL main nibfile without causing any problems.

+ +

This difference between a Lisp project and an Objective C + project might be a little confusing at first. Just try to keep + in mind that whenever Apple's tutorial refers to the + "MainMenu.nib" file, it means the file we have just created + and named "CurrencyConverter.nib". In a Clozure CL project, + "MainMenu.nib" is the name of the main Lisp nibfile, not your + application's main nibfile.

+
+ + +

Skip straight to the part of Apple's tutorial +called Defining + the View: Building the User Interface. Read + the introduction to +nibfiles, and follow the instructions to create the Currency Converter +interface. (Remember that when the tutorial tells you to open and edit +"MainMenu.nib", you will instead open and edit your +"CurrencyConverter.nib".) When you reach the end of the section +called Test + the Interface, and move on to the short section afterward + called What's Next, + you are done creating the interface for your +application. Save your nibfile and continue with the next section.

+ +
+

What if You Need to Use InterfaceBuilder 2.x?

+
+ +

If you are still using Mac OS X 10.4.x ("Tiger"), you can still + create a working nibfile and you can still follow the instructions + in this HOWTO to create a Cocoa application with Clozure CL. The + main obstacle to doing so is that the earlier versions of + InterfaceBuilder have a significantly different user interface, and + so you may find it hard to follow Apple's tutorial when working with + InterfaceBuilder.

+ +

If you are working with Mac OS X 10.4.x ("Tiger"), you can + look here to find a description + of how to build the user interface files with the earlier version of + InterfaceBuilder. When you have finished building your user + interface, you can continue with the next + section, "Creating a Lisp File".

+ +

One other thing: if you are using Mac OS X 10.4.x ("Tiger"), you + will be able to build Cocoa applications only on PPC Macs. The + Clozure CL Objective C support for Intel systems works only on Mac + OS X 10.5.x ("Leopard").

+ + +
+

Adding Custom Classes to the nibfile

+
+ +

Once the user interface for your application looks right, there is + still one important task to complete before you can use it. You must + record some information in the nibfile about the classes of the + objects, so that the application can create them with the right + connections in place.

+ +

When you use XCode to write an Objective C application, + InterfaceBuilder can read the Objective C header files and use the + information in them to create descriptions of the classes in the + Objective C code. When the application is written in Lisp, + InterfaceBuilder can't read the class descriptions from the code, + and so we'll have to manually tell the nibfile about any classes + that we use in the user interface.

+ +

As you will see in the following sections, we'll use Lisp code to + define two Objective C classes: Converter, and + ConverterController. The Converter class implements the method that + performs the actual currency conversion for our application; the + ConverterController class provides communication between the user + interface and the Converter object. We need a way to create instaces + of these two classes in the nibfile, so that launching the + application creates these instances and the connections between them + and the rest of the user interface.

+ +
+

Create Instances of Custom Classes

+
+ +

In InterfaceBuilder's Library window, select the Cocoa Objects and + Controllers view:

+ +
+ +
+ +

Drag an Object from the Library window and drop it into the main + CurrencyConverter window:

+ +
+ +
+ +

Now tell InterfaceBuilder the name of the new object's class. With + the Object icon selected in the main CurrencyConverter window, + choose the Identity tab of the Inspector. At the top of the + Identity view is a "Class" field; type the name of your custom + class (in this case, "Converter") into the "Class" field and save + the nibfile:

+ +
+ +
+ +

Repeat the previous steps to create an instance of the + ConverterController class: drag an "Object" icon and drop it in the + main CurrencyConverter window. Then, change the name of the + Object's class to "ConverterController".

+ +

That's all it takes to add an instance of a custom class to the + nibfile. We do still have to add the names of instance variables and + actions, and we need to create the connections between the + instances.

+ +
+

Add Outlets and Actions

+
+ +

Now, using the "+" button below the "Class Outlets" section of the + Inspector, add outlets to the ConverterController class. The + outlets you need to add are named "amountField", "converter", + "dollarField", and "rateField".

+ +
+ +
+ +

We'll connect each of the "field" outlets to one of the text + fields in the CurrencyConverter UI, and we'll connect the + "converter" outlet to the Converter instance that we created + before. When the application launches, it creates the Converter and + ConverterController instances and establishes the connections that + we specify in the nibfile.

+ + +

First, though, we need to tell the nibfile about actions as well as + outlets. With the "ConverterController" instance selected, use the + "+" button below the "Class Actions" section to add a new + action. Name the action "convert:":

+ +
+ +
+ +

In this application, the "convert:" action is the only action + defined for the user interface, so we are done with actions now. In + more complex applications you may need to define many actions and + outlets.

+ +

Now we'll connect outlets to objects and actions.

+ +
+

Add Connections

+
+ +

InterfaceBuilder enables you to connect objects by + "Control-dragging" from one to another. To "Control-drag", you hold + down the Control key while dragging from one object to the next.

+ +

Select the "ConverterController" instance in the nibfile's main + window, and Control-drag a connection to the "Exchange rate" text + field in the application's main window. (Be sure to connect to the + text field, not to its label!) When you release the mouse button, + InterfaceBuilder pops up a menu that lists the available + outlets. Choose "rateField" from the menu. The "rateField" outlet of + the "ConverterController" instance is now connected to the "Exchange + rate" text field.

+ +

Repeat the same steps for the "Dollars" field and the "Amount" + field, connecting them to the "dollarField" and "amountField" + outlets, respectively.

+ +

Finally, Control-drag a connection from the "ConverterController" + instance to the "Converter" instance. Choose "converter" from the + popup menu to connect the "converter" field of the + "ConverterController" instance to the "Converter" instance.

+ +

To confirm that the connections are correct, you can use the + Connections view in the inspector. With the "ConverterController" + instance selected, click the blue arrow icon at the top of the + Inspector window to display connections. You should see a list of + outlets and the types of objects they are connected to:

+ +
+ +
+ +

We need to add one more connection: from the "Convert" button in + the application window to the "ConverterController" + instance. Control drag a connection from the "Convert" button in the + application window to the "ConverterController" instance in the + nibfile's main window. InterfaceBuilder pops up a menu; choose the + "convert:" action from the menu to connect the button to the + action.

+ +

The nibfile now contains descriptions of the needed cusstom + classes and their connections. You can continue with the next + section, which explains how to write the Lisp code that implements + the application's behavior.

+ +
+

start|previous|next

+
+ + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui_tiger.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui_tiger.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui_tiger.html (revision 8058) @@ -0,0 +1,75 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Building the User Interface on "Tiger"

+
+ +
+

If you are using Mac OS X 10.4.x ("Tiger") to build your + application, then the Apple tutorial's section on building the + UI may be somewhat confusing. Apple's tutorial uses + InterfaceBuilder 3.x to show how to build an interface, and + there were many interface changes between versions 2.x and 3.x + of InterfaceBuilder. In this section we see how to build the UI + using InterfaceBuilder 2.x.

+ +
+

Launch InterfaceBuilder

+
+ +

Start by locating Apple's InterfaceBuilder application. If + you installed Apple's Developer Tools, InterfaceBuilder should + be in the folder "/Developer/Applications/":

+ +
+ +
+ +

NOTE: If you have not + installed Apple's Developer Tools, you should do that now. You + will not be able to build the CurrencyConverter example + without them. The Developer Tools are distributed as an + optional install with Mac OS X 10.4 ("Tiger"). Look for the + "XCode Tools" package in the "Optional Installs" folder on the + Mac OS 10.4 install disk.

+ +

Once you have located InterfaceBuilder, double-click to launch + the application. InterfaceBuilder presents a window you can use + to choose a template for the nibfile you are going to create.

+ +
+ +
+ +

Make sure the "Application" option is selected in the "Cocoa" + section and click the "New" button to create a new + nibfile. InterfaceBuilder creates a new application nibfile, but + doesn't immediately save it. The Objective C objects that + represent the new application's interface appear in a new + untitled window:

+ +
+ +
+ +

The intial window and menubar also appear on the screen. The + new application's name appears in the menus as + "NewApplication". Save the new nibfile into the + "currency-converter" folder that you created earlier + (on this page).

+ +
+ + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/conclusion.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/conclusion.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/conclusion.html (revision 8058) @@ -0,0 +1,40 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Conclusion

+
+ +
+

This concludes our HOWTO on building the Apple + CurrencyConverter example in Lisp with Clozure CL. Your own Lisp + applications are likely to be considerably more complex than the + Currency Converter, which, after all, just does a simpe + multiplication. You can, however, use exactly the same steps to + build a much richer and more full-featured Cocoa + application.

+ +

A more complex application will still consist of one or more + nibfiles and one or more Lisp source files. You will still use + the Objective C bridge to define Objective C classes and + methods, and to use Cocoa library features. And you will still + use BUILD-APPLICATION to turn your source and nibfiles into + standalone Cocoa applications.

+ +

You should now be able to use Clozure CL to accomplish anything + that an Objective C user can accomplish with Cocoa. Good luck!

+ +
+

start

+
+ + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/create_lisp.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/create_lisp.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/create_lisp.html (revision 8058) @@ -0,0 +1,51 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Creating a Lisp File

+
+ +
+

Now that you have created the nibfile that defines your + application's user interface, it's time to create the Lisp + source file that defines its behavior. When you work with + Objective C, as in Apple's tutorial, you use Apple's XCode + application to create and manage projects, to edit Objective C + source files, and to build the final application. In this HOWTO, + the Clozure CL application takes the place of XCode. The Lisp + project structure is much simpler than the XCode project + structure: to build the Lisp application we need only the + nibfile created in the previous section, and a single Lisp + source file.

+ +

Double-click Clozure CL to launch it. Clozure CL displays a Listener window:

+ +
+ +
+ +

Choose "New" from the "File" menu to create a new Lisp source + window. Save it with the name "CurrencyConverter.lisp" into the + same "currency-converter" folder where you saved your nibfile in + the earlier section. You should now have a "currency-converter" + folder that contains a "CurrencyConverter.lisp" item and a + "CurrencyConverter.nib" item.

+ +

Now you're ready to continue, and write the Lisp code that + implements the application's behavior.

+ +
+

start|previous|next

+
+ + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/making_project.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/making_project.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/making_project.html (revision 8058) @@ -0,0 +1,60 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Creating a Project

+
+ +
+

Example Files

+
+ +
+

This HOWTO is distributed with example files that include a + working nibfile (a file of user-interface objects, + named "CurrencyConverter.nib") and a Lisp source file (named + "CurrencyConverter.lisp"). You can build a working copy of the + example application by using these files, but you probably + shouldn't. If you want to understand how to build your own Lisp + application projects, you should follow the instructions here to + create your own source file and nibfile, and use the example + files only for reference in case something goes wrong.

+
+ +
+

Create the Project Folder

+
+ +
+

First, create a project folder to hold the files you are + going to create. When your project is complete, the folder will + contain a nibfile that defines the user interface, and + a Lisp source file that defines the behavior of the + application. Those two files are really all there is to a Lisp + application, though not all applications are as simple as this + currency converter. For more complex applications it makes sense + to split your UI into several nibfiles, and to split your + implementation into several source files. The basic principle + remains the same, however: nibfiles define your user interface, + and Lisp files define your application's behavior.

+ +

Create a folder somewhere convenient, and name it + "currency-converter". Next we will use Apple's InterfaceBuilder + application to create the user interface The next page tells you + how to do that; when you create your nibfile, save it into your + "currency-converter" folder.

+ +
+

start|next

+
+ + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/writing_lisp.html =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/writing_lisp.html (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/pages/writing_lisp.html (revision 8058) @@ -0,0 +1,225 @@ + + + + CurrencyConverter HOWTO + + + + + +
+

Writing the Lisp Source

+
+ +
+

In this section we'll write Lisp code that duplicates the + features provided by the Objective C code in Apple's + tutorial. In Apple's tutorial, the explanation of the Objective + C code begins with the + section Bridging + the Model and View: The Controller.

+ +

The Lisp code in this section of the HOWTO is considerably + simpler than the corresponding Objective C code, in part + because we can ignore the conventions that XCode uses for + laying out source files. We can just write all our definitions + into a single Lisp source file, and load that file into Clozure CL + when we are ready to build the application.

+ +
+

First Things First

+
+ +
+

Place the following line at the top of your Lisp source file:

+ + 
(in-package "CCL")
+ +

Clozure CL's Objective C bridge code is defined in the "CCL" + package. Usually, when building an application, you'll create a + package for that application and import the definitions you need + to use. In order to keep the discussion short in this simple + example, we just place all our definitions in the "CCL" + package.

+ +
+ +
+

Defining the Converter Class

+
+ +
+

We begin by defining the Converter class. Recall from Apple's + tutorial that this is the Model class that implements the + conversion between dollars and other currencies. Here is the + Lisp definition that implements the class you created in + InterfaceBuilder:

+ + 
+(defclass converter (ns:ns-object)
+  ()
+  (:metaclass ns:+ns-object))
+
+
+ +
+

This is an ordinary CLOS class definition, with a couple of + simple wrinkles. First, the superclass it inherits from is the + NS-OBJECT class in the "NS" package. NS-OBJECT is an Objective C + class, the ancestor of all Objective C objects. This CLOS + definition actually creates a new Objective C class named + "Converter".

+ +

We tell Clozure CL how to build the right kind of class object + by including the :METACLASS option in the definition:

+ + 
+  (:metaclass ns:+ns-object)
+
+ +

The Objective C bridge knows that when the metaclass + is ns:+ns-object, it must lay out the class object + in memory as an Objective C class, rather than a normal CLOS + STANDARD-CLASS.

+ +

Next, we define the method "convertCurrency:atRate:":

+ + 
+(objc:defmethod (#/convertCurrency:atRate: :float) 
+    ((self converter) (currency :float) (rate :float))
+  (* currency rate))
+
+ +

This is the method that actually does the currency + conversion. It's very simple—really, it just multiples + currency times rate. Most of the text in the definition is + Objective C bridge code that links the definition to the right + class with the right argument and return types.

+ +

objc:defmethod is a version of DEFMETHOD that + creates Objective C method definitions.

+ +

The syntax #/convertCurrency:atRate: uses the + "#/" reader macro to read a symbol with case preserved, so that + you can see in your code the same name that Objective C uses for + the method, without worrying about how the name might be + converted between Lisp and Objective C conventions.

+ +

The number of arguments to an Objective C method is the + number of colons in the name, plus one. Each colon indicates an + argument, and there is always an extra "self" argument that + refers to the object that receives the message. These are normal + Objective C conventions, but we perhaps need to emphasize the + details, since we are using Lisp code to call the Objective C + methods.

+ +

We indicate the return type and the types of arguments in + the method definition by surrounding parameters and the method + name with parentheses, and appending the type name.

+ +

Thus, for example,

+ + 
+(#/convertCurrency:atRate: :float) 
+
+ +

means that the return type of the method is :FLOAT, and

+ + 
+(self converter) 
+
+ +

means that the type of the receiving object is Converter.

+ +

You will see these same conventions repeated in the next + section.

+
+ +
+

Defining the ConverterController Class

+
+ +
+

The previous section defined the Model class, Converter. All + we need now is a definition for the ConverterController + class. Recall from your reading of Apple's Tutorial that the + CurrencyConverter example uses the Model-View-Controller + paradigm. You used InterfaceBuilder to construct the + application's views. The Converter class provides the model + that represents application data. Now we define the controller + class, ConverterController, which connects the View and the + Model.

+ +

Here's the definition of the ConverterController class:

+ + 
+(defclass converter-controller (ns:ns-object)
+  ((amount-field :foreign-type :id :accessor amount-field)
+   (converter :foreign-type :id :accessor converter)
+   (dollar-field :foreign-type :id :accessor dollar-field)
+   (rate-field :foreign-type :id :accessor rate-field))
+  (:metaclass ns:+ns-object))
+
+ +

Once again we use the Objective C bridge to define an + Objective C class. This time, we provide several + instance-variable definitions in the class, and name accessors + for each of them explicitly. The :FOREIGN-TYPE + initargs enable us to specify the type of the field in the + foreign (Objective C) class.

+ +

Each field in the definition of the ConverterController class + is an outlet that will be used to store a reference to one of + the UI fields that you created in InterfaceBuilder. For + example, amount-field will be connected to the + "Amount" text field.

+ +

Why did we spell the name "amount-field" in Lisp code, and + "amountField" when creating the outlet in InterfaceBuilder? The + Objective C bridge automatically converts Lisp-style field names + (like "amount-field") to Objective C-style field names (like + "amountField"), when handling class definitions.

+ +

The converter field at launch time contains a + reference to the Converter object, whose class definition is in + the previous section.

+ +

The final piece of the implementation is a definition of the + "convert:" method. This is the method that is called when a + user clicks the "Convert" button in the user interface.

+ + 
+(objc:defmethod #/convert: ((self converter-controller) sender)
+  (let* ((conv (converter self))
+         (dollar-field (dollar-field self))
+         (rate-field (rate-field self))
+         (amount-field (amount-field self))
+         (dollars (#/floatValue dollar-field))
+         (rate (#/floatValue rate-field))
+         (amount (#/convertCurrency:atRate: conv dollars rate)))
+    (#/setFloatValue: amount-field amount)
+    (#/selectText: rate-field self)))
+
+ +

Just as in the Apple example, this method reads the dollar + and rate values, and passes them to the + "convertCurrency:atRate:" method of the Converter class. It then + sets the text of the amount-field to reflect the result of the + conversion. The only significant difference between this + implementation and Apple's is that the code is written in Lisp + rather than Objective C.

+ +

This completes the definition of the CurrencyConverter's + behavior. All that remains is to actually build the cocoa + application. The next section shows how to do that.

+ +
+ +
+

start|previous|next

+
+ + + + Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/stylesheets/styles.css =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/stylesheets/styles.css (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/HOWTO_files/stylesheets/styles.css (revision 8058) @@ -0,0 +1,55 @@ +body { + background-color: white; + font-family: "Helvetica Neue", Arial, Helvetica, Geneva, sans-serif; +} + +.title { + text-align: center; + font-size: 16pt; +} + +.subtitle { + font-size: medium; + font-weight: bold; + text-align: center; +} + +.byline { + text-align: center; + font-weight: bold; + font-size: small; +} + +.section-head { + padding-top: 2em; + padding-left: 1em; +} + +.body-text { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 4em; + margin-right: 4em; + text-indent: 3em; +} + +.note { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 6em; + margin-right: 6em; + text-indent: 0em; +} + +.inline-image { + text-align: center; +} + +.nav { + text-align: center; + font-size: large; + font-weight: bold; + padding-top: 4em; +} + +li, pre { + text-indent: 0; +} Index: /branches/experimentation/later/source/examples/cocoa/currency-converter/currency-converter.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/currency-converter/currency-converter.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/currency-converter/currency-converter.lisp (revision 8058) @@ -0,0 +1,53 @@ +(in-package "CCL") + +;;; define the classes referenced in the nibfile + +(defclass converter (ns:ns-object) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/convertCurrency:atRate: :float) + ((self converter) (currency :float) (rate :float)) + (* currency rate)) + +(defclass converter-controller (ns:ns-object) + ((amount-field :foreign-type :id :accessor amount-field) + (converter :foreign-type :id :accessor converter) + (dollar-field :foreign-type :id :accessor dollar-field) + (rate-field :foreign-type :id :accessor rate-field)) + (:metaclass ns:+ns-object)) + +(objc:defmethod #/convert: ((self converter-controller) sender) + (let* ((conv (converter self)) + (dollar-field (dollar-field self)) + (rate-field (rate-field self)) + (amount-field (amount-field self)) + (dollars (#/floatValue dollar-field)) + (rate (#/floatValue rate-field)) + (amount (#/convertCurrency:atRate: conv dollars rate))) + (#/setFloatValue: amount-field amount) + (#/selectText: rate-field self))) + + + + +#| +"/Users/mikel/Valise/clozure/openmcl/example-code/currency-converter/CurrencyConverter.nib" + +building the app: + +(progn + (setf (current-directory) "/Users/mikel/Valise/clozure/openmcl/example-code/currency-converter/") + (load "currency-converter") + (require "build-application") + (ccl::build-application :name "CurrencyConverter" + :main-nib-name "CurrencyConverter" + :directory "/Users/mikel/Desktop/" + :nibfiles '(#P"/usr/local/openmcl/trunk/ccl/examples/cocoa/currency-converter/CurrencyConverter.xib"))) + +TODO NOTES: + +The name of the app in the main menu title is determined by the CFBundleName field in the +InfoPlist.strings file in the English.lproj resources folder. + +|# Index: /branches/experimentation/later/source/examples/cocoa/easygui.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui.lisp (revision 8058) @@ -0,0 +1,8 @@ +(in-package :cl-user) + +(let ((path (or *load-pathname* *loading-file-source-file*))) + (load (merge-pathnames ";easygui;easygui.asd" path))) + +(asdf:operate 'asdf:load-op 'easygui) + +(push :easygui *features*) Index: /branches/experimentation/later/source/examples/cocoa/easygui/.cvsignore =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*~.* +*fsl Index: /branches/experimentation/later/source/examples/cocoa/easygui/action-targets.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/action-targets.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/action-targets.lisp (revision 8058) @@ -0,0 +1,17 @@ +(in-package :easygui) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; action/targets + +(defclass generic-easygui-target (ns:ns-object) + ((handler :initarg :handler :reader target-handler)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/activateAction :void) ((self generic-easygui-target)) + (funcall (target-handler self))) + +(defmethod (setf action) (handler (view view)) + (let ((target (make-instance 'generic-easygui-target + :handler handler))) + (#/setTarget: (cocoa-ref view) target) + (#/setAction: (cocoa-ref view) (@selector #/activateAction)))) Index: /branches/experimentation/later/source/examples/cocoa/easygui/easygui.asd =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/easygui.asd (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/easygui.asd (revision 8058) @@ -0,0 +1,35 @@ +;;; -*- lisp -*- + +#+openmcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :asdf)) + +#-openmcl +(error "Requires OpenMCL") + + +(cl:defpackage :easygui-system (:use :cl :asdf)) + +(in-package :easygui-system) + +(defsystem cocoa.asd) + +(defmethod perform :after ((o compile-op) (sys (eql (find-system :cocoa.asd)))) + (require :cocoa)) + +(defmethod operation-done-p ((o compile-op) (sys (eql (find-system :cocoa.asd)))) + nil) + +(defsystem easygui + :depends-on (cocoa.asd) + :components ((:file "package") + (:file "new-cocoa-bindings" :depends-on ("package")) + (:file "events" :depends-on ("new-cocoa-bindings")) + (:file "views" :depends-on ("events")) + (:file "action-targets" :depends-on ("views")) + (:module "example" + :depends-on ("action-targets") + :components + ((:file "tiny") + (:file "currency-converter") + (:file "view-hierarchy"))))) Index: /branches/experimentation/later/source/examples/cocoa/easygui/events.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/events.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/events.lisp (revision 8058) @@ -0,0 +1,69 @@ +(in-package :easygui) + +;;; Event handling basics + +(defmacro define-chaining-responder-method (class-name + (objc-name lisp-name) + (self-arg event-arg) + &body arg-compute-forms) + `(objc:defmethod (,objc-name :void) ((,self-arg ,class-name) + ,event-arg) + (let ((ev-class (class-name + (class-of (easygui-view-of ,self-arg))))) + (if (find-method #',lisp-name nil `(,ev-class) nil) ; TODO: doesn't consider subclasses. + (,lisp-name (easygui-view-of ,self-arg) + ,@arg-compute-forms) + (,objc-name (#/nextResponder ,self-arg) ,event-arg))))) + +(defmacro define-useful-mouse-event-handling-routines (class-name) + `(progn + (define-chaining-responder-method ,class-name + (#/mouseDown: mouse-down) (self event) + :cocoa-event event + :location (let ((objc-pt (#/convertPoint:fromView: + self + (#/locationInWindow event) + nil))) + (point (ns:ns-point-x objc-pt) (ns:ns-point-y objc-pt))) + :button (#/buttonNumber event) + :click-count (#/clickCount event) + :delta (point (#/deltaX event) (#/deltaY event))) + (define-chaining-responder-method ,class-name + (#/mouseUp: mouse-up) (self event) + :cocoa-event event + :location (let ((objc-pt (#/convertPoint:fromView: + self + (#/locationInWindow event) + nil))) + (point (ns:ns-point-x objc-pt) (ns:ns-point-y objc-pt))) + :button (#/buttonNumber event) + :click-count (#/clickCount event) + :delta (point (#/deltaX event) (#/deltaY event))) + (define-chaining-responder-method ,class-name + (#/mouseDragged: mouse-dragged) (self event) + :cocoa-event event + :location (let ((objc-pt (#/convertPoint:fromView: + self + (#/locationInWindow event) + nil))) + (point (ns:ns-point-x objc-pt) (ns:ns-point-y objc-pt)))))) + +;;; Mouse: + +(defclass event-handler-mixin () ()) + +(defclass mouse-event-handler-mixin () ()) + + +(macrolet ((defgeneric-and-empty-method (name (&rest args) &rest options) + `(defgeneric ,name ,args + ,@options + (:method ,args + (declare (ignore ,@args)))))) + ;; TODO: mouse-move + (defgeneric-and-empty-method mouse-down (view &key cocoa-event location button + click-count delta)) + (defgeneric-and-empty-method mouse-up (view &key cocoa-event location button + click-count delta)) + (defgeneric-and-empty-method mouse-dragged (view &key cocoa-event location + delta))) Index: /branches/experimentation/later/source/examples/cocoa/easygui/example/currency-converter.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/example/currency-converter.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/example/currency-converter.lisp (revision 8058) @@ -0,0 +1,41 @@ +(in-package :easygui-demo) + +(defclass converter-window (window) + () + (:default-initargs :size (point 383 175) + :position (point 125 513) + :title "Currency Converter" + :resizable-p nil + :minimizable-p t)) + +(defmethod initialize-view :after ((cw converter-window)) + (let ((currency-form (make-instance 'form-view + :autosize-cells-p t + :interline-spacing 9.0 + :position (point 15 70) + :size (point 353 90))) + (convert-button (make-instance 'push-button-view + :default-button-p t + :text "Convert" + :position (point 247 15))) + (line (make-instance 'box-view + :position (point 15 59) + :size (point 353 2)))) + (setf (action convert-button) + #'(lambda () + (let ((exchange-rate (read-from-string + (entry-text currency-form 1) nil nil)) + (amount (read-from-string (entry-text currency-form 0) + nil nil))) + (when (and (numberp exchange-rate) (numberp amount)) + (setf (entry-text currency-form 2) + (prin1-to-string (* exchange-rate amount))))))) + (setf (editable-p (car (last (add-entries currency-form + "Exchange Rate per $1:" + "Dollars to Convert:" + "Amount in other Currency:")))) + nil) + (add-subviews cw currency-form line convert-button) + (window-show cw))) + +;(make-instance 'converter-window) Index: /branches/experimentation/later/source/examples/cocoa/easygui/example/tiny.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/example/tiny.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/example/tiny.lisp (revision 8058) @@ -0,0 +1,62 @@ +;;; Another example: +;;; This one creates a full-window view and draws in it. +;;; This is the easygui equivalent of examples/cocoa/tiny.lisp. + +(in-package :easygui-demo) ; In user code, this might be easygui-user + +(defclass tiny-demo-drawing-view (drawing-view) () + (:default-initargs :accept-key-events-p t)) + +(defconstant short-pi (coerce pi 'short-float)) +(defparameter numsides 12) + +(defmethod draw-view-rectangle ((view tiny-demo-drawing-view) rectangle) + (declare (ignore rectangle)) + (let* ((view (cocoa-ref view)) + (bounds (#/bounds view)) + (width (ns:ns-rect-width bounds)) + (height (ns:ns-rect-height bounds))) + (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5)) + (Y (tt) `(* (1+ (cos ,tt)) height 0.5))) + ;; Fill the view with white + (#/set (#/whiteColor ns:ns-color)) + ;; Trace two polygons with N sides and connect all of the vertices + ;; with lines + (#/set (#/blackColor ns:ns-color)) + (loop + for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do (loop + for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do (#/strokeLineFromPoint:toPoint: + ns:ns-bezier-path + (ns:make-ns-point (X f) (Y f)) + (ns:make-ns-point (X g) (Y g)))))))) + +(defclass tiny-demo-window (window) () + (:default-initargs :size (point 400 400) + :position (point 100 350) + :title "Tiny rectangle drawing demo" + :resizable-p nil + :minimizable-p t)) + +(defmethod initialize-view :after ((window tiny-demo-window)) + (let ((draw-view (make-instance 'tiny-demo-drawing-view))) + (setf (content-view window) draw-view) + (window-show window))) + +;;; Mouse handling: +;;; (Drag up to increase number of points, down to decrease) +(defvar *original-point* nil) + +(defmethod mouse-down ((view tiny-demo-drawing-view) &key location + &allow-other-keys) + (setf *original-point* location)) + +(defmethod mouse-up ((view tiny-demo-drawing-view) &key location + &allow-other-keys) + (when *original-point* + (cond ((> (point-y location) (point-y *original-point*)) + (incf numsides)) + ((< (point-y location) (point-y *original-point*)) + (decf numsides))) + (redisplay view))) Index: /branches/experimentation/later/source/examples/cocoa/easygui/example/view-hierarchy.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/example/view-hierarchy.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/example/view-hierarchy.lisp (revision 8058) @@ -0,0 +1,43 @@ +(in-package :easygui-user) + +(defclass view-hierarchy-demo-window (window) + () + (:default-initargs :size (point 480 270) + :position (point 125 513) + :resizable-p nil + :minimizable-p t + :title "View tree demo") + (:documentation "Shows a window with a simple view hierarchy and a button +action that manipulates this hierarchy.")) + +(defmethod initialize-view :after ((w view-hierarchy-demo-window)) + (let ((left-box (make-instance 'box-view + :position (point 17 51) + :size (point 208 199) + :title "Left")) + (right-box (make-instance 'box-view + :position (point 255 51) + :size (point 208 199) + :title "Right")) + (swap-button (make-instance 'push-button-view + :position (point 173 12) + :text "Switch sides")) + (text (make-instance 'static-text-view + :text "Oink!" + :position (point 37 112))) + (leftp t)) + (setf (action swap-button) + (lambda () + (retaining-objects (text) + (cond (leftp + (remove-subviews left-box text) + (add-subviews right-box text)) + (t + (remove-subviews right-box text) + (add-subviews left-box text)))) + (setf leftp (not leftp)))) + (add-subviews w left-box right-box swap-button) + (add-subviews left-box text) + (window-show w))) + +;;; (make-instance 'view-hierarchy-demo-window) Index: /branches/experimentation/later/source/examples/cocoa/easygui/new-cocoa-bindings.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/new-cocoa-bindings.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/new-cocoa-bindings.lisp (revision 8058) @@ -0,0 +1,154 @@ +(in-package :easygui) + +;;; Helper types: + +;;; point: +(defclass eg-point () + ((x :initarg :x :reader point-x) + (y :initarg :y :reader point-y))) + +(defun point (x y) + (assert (>= x 0)) + (assert (>= y 0)) + (make-instance 'eg-point :x x :y y)) + +(defmethod print-object ((o eg-point) s) + (print-unreadable-object (o s :identity nil :type t) + (format s "(~,2,F/~,2,F)" (point-x o) (point-y o)))) + +;;; range: +(defclass eg-range () + ((start :initarg :start :reader range-start) + (end :initarg :end :reader range-end))) + +(defun range (start end) + (assert (>= end start)) + (make-instance 'eg-range :start start :end end)) + +(defun range-nsrange (range) + (ns:make-ns-range (range-start range) (range-end range))) + +(defclass eg-rectangle () + ((x :initarg :x :reader rectangle-x) + (y :initarg :y :reader rectangle-y) + (width :initarg :width :reader rectangle-width) + (height :initarg :height :reader rectangle-height))) + +(defun rectangle (x y width height) + (assert (>= x 0)) + (assert (>= y 0)) + (assert (>= width 0)) + (assert (>= height 0)) + (make-instance 'eg-rectangle :x x :y y :width width :height height)) + +(defun rectangle-nsrect (r) + (ns:make-ns-rect (rectangle-x r) (rectangle-y r) + (rectangle-width r) (rectangle-height r))) + +(defun nsrect-rectangle (r) + (rectangle (ns:ns-rect-x r) (ns:ns-rect-y r) + (ns:ns-rect-width r) (ns:ns-rect-height r))) + +;;; Base class for all Cocoa-based Easygui objects: +(defclass easy-cocoa-object () + ((ref :initarg :cocoa-ref) + (ref-valid-p :initform t :accessor cocoa-ref-valid-p))) + +(defgeneric cocoa-ref (eg-object) + (:method ((eg-object easy-cocoa-object)) + (if (cocoa-ref-valid-p eg-object) + (slot-value eg-object 'ref) + (error "Attempting to access an invalidated Cocoa object on ~A!" + eg-object)))) + +(defgeneric (setf cocoa-ref) (new eg-object) + (:method (new (eg-object easy-cocoa-object)) + (setf (cocoa-ref-valid-p eg-object) t + (slot-value eg-object 'ref) new))) + +(defvar *window-position-default-x* 200) +(defvar *window-position-default-y* 200) +(defvar *window-size-default-x* 200) +(defvar *window-size-default-y* 200) + +(defun ns-rect-from-points (posn size) + (ns:make-ns-rect (point-x posn) (point-y posn) + (point-x size) (point-y size))) + +(defparameter *flag-to-mask-alist* + `( ;; (:zoomable-p . #$NSZoomableWindowMask) ; doesn't work + (:minimizable-p . ,#$NSMiniaturizableWindowMask) + (:resizable-p . ,#$NSResizableWindowMask) + (:closable-p . ,#$NSClosableWindowMask))) + +(defun flag-mask (keyword enabled-p) + (if enabled-p + (or (cdr (assoc keyword *flag-to-mask-alist*)) 0) + 0)) + +(defparameter *key-to-mask-alist* + `((:control . ,#$NSControlKeyMask) + (:alt . ,#$NSAlternateKeyMask) + (:command . ,#$NSCommandKeyMask))) + +(defun key-mask (keyword) + (or (cdr (assoc keyword *key-to-mask-alist*)) 0)) + +;;; Memory management helpers: + +(defmacro maybe-invalidating-object ((eg-object) &body body) + `(if (= 1 (#/retainCount (cocoa-ref ,eg-object))) + (multiple-value-prog1 (progn ,@body) + (setf (cocoa-ref-valid-p ,eg-object) nil)) + (progn ,@body))) + +(defmethod retain-object ((o easy-cocoa-object)) + (#/retain (cocoa-ref o))) + +(defmethod release-object ((o easy-cocoa-object)) + (#/release (cocoa-ref o))) + +(defmacro retaining-objects ((&rest eg-objects) &body body) + "Retains EG-OBJECTS, runs BODY forms and releases them after control +has left BODY." + (let ((objects (gensym))) + `(let ((,objects (list ,@eg-objects))) + (mapc #'retain-object ,objects) + (unwind-protect (progn ,@body) + (mapc #'release-object ,objects))))) + +;;; debug macro for #/ funcalls: + +(defvar *debug-cocoa-calls* t) + +(defmacro dcc (form) + `(progn + (when *debug-cocoa-calls* + (format *trace-output* "Calling ~A on ~S~%" + ',(first form) (list ,@(rest form)))) + ,form)) + +;;; Running things on the main thread: + +(defclass cocoa-thunk (ns:ns-object) + ((thunk :accessor thunk-of)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/run :void) ((self cocoa-thunk)) + (funcall (thunk-of self))) + +(defun run-on-main-thread (waitp thunk) + (let ((thunk* (make-instance 'cocoa-thunk))) + (setf (thunk-of thunk*) thunk) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + thunk* + (@selector #/run) + +null-ptr+ + (not (not waitp))))) + +(defmacro running-on-main-thread ((&key (waitp t)) &body body) + `(run-on-main-thread ,waitp (lambda () ,@body))) + +;;; Getting views from objc objects: + +(defgeneric easygui-view-of (cocoa-view)) Index: /branches/experimentation/later/source/examples/cocoa/easygui/package.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/package.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/package.lisp (revision 8058) @@ -0,0 +1,31 @@ +(cl:defpackage :easygui + (:use :cl) + (:import-from :ccl with-autorelease-pool @selector lisp-string-from-nsstring +null-ptr+) + (:export #:point #:range #:rectangle #:window + #:point-x #:point-y #:rectangle-x #:rectangle-y #:rectangle-width + #:rectangle-height + ;; cocoa stuff + #:retain-object #:release-object #:retaining-objects + ;; view classes + #:view #:static-text-view #:text-input-view #:password-input-view + #:push-button-view + #:form-view #:form-cell-view #:box-view #:drawing-view #:slider-view + ;; event methods + #:mouse-down #:mouse-dragged #:mouse-up + ;; operators + #:cocoa-ref + #:add-subviews #:remove-subviews #:window-show #:set-window-title + #:content-view + #:initialize-view #:action #:view-text + #:add-entry #:add-entries #:editable-p + #:draw-view-rectangle + #:entry-text #:cell-count #:nth-cell #:selection #:redisplay + #:string-value-of #:integer-value-of #:float-value-of + #:double-value-of)) + +(cl:defpackage :easygui-demo + (:use :cl :easygui) + (:export #:converter-window #:tiny-demo-window)) + +(cl:defpackage :easygui-user + (:use :cl :easygui)) Index: /branches/experimentation/later/source/examples/cocoa/easygui/views.lisp =================================================================== --- /branches/experimentation/later/source/examples/cocoa/easygui/views.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/cocoa/easygui/views.lisp (revision 8058) @@ -0,0 +1,386 @@ +(in-package :easygui) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; view protocol + +(defgeneric initialize-view (view) + (:documentation "Initializes the view with a cocoa object, sets it up +according to initargs.")) + +(defgeneric add-1-subview (view super-view) + (:documentation "Adds a subview to another view in the view hierarchy.")) + +(defgeneric remove-1-subview (view super-view) + (:documentation "Removes a view from its superview, possibly deallocating it. +To avoid deallocation, use RETAINING-OBJECTS")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mixins + +(defclass value-mixin () ()) +(defclass string-value-mixin (value-mixin) ()) +(defclass numeric-value-mixin (value-mixin) ()) + +(macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer + &key new-value-form return-value-converter) + (let ((name (intern (format nil "~A-VALUE-OF" lisp-type)))) + `(progn + (defmethod ,name ((o ,class)) + ,(if return-value-converter + `(,return-value-converter + (dcc (,cocoa-reader (cocoa-ref o)))) + `(dcc (,cocoa-reader (cocoa-ref o))))) + (defmethod (setf ,name) (new-value (o ,class)) + (dcc (,cocoa-writer (cocoa-ref o) + ,(or new-value-form + 'new-value)))))))) + (def-type-accessor string-value-mixin string #/stringValue #/setStringValue: + :return-value-converter lisp-string-from-nsstring ) + + (def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:) + (def-type-accessor numeric-value-mixin float + #/floatValue #/setFloatValue: + :new-value-form (coerce new-value 'single-float)) + (def-type-accessor numeric-value-mixin double + #/doubleValue #/setDoubleValue: + :new-value-form (coerce new-value 'double-float))) + +(defclass view-text-mixin () + ((text :initarg :text))) +(defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mixin) + ()) +(defclass view-text-via-title-mixin (view-text-mixin) + ((text :initarg :title))) + +(defmethod view-text ((view view-text-via-stringvalue-mixin)) + (string-value-of view)) + +(defmethod view-text ((view view-text-via-title-mixin)) + (lisp-string-from-nsstring (dcc (#/title (cocoa-ref view))))) + +(defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin)) + (setf (string-value-of view) new-text)) + +(defmethod (setf view-text) (new-text (view view-text-via-title-mixin)) + (dcc (#/setTitle: (cocoa-ref view) new-text))) + +(defmethod initialize-view :after ((view view-text-mixin)) + (when (slot-boundp view 'text) + (setf (view-text view) (slot-value view 'text)))) + +(defclass editable-mixin () ()) + +(defmethod editable-p ((view editable-mixin)) + (dcc (#/isEditable (cocoa-ref view)))) + +(defmethod (setf editable-p) (editable-p (view editable-mixin)) + (check-type editable-p boolean) + (dcc (#/setEditable: (cocoa-ref view) editable-p))) + +(defclass one-selection-mixin () ()) + +(defmethod (setf selection) (selection (view one-selection-mixin)) + (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection)))) + +(defmethod selection ((view one-selection-mixin)) + (let ((range (dcc (#/selectedRange (cocoa-ref view))))) + (if (= (ns:ns-range-location range) #$NSNotFound) + nil + (range (ns:ns-range-location range) + (ns:ns-range-length range))))) + +(defclass content-view-mixin () + (content-view)) + +(defmethod initialize-view :after ((view content-view-mixin)) + (setf (slot-value view 'content-view) + (make-instance 'view + :cocoa-ref (dcc (#/contentView (cocoa-ref view)))))) + +(defmethod content-view ((view content-view-mixin)) + (assert (eql (cocoa-ref (slot-value view 'content-view)) + (dcc (#/contentView (cocoa-ref view))))) + (slot-value view 'content-view)) + +(defmethod (setf content-view) (new-content-view (view content-view-mixin)) + (setf (slot-value view 'content-view) new-content-view) + (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; the actual views (when adding a new class, +;;; consider *view-class-to-ns-class-map*): + +(defclass view (easy-cocoa-object) + ((position :initarg :position :reader view-position) + (size :initarg :size :reader view-size) + (frame-inited-p :initform nil))) + +(defclass window (content-view-mixin view-text-via-title-mixin view) + ((text :initarg :title :initform "" :reader window-title) + (zoomable-p :initarg :zoomable-p :initform t :reader window-zoomable-p) + (minimizable-p :initarg :minimizable-p :initform t + :reader window-minimizable-p) + (resizable-p :initarg :resizable-p :initform t + :reader window-resizable-p) + (closable-p :initarg :closable-p :initform t :reader window-closable-p))) + +(defclass static-text-view (view view-text-via-stringvalue-mixin) ()) + +(defclass text-input-view (view editable-mixin view-text-via-stringvalue-mixin + ;; XXX: requires NSTextView, but this is an + ;; NSTextField: + #+not-yet one-selection-mixin) + ((input-locked-p :initform nil :initarg :input-locked-p + :reader text-input-locked-p))) + +(defclass password-input-view (text-input-view) + ()) + +(defclass push-button-view (view view-text-via-title-mixin) + ((default-button-p :initarg :default-button-p :initform nil + :reader default-button-p))) + +(defclass form-view (view) + ((autosize-cells-p :initarg :autosize-cells-p :initform nil) + (interline-spacing :initarg :interline-spacing :initform 9) + ;; cell width + )) + +(defclass form-cell-view (view editable-mixin view-text-via-stringvalue-mixin) + ()) + +(defclass box-view (content-view-mixin view-text-via-title-mixin view) ()) + +(defclass drawing-view (view) + ( + ;; TODO: make this a mixin + (accept-key-events-p :initform nil :initarg :accept-key-events-p + :accessor accept-key-events-p))) + +(defclass slider-view (view numeric-value-mixin) + ((max-value :initarg :max-value) + (min-value :initarg :min-value) + (tick-mark-count :initarg :tick-mark-count) + (discrete-tick-marks-p :initarg :discrete-tick-marks-p))) + +(defparameter *view-class-to-ns-class-map* + '((static-text-view . ns:ns-text-field) + (text-input-view . ns:ns-text-field) + (password-input-view . ns:ns-secure-text-field) + (push-button-view . ns:ns-button) + (form-view . ns:ns-form) + (form-cell-view . ns:ns-form-cell) + (box-view . ns:ns-box) + (drawing-view . cocoa-drawing-view) + (slider-view . ns:ns-slider))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; view initialization: + +(defmethod shared-initialize :around ((view view) new-slots &rest initargs) + (declare (ignore new-slots initargs)) + (call-next-method) + (running-on-main-thread () + (initialize-view view))) + +(defmethod initialize-view ((view view)) + "Initializes the view via the class-to-ns-class map." + (when (slot-boundp view 'ref) + (return-from initialize-view nil)) + (let ((ns-view-class (cdr (assoc (class-name (class-of view)) + *view-class-to-ns-class-map* + :test #'subtypep)))) + (when ns-view-class + (setf (cocoa-ref view) + (cond + ((and (slot-boundp view 'position) + (slot-boundp view 'size)) + (setf (slot-value view 'frame-inited-p) t) + (make-instance ns-view-class + :with-frame (with-slots (position size) view + (ns-rect-from-points position size)))) + (t (make-instance ns-view-class))))))) + +(defmethod initialize-view ((win window)) + "Initialize size, title, flags." + (with-slots (position size) win + (let ((content-rect + (multiple-value-call + #'ns:make-ns-rect + (if (slot-boundp win 'position) + (values (point-x position) (point-y position)) + (values *window-position-default-x* + *window-position-default-y*)) + (if (slot-boundp win 'size) + (values (point-x size) (point-y size)) + (values *window-size-default-x* + *window-size-default-y*)))) + (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win)) + (flag-mask :resizable-p + (window-resizable-p win)) + (flag-mask :minimizable-p + (window-minimizable-p win)) + (flag-mask :closable-p + (window-closable-p win)) + #$NSTitledWindowMask))) + (setf (cocoa-ref win) (make-instance 'ns:ns-window + :with-content-rect content-rect + :style-mask style-mask + :backing #$NSBackingStoreBuffered ; TODO? + :defer nil))))) + +(defmethod initialize-view :after ((view text-input-view)) + (setf (editable-p view) (not (text-input-locked-p view)))) + +(defmethod initialize-view :after ((view static-text-view)) + (dcc (#/setEditable: (cocoa-ref view) nil)) + (dcc (#/setBordered: (cocoa-ref view) nil)) + (dcc (#/setBezeled: (cocoa-ref view) nil)) + (dcc (#/setDrawsBackground: (cocoa-ref view) nil))) + +(defmethod initialize-view :after ((view push-button-view)) + (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle)) + (let ((default-button-p (slot-value view 'default-button-p))) + (typecase default-button-p + (cons + (dcc (#/setKeyEquivalent: (cocoa-ref view) (string + (first default-button-p)))) + (dcc (#/setKeyEquivalentModifierMask: + (cocoa-ref view) + (apply #'logior (mapcar #'key-mask (cdr default-button-p)))))) + (string + (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p))) + (null) + (t + (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return)))))))) + +(defmethod initialize-view :after ((view form-view)) + (when (slot-boundp view 'interline-spacing) + (dcc (#/setInterlineSpacing: (cocoa-ref view) + (coerce (slot-value view 'interline-spacing) + 'double-float))))) + +(defmethod initialize-view :after ((view slider-view)) + (with-slots (discrete-tick-marks-p tick-mark-count min-value max-value) view + (cond ((and (not (slot-boundp view 'tick-mark-count)) + (slot-boundp view 'discrete-tick-marks-p) + (/= (length tick-mark-values) tick-mark-count)) + (error "Incompatible tick mark specification: ~A doesn't match ~ + count of ~A" tick-mark-values tick-mark-values)) + ((or (not (slot-boundp view 'max-value)) + (not (slot-boundp view 'min-value))) + (error "A slider view needs both :min-value and :max-value set."))) + (dcc (#/setMinValue: (cocoa-ref view) (float min-value ns:+cgfloat-zero+))) + (dcc (#/setMaxValue: (cocoa-ref view) (float max-value ns:+cgfloat-zero+))) + (when (slot-boundp view 'tick-mark-count) + (dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count)) + (dcc (#/setAllowsTickMarkValuesOnly: + (cocoa-ref view) (not (not discrete-tick-marks-p))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; view hierarchies: + +(defmethod add-1-subview :around ((view view) (cw-view content-view-mixin)) + (add-1-subview view (content-view cw-view))) + +(defmethod add-1-subview :around ((view view) (super-view view)) + "Correctly initialize view positions" + (call-next-method) + (with-slots (position size frame-inited-p) view + (unless frame-inited-p + (dcc (#/setFrameOrigin: (cocoa-ref view) + (ns:make-ns-point (point-x position) + (point-y position)))) + (if (slot-boundp view 'size) + (dcc (#/setFrameSize: (cocoa-ref view) + (ns:make-ns-point (point-x size) + (point-y size)))) + (dcc (#/sizeToFit (cocoa-ref view))))) + (dcc (#/setNeedsDisplay: (cocoa-ref view) t)) + (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t)))) + +(defmethod add-1-subview ((view view) (super-view view)) + (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view)))) + +(defun add-subviews (superview subview &rest subviews) + (add-1-subview subview superview) + (dolist (subview subviews) + (add-1-subview subview superview)) + superview) + +(defmethod remove-1-subview ((view view) (cw-view content-view-mixin)) + (remove-1-subview view (content-view cw-view))) + +(defmethod remove-1-subview ((view view) (super-view view)) + (assert (eql (cocoa-ref super-view) (#/superview (cocoa-ref view)))) + (maybe-invalidating-object (view) + (#/removeFromSuperview (cocoa-ref view)))) + +(defun remove-subviews (superview subview &rest subviews) + (remove-1-subview subview superview) + (dolist (subview subviews) + (remove-1-subview subview superview)) + superview) + +(defmethod window-show ((window window)) + (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil)) + window) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Forms: + +(defmethod add-entry (entry (view form-view)) + (make-instance 'form-cell-view + :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry)))) + +(defun add-entries (view &rest entries) + (prog1 (mapcar (lambda (entry) (add-entry entry view)) entries) + (dcc (#/setAutosizesCells: (cocoa-ref view) + (slot-value view 'autosize-cells-p))))) + +(defmethod cell-count ((view form-view)) + (dcc (#/numberOfRows (cocoa-ref view)))) + +(defmethod nth-cell (index view) + (assert (< index (cell-count view))) + (let ((cocoa-cell (dcc (#/cellAtIndex: (cocoa-ref view) index)))) + (when cocoa-cell + (make-instance 'form-cell-view :cocoa-ref cocoa-cell)))) + +(defmethod (setf entry-text) (text view index) + (setf (view-text (nth-cell index view)) text)) + +(defmethod entry-text (view index) + (view-text (nth-cell index view))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Drawing: + +(defclass cocoa-drawing-view (ns:ns-view) + ((easygui-view :initarg :eg-view :reader easygui-view-of)) + (:metaclass ns:+ns-view)) + +(defmethod initialize-view :after ((view drawing-view)) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view) + (rect :ect)) + (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect))) + +(objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-view)) + (accept-key-events-p (easygui-view-of view))) + +(defgeneric draw-view-rectangle (view rectangle) + (:method ((view drawing-view) rectangle) + (declare (ignore view rectangle)) + nil)) + +(defmethod redisplay ((view drawing-view) + &key rect) + (setf rect (if rect + (rectangle-nsrect rect) + (#/bounds (cocoa-ref view)))) + (#/setNeedsDisplayInRect: (cocoa-ref view) rect)) + +(define-useful-mouse-event-handling-routines cocoa-drawing-view) Index: /branches/experimentation/later/source/examples/finger.lisp =================================================================== --- /branches/experimentation/later/source/examples/finger.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/finger.lisp (revision 8058) @@ -0,0 +1,179 @@ +;;;; -*- mode: lisp -*- +;;;; Copyright (C) 2002-2003 Barry Perryman. +;;;; +;;;; finger.lisp +;;;; A simple finger client and server as specified by RFC 1288. +;;;; +;;;; Anyone who wants to use this code for any purpose is free to do so. +;;;; In doing so, the user acknowledges that this code is provided "as is", +;;;; without warranty of any kind, and that no other party is legally or +;;;; otherwise responsible for any consequences of its use. +;;;; +;;;; Changes: +;;;; 2003-xx-xx: General tidy up of code, especially the interface to the +;;;; server. Add some error handling. Update copyright. +;;;; Remove package. +;;;; 2002-07-15: New processes are optional. The system can now forward on +;;;; nested queries onto other servers, which can be a security +;;;; risk, so by default this is not enabled. +;;;; + +(defconstant +input-buffer-size+ 1024 + "Size of the input buffer used by read-sequence.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Start off with a couple of utility functions +(defun write-net-line (line stream) + "Write out the string line to the stream, terminating with CRLF." + (format stream "~a~c~c" line #\return #\linefeed)) + +(defun read-net-line (stream) + "Read a line from stream." + (let ((line (make-array 10 :element-type 'character :adjustable t :fill-pointer 0))) + (do ((c (read-char stream nil nil) (read-char stream nil nil))) + ((or (null c) + (and (char= c #\return) + (char= (peek-char nil stream nil nil) #\linefeed))) + (progn + (read-char stream nil nil) + line)) + (vector-push-extend c line)))) + +(defmacro aif (test yes no) + `(let ((it ,test)) + (if it + ,yes + ,no))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Finger client +(defun %finger (host query port) + "Send query to host:port using the finger protocol, RFC 1288. Returns the output as a string." + (declare (ignore verbose)) + (with-open-socket (net :remote-host host :remote-port port) + (write-net-line query net) + (force-output net) ; Doesn't seem to be needed, but just incase + (let ((inbuf (make-array +input-buffer-size+ :element-type 'character :initial-element #\space))) + (do* ((pos (read-sequence inbuf net) (read-sequence inbuf net)) + (output (subseq inbuf 0 pos) (concatenate 'string output (subseq inbuf 0 pos)))) + ((zerop pos) output))))) + +(defun finger (query &key (verbose nil) (port 79)) + "Takes a query, in the same format as the unix command line tool and execute it." + (let (host + (host-query (if verbose "/W " ""))) + (aif (position #\@ query :from-end t) + (setf host (subseq query (1+ it)) + host-query (concatenate 'string host-query (subseq query 0 it))) + (setf host query)) + (%finger host host-query port))) + +;; For testing try: +;; (finger "idsoftware.com") +;; (finger "johnc@idsoftware.com") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Server code +(defun finger-daemon (handler &key (port 79) (subqueries nil)) + "Start up a listner on port that responds to the finger protocol" + (process-run-function (format nil "finger-daemon on port ~d" port) + #'%finger-daemon handler port subqueries)) + +(defun %finger-daemon (handler port subqueries) + "Specific implementation routine." + (with-open-socket (sock :type :stream :connect :passive :local-port port :reuse-address t) + (loop + (let ((insock (accept-connection sock))) + (process-run-function "Finger request handler" + #'%finger-daemon-handler handler insock subqueries))))) + +(defun %finger-daemon-handler (handler socket subqueries) + (let* ((line (read-net-line socket)) + (verbose (and (>= (length line) 3) + (string= line "/W " :end1 3))) + (proc-line (if verbose (subseq line 3) line)) + (req-sub (find #\@ line :test #'char=)) + (ret-str (cond ((and subqueries req-sub) + (finger-forward-handler proc-line verbose)) + (req-sub + "Sub-Queries not supported.") + (t + (funcall handler proc-line verbose))))) + (if (null ret-str) + (write-sequence "Unknown." socket) + (write-sequence ret-str socket)) + (force-output socket) + (close socket))) + +(defun finger-forward-handler (line verbose) + "Handler for forwarding requests a third party" + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from finger-forward-handler "Unable to process the request.")))) + (finger line :verbose verbose))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Vending machine code, which becomes a simple server +(defstruct vending + button + contents + description + price) + +(defparameter *vending-machine* nil + "Holds the data for the vending machine.") + +(defun populate-vending-machine (data) + "Takes a list of data in the format (button short-desc long-desc price) and turns it into a vending mahcine." + (setf *vending-machine* (mapcar #'(lambda (x) + (destructuring-bind (b c d p) x + (make-vending :button b + :contents c + :description d + :price p))) + data))) + +(populate-vending-machine + '(("T1" "English Breakfast Tea" "Probably the best tea in the world." 1.0) + ("T2" "Earl Grey" "Well if you like the taste of washing up liquid..." 1.1) + ("T3" "Herbal Tea (Various)" "Smells great, tastes just like water." 0.80) + ("C1" "Cheap 'n' Nasty coffee." "It's awful, doesn't even taste like coffee." 0.50) + ("C2" "Freeze Dried Coffee." "Do yourself a favour and go to a coffee shop and get a real coffee." 1.0) + ("H1" "Hot Chocolate" "Carefull, this is so hot it'll cook your tastebuds." 1.0))) + +(defun vending-machine-details () + (with-output-to-string (stream) + (format stream "~%Button~10,0TContents~50,4TPrice~%") + (format stream "-------------------------------------------------------~%") + (dolist (i *vending-machine*) + (format stream "~a~10,0T~a~50,4T~,2f~%" + (vending-button i) + (vending-contents i) + (vending-price i))))) + +(defun specific-button-details (button) + "This write the specific information for the button" + (with-output-to-string (stream) + (let ((item (find button *vending-machine* + :key #'vending-button + :test #'string-equal))) + (cond ((null item) + (format stream "Not available on this machine.~%")) + (t + (format stream "Button: ~a~50,0tPrice: ~,2f~%" + (vending-button item) + (vending-price item)) + (format stream "Contents: ~a~%" + (vending-contents item)) + (format stream "Description: ~a~%" + (vending-description item))))))) + +(defun process-vending-machine-command (command verbose) + "This is the vending machine." + (declare (ignore verbose)) + (if (string= command "") + (vending-machine-details) + (specific-button-details command))) + +(defun vending-machine-demo (port) + (finger-daemon #'process-vending-machine-command :port port)) Index: /branches/experimentation/later/source/examples/gtk-clock.lisp =================================================================== --- /branches/experimentation/later/source/examples/gtk-clock.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/gtk-clock.lisp (revision 8058) @@ -0,0 +1,203 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; +;;; This is a (loose) translation of the double-buffered clock GTK+ +;;; example to OpenMCL. See p 222 of "Developing Linux Applications +;;; with GDK and GTK+", Eric Harlow, (c) 1999 New Riders Publishing. +;;; +;;; Anyone who wants to use this code for any purpose is free to do so. +;;; In doing so, the user acknowledges that this code is provided "as is", +;;; without warranty of any kind, and that no other party is legally or +;;; otherwise responsible for any consequences of its use. + +(in-package "CCL") + +;;; +;;; Make GTK+ interface info available. +(eval-when (:compile-toplevel :execute) + (use-interface-dir :GTK)) + +;;; GTK+ "runtime support"; handy to have around at compile time, too. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "OPENMCL-GTK-SUPPORT")) + + +;;; A global alist mapping clock windows to their offscreen pixmaps. +(defvar *gtk-clock-window-pixmaps* ()) + + +(defun draw-tick-at (pixmap gc nhour cx cy radius) + (let* ((radians (/ (* pi nhour) 6.0d0)) + (sin-radians (sin radians)) + (cos-radians (cos radians)) + (95%radius (* radius .95))) + (#_gdk_draw_line pixmap gc + (+ cx (floor (* 95%radius sin-radians))) + (+ cy (floor (* 95%radius cos-radians))) + (+ cx (floor (* radius sin-radians))) + (+ cy (floor (* radius cos-radians)))))) + +;;; It seems like this can get called when the drawing area's in the +;;; process of being destroyed. Try not to segfault in that case. +(defcallback gtk-clock-repaint (:address data :signed-fullword) + (if (or (%null-ptr-p data) + (%null-ptr-p (pref data :tkidget.style))) + #$FALSE + (let* ((drawing-area data) + (radius 0) + (white-gc (pref drawing-area :tkidget.style.white_gc)) + (black-gc (pref drawing-area :tkidget.style.black_gc)) + (area-width (pref drawing-area :tkidget.allocation.width)) + (area-height (pref drawing-area :tkidget.allocation.height)) + (dradians) + (midx 0) + (midy 0) + (vbox (pref drawing-area :tkidget.parent)) + (window (pref vbox :tkidget.parent)) + (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*)))) + (rlet ((update-rect :dkectangle)) + ;; Clear pixmap (background image) + (#_gdk_draw_rectangle + pixmap white-gc #$TRUE 0 0 area-width area-height) + + ;; Calculate midpoint of clock. + (setq midx (ash area-width -1) + midy (ash area-height -1)) + + ;; Calculate radius + (setq radius (min midx midy)) + + ;; Draw circle + (#_gdk_draw_arc pixmap black-gc 0 0 0 + (+ midx midx) (+ midy midy) 0 (* 360 64)) + + ;; Draw tickmarks on clock face. + (do* ((nhour 1 (1+ nhour))) + ((> nhour 12)) + (draw-tick-at pixmap black-gc nhour midx midy radius)) + (multiple-value-bind (seconds minutes hours) + (decode-universal-time (get-universal-time)) + + ;; Get radians from seconds + (setq dradians (/ (* seconds pi) 30.0d0)) + + ;; Draw second hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.9d0 radius (sin dradians)))) + (- midy (floor (* 0.9d0 radius (cos dradians))))) + + ;; Get radians from minutes & seconds. + (setq dradians (+ (/ (* minutes pi) 30.0d0) + (/ (* seconds pi) 1800.0d0))) + + ;; Draw minute hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.7d0 radius (sin dradians)))) + (- midy (floor (* 0.7d0 radius (cos dradians))))) + + ;; Get radians from hours & minutes. + (setq dradians (+ (/ (* (mod hours 12) pi) 6.0d0) + (/ (* minutes pi) 360.0d0))) + + ;; Draw hour hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.5d0 radius (sin dradians)))) + (- midy (floor (* 0.5d0 radius (cos dradians))))) + + ;; Setup the update rectangle; this will force an expose event. + ;; The expose event handler will then copy the pixmap to the + ;; window. + + (setf (pref update-rect :dkectangle.x) 0 + (pref update-rect :dkectangle.y) 0 + (pref update-rect :dkectangle.width) area-width + (pref update-rect :dkectangle.height) area-height) + + ;; Draw the update rectangle. + (#_gtk_widget_draw drawing-area update-rect) + #$TRUE))))) + + +;;; This is called when the window's created and whenever it's +;;; resized. Create a new pixmap of appropriate +;;; size; free the old one (if it's non-null). +(defcallback gtk-clock-configure-event + (:address widget :address event :address window :signed-fullword) + (declare (ignore event)) + (let* ((pair (assoc window *gtk-clock-window-pixmaps*))) + (if (cdr pair) + (#_gdk_pixmap_unref (cdr pair))) + + (setf (cdr pair) + (#_gdk_pixmap_new (pref widget :tkidget.window) + (pref widget :tkidget.allocation.width) + (pref widget :tkidget.allocation.height) + -1))) + #$TRUE) + +;;; Copy the window's pixmap to the exposed region of the window. +(defcallback gtk-clock-expose-event + (:address widget :address event :address window :signed-fullword) + (let* ((state (pref widget :tkidget.state)) + (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*))) + (fg-gc (pref widget :tkidget.style.fg_gc)) + (x (pref event :dkventxpose.area.x)) + (y (pref event :dkventxpose.area.y)) + (width (pref event :dkventxpose.area.width)) + (height (pref event :dkventxpose.area.height))) + (#_gdk_draw_pixmap + (pref widget :tkidget.window) + (%get-ptr fg-gc (ash state 2)) + pixmap + x y + x y + width height) + #$FALSE)) + +;;; When the window's destroyed, delete its entry from the +;;; *gtk-clock-window-pixmaps* alist. + +(defcallback gtk-clock-close (:address window :void) + (let* ((pair (assoc window *gtk-clock-window-pixmaps*))) + (if pair + (setq *gtk-clock-window-pixmaps* + (delete pair *gtk-clock-window-pixmaps*)) + (break "No entry for window!")))) + +(defun gtk-clock () + ;; Doesn't hurt to call gtk-init more than once. + (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL)) + (vbox (#_gtk_vbox_new #$FALSE 0))) + (push (cons window nil) *gtk-clock-window-pixmaps*) + (#_gtk_container_add window vbox) + (#_gtk_widget_show vbox) + (let* ((drawing-area (#_gtk_drawing_area_new))) + (#_gtk_drawing_area_size drawing-area 200 200) + (#_gtk_box_pack_start vbox drawing-area #$TRUE #$TRUE 0) + (#_gtk_widget_show drawing-area) + (with-cstrs ((expose-name "expose_event") + (configure-name "configure_event") + (destroy-name "destroy") + (window-title + "Takes a lickin' and keeps on tickin'.")) + (#_gtk_window_set_title window window-title) + (#_gtk_signal_connect drawing-area + expose-name + gtk-clock-expose-event + window) + (#_gtk_signal_connect drawing-area + configure-name + gtk-clock-configure-event + window) + (#_gtk_signal_connect window + destroy-name + gtk-clock-close + (%null-ptr))) + (#_gtk_widget_show window) + (#_gtk_timeout_add 1000 gtk-clock-repaint drawing-area) + (values)))) + Index: /branches/experimentation/later/source/examples/gtk-minesweeper.lisp =================================================================== --- /branches/experimentation/later/source/examples/gtk-minesweeper.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/gtk-minesweeper.lisp (revision 8058) @@ -0,0 +1,992 @@ +;;;-*-Mode: LISP; Package: (MINESWEEPER :USE (CL CCL)) -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; +;;; This is a GTK+-based MineSweeper game, derived from a C program +;;; developed by Eric Harlow and published in "Developing Linux Programs +;;; with GTK+ and GDK", (c) 1999 New Riders Publishing. +;;; +;;; Anyone who wants to use this code for any purpose is free to do so. +;;; In doing so, the user acknowledges that this code is provided "as is", +;;; without warranty of any kind, and that no other party is legally or +;;; otherwise responsible for any consequences of its use. + +(defpackage "MINESWEEPER" + (:use "CL" "CCL") + (:export "MINESWEEPER")) + +(in-package "MINESWEEPER") + +;;; +;;; Make GTK+ interface info available. +(eval-when (:compile-toplevel :execute) + (use-interface-dir :GTK)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "OPENMCL-GTK-SUPPORT")) + + +(defconstant max-rows 35) +(defconstant max-cols 35) + +(defconstant button-width 24) +(defconstant button-height 26) + + +(defvar *nrows* 10) +(defvar *ncols* 10) +(defvar *ntotalbombs* 0) + +(defvar *bgameover* nil) +(defvar *bresetgame* nil) +(defvar *nbombsleft* nil) + +(defvar *table* nil) +(defvar *start-button* nil) +(defvar *bombs-label* nil) +(defvar *time-label* nil) +(defvar *vbox* nil) + +(defstruct cell + (buttonstate :button-unknown + :type (member (:button-down :button-unknown :button-flagged))) + button + (bombsnearby 0) + (has-bomb nil) + row + col) + +;;; The original C Minesweeper example uses GtkToggleButtons to +;;; represent the cells on the grid. They seem to work reasonably +;;; well except for one minor (but annoying) feature: "enter" and +;;; "leave" events cause the cells under the mouse to be highlighted, +;;; making it difficult to distinguish "unpressed buttons" from "the +;;; button under the mouse". +;;; +;;; This defines a GtkQuietToggleButton class that's exactly like +;;; GtkToggleButton except for the fact that it does nothing on +;;; "enter" and "leave" events. It's not necessarily the most +;;; interesting example of subclassing a Gtk widget, but it -is- an +;;; example of doing so. +;;; +;;; GtkQuietToggleButtons seem to be better, but there is still some +;;; room for improvement. + +(defcallback enter-or-leave-quietly (:address widget :void) + (let* ((id (with-cstrs ((cell-id "cell-id")) + (#_gtk_object_get_data widget cell-id))) + (cell (cell-id->cell id)) + (desired-state + (if (member (cell-buttonstate cell) + '(:button-unknown :button-flagged)) + #$GTK_STATE_NORMAL + #$GTK_STATE_ACTIVE)) + (current-state (pref widget :tkidget.state))) + (unless (eql current-state desired-state) + (#_gtk_widget_set_state widget desired-state)))) + +(defcallback gtk_quiet_toggle_button_class_init (:address classptr :void) + (setf (pref classptr :tkuttonlass.enter) enter-or-leave-quietly + (pref classptr :tkuttonlass.leave) enter-or-leave-quietly)) + + +(defcallback gtk_quiet_toggle_button_init (:address widget :void) + (declare (ignore widget))) + + +;;; CCL::DEFLOADVAR behaves like DEFPARAMETER, but arranges to +;;; initialize the variable whenever a saved image start up +;;; as well as when the DEFLOADVAR is executed. +(ccl::defloadvar *gtk-quiet-toggle-button-type-info* + (let* ((p (#_malloc (ccl::%foreign-type-or-record-size :tkypenfo :bytes)))) + (setf + (pref p :tkypenfo.type_name) + (with-cstrs ((name "GtkQuietToggleButton")) (#_g_strdup name)) + (pref p :tkypenfo.object_size) + (ccl::%foreign-type-or-record-size :tkoggleutton :bytes) + (pref p :tkypenfo.class_size) + (ccl::%foreign-type-or-record-size :tkoggleuttonlass :bytes) + (pref p :tkypenfo.class_init_func) gtk_quiet_toggle_button_class_init + (pref p :tkypenfo.object_init_func) gtk_quiet_toggle_button_init + (pref p :tkypenfo.reserved_1) (%null-ptr) + (pref p :tkypenfo.reserved_2) (%null-ptr) + (pref p :tkypenfo.base_class_init_func) (%null-ptr)) + p)) + +(ccl::defloadvar *gtk-quiet-toggle-button-type* nil) + +(defun gtk-quiet-toggle-button-get-type () + (or *gtk-quiet-toggle-button-type* + (setq *gtk-quiet-toggle-button-type* + (#_gtk_type_unique (#_gtk_toggle_button_get_type) + *gtk-quiet-toggle-button-type-info*)))) + +(defcallback gtk_quiet_toggle_button_get_type (:unsigned-fullword) + (gtk-quiet-toggle-button-get-type)) + +(defun gtk-quiet-toggle-button-new () + (#_gtk_type_new (gtk-quiet-toggle-button-get-type))) + +(defcallback gtk_quiet_toggle_button_new (:address) + (gtk-quiet-toggle-button-new)) + +(defparameter *minesweeper-use-quiet-toggle-buttons* t) + +;;; Display message dialogs (as for the About... box). + +;;; A dialog widget has "grabbed" the focus. Call back here when +;;; the dialog is to be closed; yield the focus. +(defcallback close-show-message + (:address container :address data :void) + (declare (ignore container)) + (let* ((dialog-widget data)) + (#_gtk_grab_remove dialog-widget) + (#_gtk_widget_destroy dialog-widget))) + +(defcallback clear-show-message + (:address widget :address data :void) + (declare (ignore data)) + (#_gtk_grab_remove widget)) + +(defun show-message (title message) + (let* ((dialog-window (#_gtk_dialog_new))) + (with-cstrs ((destroy-name "destroy")) + (#_gtk_signal_connect dialog-window destroy-name clear-show-message + (%null-ptr))) + (with-cstrs ((title title)) + (#_gtk_window_set_title dialog-window title)) + (#_gtk_container_set_border_width dialog-window 0) + + (let* ((button (with-cstrs ((ok "OK")) + (#_gtk_button_new_with_label ok)))) + (with-cstrs ((clicked "clicked")) + (#_gtk_signal_connect button clicked close-show-message dialog-window)) + (setf (pref button :tkbject.flags) + (logior (pref button :tkbject.flags) #$GTK_CAN_DEFAULT)) + (#_gtk_box_pack_start (pref dialog-window :tkialog.action_area) + button #$TRUE #$TRUE 0) + (#_gtk_widget_grab_default button) + (#_gtk_widget_show button)) + + (let* ((label (with-cstrs ((message message)) + (#_gtk_label_new message)))) + (#_gtk_misc_set_padding label 10 10) + (#_gtk_box_pack_start (pref dialog-window :tkialog.vbox) + label #$TRUE #$TRUE 0) + (#_gtk_widget_show label)) + + (#_gtk_widget_show dialog-window) + (#_gtk_grab_add dialog-window))) + + +(defun show-about () + (show-message "About ..." + "Minesweeper OpenMCL GTK+ example +Copyright 2001 Clozure Associates +Derived from Minesweeper v0.6 by Eric Harlow")) + +(defvar *win-main* ()) +(defvar *accel-group* ()) +(defvar *tooltips* ()) + +(defun reset-minesweeper-globals () + (setq *win-main* nil + *accel-group* nil + *tooltips* nil + *vbox* nil + *time-label* nil + *bombs-label* nil + *start-button* nil + *table* nil + *bgameover* nil + *bresetgame* nil)) + +(defun create-widget-from-xpm (window xpm-string-list) + (rlet ((mask (* :dkitmap))) + (with-string-vector (xpm-data xpm-string-list) + (let* ((pixmap-data (#_gdk_pixmap_create_from_xpm_d + (pref window :tkidget.window) + mask + (%null-ptr) + xpm-data)) + (pixmap-widget (#_gtk_pixmap_new pixmap-data (%get-ptr mask)))) + (#_gtk_widget_show pixmap-widget) + pixmap-widget)))) + +(defun create-menu-item (menu item-name accel tip func data) + ;; A null or zero-length item-name indicates a separator. + (let* ((menuitem nil)) + (if (and item-name (length item-name)) + (with-cstrs ((item-name item-name) + (activate "activate")) + (setq menuitem (#_gtk_menu_item_new_with_label item-name)) + (#_gtk_signal_connect menuitem activate func (or data (%null-ptr)))) + (setq menuitem (#_gtk_menu_item_new))) + (#_gtk_menu_append menu menuitem) + (#_gtk_widget_show menuitem) + + (unless *accel-group* + (setq *accel-group* + (#_gtk_accel_group_new)) + (#_gtk_accel_group_attach *accel-group* + *win-main*)) + + (if (and accel (char= (schar accel 0) #\^)) + (with-cstrs ((activate "activate")) + (#_gtk_widget_add_accelerator + menuitem activate *accel-group* (char-code (schar accel 1)) + #$GDK_CONTROL_MASK #$GTK_ACCEL_VISIBLE))) + + (if (and tip (length tip)) + (with-cstrs ((tip tip)) + (#_gtk_tooltips_set_tip + (or *tooltips* + (setq *tooltips* (#_gtk_tooltips_new))) + menuitem + tip + (%null-ptr)))) + menuitem)) + +(defun create-radio-menu-item (menu item-name group-ptr func data) + (with-cstrs ((item-name item-name) + (toggled "toggled")) + (let* ((menuitem (#_gtk_radio_menu_item_new_with_label + (%get-ptr group-ptr) + item-name))) + (setf (%get-ptr group-ptr) + (#_gtk_radio_menu_item_group menuitem)) + (#_gtk_menu_append menu menuitem) + (#_gtk_widget_show menuitem) + (#_gtk_signal_connect menuitem toggled func (or data (%null-ptr))) + menuitem))) + +(defun create-bar-sub-menu (menu name) + (with-cstrs ((name name)) + (let* ((menuitem (#_gtk_menu_item_new_with_label name))) + (#_gtk_menu_bar_append menu menuitem) + (#_gtk_widget_show menuitem) + (let* ((submenu (#_gtk_menu_new))) + (#_gtk_menu_item_set_submenu menuitem submenu) + submenu)))) + +;;; Represent xpm string vectors as lists of strings. WITH-STRING-VECTOR +;;; will produce a foreign vector of C strings out of such a list. +(defvar *xpm-one* + '( + "12 12 2 1" + " c None" + "X c #3333CC" + " " + " XX " + " XXX " + " X XX " + " XX " + " XX " + " XX " + " XX " + " XX " + " XXXXXX " + " " + " " + )) + +(defvar *xpm-two* + '( + "12 12 2 1" + " c None" + "X c #009900" + " " + " XXXXXX " + " X X " + " XX " + " XX " + " XX " + " XX " + " XX " + " XX " + " XXXXXXXX " + " " + " " + )) + + +(defvar *xpm-three* + '( + "12 12 2 1" + " c None" + "X c #AA0000" + " " + " XXXXX " + " XX " + " XX " + " XXXXXX " + " XX " + " XX " + " XX " + " XX " + " XXXXXX " + " " + " " + )) + + +(defvar *xpm-four* + '( + "12 12 2 1" + " c None" + "X c #000066" + " " + " XX XX " + " XX XX " + " XX XX " + " XX XX " + " XXXXXXXX " + " XX " + " XX " + " XX " + " XX " + " " + " " + )) + + + +(defvar *xpm-five* + '( + "12 12 2 1" + " c None" + "X c #992299" + " " + " XXXXXXXX " + " XX " + " XX " + " XXXXXXX " + " XX " + " XX " + " XX " + " XX XX " + " XXXXXXX " + " " + " " + )) + + +(defvar *xpm-six* + '( + "12 12 2 1" + " c None" + "X c #550055" + " " + " XXXXXX " + " XX " + " XX " + " XXXXXXX " + " XX XX " + " XX XX " + " XX XX " + " XX XX " + " XXXXXX " + " " + " " + )) + + + +(defvar *xpm-seven* + '( + "12 12 2 1" + " c None" + "X c #550000" + " " + " XXXXXXXX " + " XX " + " XX " + " XX " + " XX " + " XX " + " WX " + " XX " + " XX " + " " + " " + )) + + + +(defvar *xpm-eight* + '( + "12 12 2 1" + " c None" + "X c #441144" + " " + " XXXXXX " + " XX XX " + " XX XX " + " XXXXXX " + " XX XX " + " XX XX " + " XX XX " + " XX XX " + " XXXXXX " + " " + " " + )) + +(defvar *xpm-flag* + '( + "12 12 4 1" + " c None" + "X c #000000" + "R c #FF0000" + "r c #AA0000" + " " + " RRRRRRR " + " RRRRRrr " + " RRRrrrr " + " Rrrrrrr " + " X " + " X " + " X " + " X " + " X " + " XXX " + " " + )) + + +;;; +;;; --- A bomb. Ooops, you're not as smart as you thought. +;;; +(defvar *xpm-bomb* + '( + "12 12 4 1" + " c None" + "X c #000000" + "R c #FF0000" + "r c #AA0000" + " " + " X " + " X X X " + " XXXXX " + " XXXXX " + " XXXXXXXXX " + " XXXXX " + " XXXXX " + " X X X " + " X " + " " + " " + )) + + +;;; +;;; --- Wrong move! +;;; +(defvar *xpm-bigx* + '( + "12 12 4 1" + " c None" + "X c #000000" + "R c #FF0000" + "r c #AA0000" + "RRR RRR" + " RRR RRR " + " RRR RRR " + " RRRRRR " + " RRRR " + " RRRR " + " RRRR " + " RRRRRR " + " RRR RRR " + " RRR RRR " + "RRR RRR" + " " + )) + + +;;; +;;; --- Bitmap of a smile +;;; +(defvar *xpm-smile* + '( + "16 16 4 1" + " c None" + ". c #000000" + "X c #FFFF00" + "r c #AA0000" + " ...... " + " ..XXXXXX.. " + " ..XXXXXXXXXX. " + " .XXXXXXXXXXXX. " + " .XX..XXXX..XX. " + ".XXX..XXXX..XXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + " .XX.XXXXXX.XX. " + " .XXX......XXX. " + " .XXXXXXXXXX. " + " ..XXXXXX.. " + " ...... " + " " + )) + + +;;; +;;; --- frown. You lost. +;;; +(defvar *xpm-frown* + '( + "16 16 4 1" + " c None" + ". c #000000" + "X c #FFFF00" + "r c #AA0000" + " ...... " + " ..XXXXXX.. " + " ..XXXXXXXXXX. " + " .XXXXXXXXXXXX. " + " .XX.X.XX.X.XX. " + ".XXXX.XXXX.XXXX." + ".XXX.X.XX.X.XXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + " .XXX......XXX. " + " .XX.XXXXXX.XX. " + " .XXXXXXXXXX. " + " ..XXXXXX.. " + " ...... " + " " + )) + + +;;; +;;; --- We have a winner +;;; +(defvar *xpm-winner* + '( + "16 16 4 1" + " c None" + ". c #000000" + "X c #FFFF00" + "r c #AA0000" + " ...... " + " ..XXXXXX.. " + " ..XXXXXXXXXX. " + " .XXXXXXXXXXXX. " + " .XX...XX...XX. " + ".XX..........XX." + ".X.X...XX...X.X." + "..XXXXXXXXXXXX.." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + " .XX.XXXXXX.XX. " + " .XXX......XXX. " + " .XXXXXXXXXX. " + " ..XXXXXX.. " + " ...... " + " " + )) + +(defvar *digits* + (vector nil *xpm-one* *xpm-two* *xpm-three* *xpm-four* *xpm-five* + *xpm-six* *xpm-seven* *xpm-eight*)) + +(defun set-grid (ncols nrows nbombs) + (when *table* + (#_gtk_widget_destroy *table*)) + (setq *table* (#_gtk_table_new ncols nrows #$FALSE)) + (#_gtk_box_pack_start *vbox* *table* #$FALSE #$FALSE 0) + (#_gtk_widget_realize *table*) + (reset-game ncols nrows nbombs t) + (#_gtk_widget_show *table*)) + + +;;; Menu callbacks. + +;;; This is called both when the start button is pressed and when +;;; the "New" menu item is selected. +(defcallback start-button-clicked (:address widget :address data :void) + (declare (ignore widget data)) + (set-start-button-icon *xpm-smile*) + (reset-game *ncols* *nrows* *ntotalbombs* nil)) + +(defcallback action-beginner + (:address widget :address data :void) + (declare (ignore data)) + (unless (zerop (pref widget :tkheckenutem.active)) + (set-grid 10 10 10))) + +(defcallback action-intermediate + (:address widget :address data :void) + (declare (ignore data)) + (unless (zerop (pref widget :tkheckenutem.active)) + (set-grid 20 15 40))) + +(defcallback action-advanced + (:address widget :address data :void) + (declare (ignore data)) + (unless (zerop (pref widget :tkheckenutem.active)) + (set-grid 30 20 100))) + +(defcallback action-quit (:address widget :address data :void) + (declare (ignore widget)) + (stop-timer) + (#_gtk_widget_destroy data) + (reset-minesweeper-globals)) + +(defcallback action-about (:void) + (show-about)) + +(defun create-menu (window vbox-main) + (setq *win-main* window) + (setq *accel-group* (#_gtk_accel_group_new)) + (#_gtk_accel_group_attach *accel-group* *win-main*) + (let* ((menubar (#_gtk_menu_bar_new))) + (#_gtk_box_pack_start vbox-main menubar #$FALSE #$TRUE 0) + (#_gtk_widget_show menubar) + (let* ((game-menu (create-bar-sub-menu menubar "Game"))) + (create-menu-item game-menu + "New" "^N" "New Game" start-button-clicked nil) + (create-menu-item game-menu nil nil nil nil nil) + (rlet ((group (* t))) + (setf (%get-ptr group) (%null-ptr)) + (with-macptrs ((group-ptr group)) + (create-radio-menu-item game-menu "Beginner" group-ptr + action-beginner nil) + (create-radio-menu-item game-menu "Intermediate" group-ptr + action-intermediate nil) + (create-radio-menu-item game-menu "Advanced" group-ptr + action-advanced nil))) + (create-menu-item game-menu nil nil nil nil nil) + (create-menu-item game-menu "Quit" nil "Quit game" + action-quit *win-main*)) + (let* ((help-menu (create-bar-sub-menu menubar "Help"))) + (create-menu-item help-menu "About Minesweeper" nil "Gory Details" + action-about nil)))) + + + + +(defparameter *cells* + (let* ((a (make-array (list max-cols max-rows)))) + (dotimes (row max-rows a) + (dotimes (col max-cols) + (setf (aref a col row) + (make-cell :row row :col col)))))) + +;;; Callbacks can receive (foreign) pointer arguments. Since we'd +;;; rather keep information in lisp structures/arrays, that's not +;;; directly helpful. + +;;; We can identify a cell by its row and column and +;;; can easily pack the row and column into a fixnum. This function's +;;; caller can coerce that fixnum into a pointer (via ccl::%int-to-ptr). + +(defun cell->cell-id (cell) + (dpb (cell-row cell) + (byte 8 8) + (cell-col cell))) + +;;; The inverse operation: the caller (a callback) will generally have +;;; a foreign pointer; it can coerce that to a fixnum and obtain the +;;; corresponding cell by unpacking its indices from that fixnum. + +(defun cell-id->cell (cell-id) + (let* ((id (if (typep cell-id 'macptr) + (%ptr-to-int cell-id) + cell-id)) + (row (ldb (byte 8 8) id)) + (col (ldb (byte 8 0) id))) + (declare (fixnum id row col)) + (aref *cells* col row))) + +;;; Free widget. +(defcallback FreeChildCallback (:address widget :void) + (#_gtk_widget_destroy widget)) + +;;; Free all of the widgets contained in this one. +(defun free-children (widget) + (#_gtk_container_foreach + (#_gtk_type_check_object_cast widget (#_gtk_container_get_type)) + FreeChildCallback (%null-ptr))) + +(defun add-image-to-mine (cell xpm-data) + (let* ((widget (create-widget-from-xpm *table* xpm-data))) + (#_gtk_container_add (cell-button cell) widget) + (#_gdk_pixmap_unref widget) + nil)) + +(defun open-nearby-squares (col row) + (declare (fixnum col row)) + (let* ((mincol (max (1- col) 0)) + (maxcol (min (1+ col) (1- *ncols*))) + (minrow (max (1- row) 0)) + (maxrow (min (1+ row) (1- *nrows*)))) + (declare (fixnum mincol maxcol minrow maxrow)) + (do* ((i mincol (1+ i))) + ((> i maxcol)) + (declare (fixnum i)) + (do* ((j minrow (1+ j))) + ((> j maxrow)) + (declare (fixnum j)) + (display-hidden-info (aref *cells* i j)))))) + +(defun display-hidden-info (cell) + (case (cell-buttonstate cell) + (:button-down + (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE)) + (:button-flagged + (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE)) + (t + (setf (cell-buttonstate cell) :button-down) + (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE) + (setf (pref (cell-button cell) :tkutton.button_down) #$TRUE) + (if (cell-has-bomb cell) + (add-image-to-mine cell *xpm-bomb*) + (let* ((nearby-bombs (cell-bombsnearby cell))) + (declare (fixnum nearby-bombs)) + (if (> nearby-bombs 0) + (add-image-to-mine cell (svref *digits* nearby-bombs)) + (open-nearby-squares (cell-col cell) (cell-row cell)))))))) + +(defun show-bombs () + (dotimes (i *ncols*) + (dotimes (j *nrows*) + (let* ((cell (aref *cells* i j)) + (buttonstate (cell-buttonstate cell)) + (has-bomb (cell-has-bomb cell))) + (if (and (eq buttonstate :button-unknown) has-bomb) + (display-hidden-info cell) + (when (and (eq buttonstate :button-flagged) (not has-bomb)) + (free-children (cell-button cell)) + (add-image-to-mine cell *xpm-bigx*))))))) + + + +(defcallback cell-toggled (:address widget :address data :void) + (let* ((cell (cell-id->cell data)) + (state (cell-buttonstate cell))) + (unless (eq state :button-flagged) + (if *bgameover* + (#_gtk_toggle_button_set_active widget + (if (eq state + :button-down) + #$TRUE + #$FALSE)) + (unless *bresetgame* + (start-timer) + (cond ((cell-has-bomb cell) + (setq *bgameover* t) + (set-start-button-icon *xpm-frown*) + (stop-timer) + (show-bombs)) + (t + (display-hidden-info cell) + (check-for-win)))))))) + + + +(defcallback button-press (:address widget :address event :address data :void) + (unless *bgameover* + (when (and (eql (pref event :dkventutton.type) #$GDK_BUTTON_PRESS) + (eql (pref event :dkventutton.button) 3)) + (let* ((cell (cell-id->cell data))) + (case (cell-buttonstate cell) + (:button-unknown + (free-children widget) + (setf (cell-buttonstate cell) :button-flagged) + (add-image-to-mine cell *xpm-flag*) + (decf *nbombsleft*)) + (:button-flagged + (free-children widget) + (setf (cell-buttonstate cell) :button-unknown) + (incf *nbombsleft*))) + (display-bomb-count) + (check-for-win))))) + + + + +(defun set-start-button-icon (xpm-list) + (let* ((widget (create-widget-from-xpm *start-button* xpm-list))) + (free-children *start-button*) + (#_gtk_container_add *start-button* widget))) + +(defun check-for-win () + (let* ((nmines 0)) + (declare (fixnum nmines)) + (dotimes (col *ncols*) + (declare (fixnum col)) + (dotimes (row *nrows*) + (declare (fixnum row)) + (when (member (cell-buttonstate (aref *cells* col row)) + '(:button-unknown :button-flagged)) + (incf nmines)))) + (when (= nmines (the fixnum *ntotalbombs*)) + (stop-timer) + (set-start-button-icon *xpm-winner*) + (setq *bgameover* t)))) + + +(defun create-button (table cell row column) + (let* ((button + (if *minesweeper-use-quiet-toggle-buttons* + (let* ((b (gtk-quiet-toggle-button-new)) + (id (cell->cell-id (aref *cells* column row)))) + (with-cstrs ((cell-id "cell-id")) + (#_gtk_object_set_data b cell-id (%int-to-ptr id))) + b) + (#_gtk_toggle_button_new))) + (cell-id (cell->cell-id cell))) + (with-cstrs ((toggled "toggled") + (button-press-event "button_press_event")) + (#_gtk_signal_connect button toggled cell-toggled + (%int-to-ptr cell-id)) + (#_gtk_signal_connect button button-press-event + button-press (%int-to-ptr cell-id))) + (#_gtk_table_attach table button + column (1+ column) + (1+ row) (+ row 2) + (logior #$GTK_FILL #$GTK_EXPAND) + (logior #$GTK_FILL #$GTK_EXPAND) + 0 0) + (#_gtk_widget_set_usize button button-width button-height) + (#_gtk_widget_show button) + button)) + + +(defun count-nearby-bombs (col row) + (declare (fixnum col row)) + (let* ((mincol (max (1- col) 0)) + (maxcol (min (1+ col) (1- *ncols*))) + (minrow (max (1- row) 0)) + (maxrow (min (1+ row) (1- *nrows*))) + (ncount 0)) + (declare (fixnum mincol maxcol minrow maxrow ncount)) + (do* ((i mincol (1+ i))) + ((> i maxcol) ncount) + (declare (fixnum i)) + (do* ((j minrow (1+ j))) + ((> j maxrow)) + (declare (fixnum j)) + (if (cell-has-bomb (aref *cells* i j)) + (incf ncount)))))) + +(defun display-bomb-count () + (with-cstrs ((buf (format nil "Bombs: ~d" *nbombsleft*))) + (#_gtk_label_set_text *bombs-label* buf))) + +(defun update-seconds (seconds) + (with-cstrs ((buf (format nil "Time: ~d" seconds))) + (#_gtk_label_set_text *time-label* buf))) + +(defun create-minesweeper-buttons (table ngridcols ngridrows bnewbuttons) + (setq *nrows* ngridrows + *ncols* ngridcols + *bgameover* nil + *bresetgame* t) + (display-bomb-count) + (dotimes (ci *ncols*) + (declare (fixnum ci)) + (dotimes (ri *nrows*) + (declare (fixnum ri)) + (let* ((cell (aref *cells* ci ri))) + (setf (cell-has-bomb cell) nil + (cell-buttonstate cell) :button-unknown) + (if bnewbuttons + (setf (cell-button cell) (create-button table cell ri ci)) + (progn + (free-children (cell-button cell)) + (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE)))))) + (do* ((nbombs *ntotalbombs*) + (state (make-random-state t))) + ((zerop nbombs)) + (declare (fixnum nbombs)) + (let* ((cell (aref *cells* (random *ncols* state) (random *nrows* state)))) + (unless (cell-has-bomb cell) + (setf (cell-has-bomb cell) t) + (decf nbombs)))) + (dotimes (ci *ncols*) + (declare (fixnum ci)) + (dotimes (ri *nrows*) + (declare (fixnum ri)) + (setf (cell-bombsnearby (aref *cells* ci ri)) + (count-nearby-bombs ci ri)))) + (setq *bresetgame* nil)) + +(defun reset-game (ncols nrows nbombs bnewbuttons) + (setq *ntotalbombs* nbombs + *nbombsleft* nbombs) + (create-minesweeper-buttons *table* ncols nrows bnewbuttons) + (stop-timer) + (update-seconds 0) + (set-start-button-icon *xpm-smile*)) + + + +;;; Timer stuff. + +(defvar *timer* nil) +(defvar *nseconds* 0) + +(defcallback timer-callback (:address data :void) + (declare (ignore data)) + (incf *nseconds*) + (update-seconds *nseconds*)) + +(defun start-timer () + (unless *timer* + (setq *nseconds* 0 + *timer* (#_gtk_timeout_add 1000 timer-callback *win-main*)))) + +(defun stop-timer () + (when *timer* + (#_gtk_timeout_remove *timer*) + (setq *timer* nil))) + + +;;; Finally ... + +(defun minesweeper () + (when *win-main* + (cerror + "Close current minesweeper game and start a new one" + "It seems that a minesweeper game is already active.") + (do* () + ((null *win-main*)) + (#_gtk_widget_destroy *win-main*) + (sleep 1))) + (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL))) + (#_gtk_window_set_policy window #$FALSE #$FALSE #$TRUE) + (with-cstrs ((window-title "Minesweeper")) + (#_gtk_window_set_title window window-title) + (setq *vbox* (#_gtk_vbox_new #$FALSE 1)) + (#_gtk_widget_show *vbox*) + (create-menu window *vbox*) + (let* ((hbox (#_gtk_hbox_new #$TRUE 1))) + (#_gtk_widget_show hbox) + (#_gtk_box_pack_start *vbox* hbox #$FALSE #$FALSE 0) + (with-cstrs ((len0-string "")) + (setq *bombs-label* (#_gtk_label_new len0-string) + *time-label* (#_gtk_label_new len0-string))) + (#_gtk_box_pack_start hbox *bombs-label* #$FALSE #$FALSE 0) + (#_gtk_widget_show *bombs-label*) + (setq *start-button* (#_gtk_button_new)) + (with-cstrs ((clicked "clicked")) + (#_gtk_signal_connect *start-button* clicked start-button-clicked + (%null-ptr))) + (#_gtk_box_pack_start hbox *start-button* #$FALSE #$FALSE 0) + (#_gtk_widget_show *start-button*) + (#_gtk_box_pack_start hbox *time-label* #$FALSE #$FALSE 0) + (#_gtk_widget_show *time-label*) + (#_gtk_widget_show hbox) + (#_gtk_container_add window *vbox*) + (with-cstrs ((destroy "destroy")) + (#_gtk_signal_connect window destroy action-quit window)) + (#_gtk_widget_show window) + + (set-start-button-icon *xpm-smile*) + (set-grid 10 10 10))))) Index: /branches/experimentation/later/source/examples/gtk-step.lisp =================================================================== --- /branches/experimentation/later/source/examples/gtk-step.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/gtk-step.lisp (revision 8058) @@ -0,0 +1,352 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; +;;; Anyone who wants to use this code for any purpose is free to do so. +;;; In doing so, the user acknowledges that this code is provided "as is", +;;; without warranty of any kind, and that no other party is legally or +;;; otherwise responsible for any consequences of its use. + +;;; A GTK+-based interface to OpenMCL's stepper. + +(in-package "CCL") + +;;; +;;; Make GTK+ interface info available. +(eval-when (:compile-toplevel :execute) + (ccl::use-interface-dir :GTK)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "OPENMCL-GTK-SUPPORT") + (require "STEP")) + +(eval-when (:compile-toplevel :execute) + (defconstant gtk-step-window-command-step 1) + (defconstant gtk-step-window-command-step-over 2) + (defconstant gtk-step-window-command-go 3) + (defconstant gtk-step-window-command-eval 4) + (defconstant gtk-step-window-command-quit 5) + (defconstant gtk-step-window-command-window-closed 9999)) + +(defparameter *gtk-step-window-button-commands* + (list gtk-step-window-command-step + gtk-step-window-command-step-over + gtk-step-window-command-go + gtk-step-window-command-eval + gtk-step-window-command-quit)) + +;;; The callback associated with button-clicked events appends one of the +;;; GTK-STEP-WINDOW-COMMAND- constants to a GList whose address is stored +;;; in P. If the contents of P are non-NULL, remove the first element +;;; from the GList and return the command. +(defun gtk-step-window-command (p) + (without-interrupts + (let* ((q (%get-ptr p))) + (declare (dynamic-extent q)) + (unless (%null-ptr-p q) + (setf (%get-ptr p) (#_g_list_remove_link q q)) + (let* ((cmd (%ptr-to-int (pref q :ist.data)))) + (#_g_list_free_1 q) + cmd))))) + +;;; Button clicks come here; the "cmd" argument contains +;;; the command specific to this button, encoded as a pointer. +(defcallback gtk-step-window-button-clicked + (:address button :address cmd :void) + (with-cstrs ((qptr "qptr")) + (let* ((p (#_gtk_object_get_data button qptr))) + (declare (dynamic-extent p)) + (unless (%null-ptr-p p) + (without-interrupts + (setf (%get-ptr p) + (#_g_list_append (%get-ptr p) cmd))))))) + + +;;; If the step window gets closed before the stepper's finished, we +;;; want to know that ... +;;; The handler for the window-destroyed signal places a +;;; GTK-STEP-WINDOW-COMMAND-WINDOW-CLOSED command at the front of +;;; the command queue. +(defcallback gtk-step-window-closed (:address window :address cmd :void) + (with-cstrs ((qptr "qptr")) + (let* ((p (#_gtk_object_get_data window qptr))) + (declare (dynamic-extent p)) + (unless (%null-ptr-p p) + (without-interrupts + (setf (%get-ptr p) + (#_g_list_prepend (%get-ptr p) cmd))))))) + + +(defun make-gtk-step-window () + (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL))) + (#_gtk_widget_set_usize window 600 500) + (#_gtk_window_set_policy window #$TRUE #$TRUE #$FALSE) + (with-cstrs ((title "Step Window")) + (#_gtk_window_set_title window title)) + (#_gtk_container_set_border_width window 0) + (let* ((box1 (#_gtk_vbox_new #$FALSE 0)) + (box2 (#_gtk_vbox_new #$FALSE 10))) + (#_gtk_container_add window box1) + (#_gtk_widget_show box1) + (#_gtk_container_set_border_width box2 10) + (#_gtk_box_pack_start box1 box2 #$TRUE #$TRUE 0) + (#_gtk_widget_show box2) + (let* ((table (#_gtk_table_new 2 2 #$FALSE)) + (text (#_gtk_text_new (%null-ptr) (%null-ptr)))) + (#_gtk_text_set_editable text #$TRUE) + (#_gtk_text_set_line_wrap text #$TRUE) + (#_gtk_table_set_row_spacing table 0 2) + (#_gtk_table_set_col_spacing table 0 2) + (#_gtk_box_pack_start box2 table #$TRUE #$TRUE 0) + (#_gtk_widget_show table) + (#_gtk_table_attach table text + 0 ;left + 1 ;right + 0 ;top + 1 ;bottom + (logior #$GTK_EXPAND #$GTK_SHRINK #$GTK_FILL) + (logior #$GTK_EXPAND #$GTK_SHRINK #$GTK_FILL) + 0 + 0) + (#_gtk_widget_show text) + (let* ((vscrollbar (#_gtk_vscrollbar_new (pref text :tkext.vadj)))) + (#_gtk_table_attach table vscrollbar + 1 + 2 + 0 + 1 + #$GTK_FILL + (logior #$GTK_EXPAND #$GTK_SHRINK #$GTK_FILL) + 0 + 0) + (#_gtk_widget_show vscrollbar)) + (#_gtk_text_thaw text) + (let* ((separator (#_gtk_hseparator_new))) + (#_gtk_box_pack_start box1 separator #$FALSE #$TRUE 0) + (#_gtk_widget_show separator)) + (let* ((box3 (#_gtk_hbox_new #$FALSE 10))) + (#_gtk_container_set_border_width box3 10) + (#_gtk_box_pack_start box1 box3 #$FALSE #$TRUE 0) + (#_gtk_widget_show box3) + (with-cstrs ((step-name "Step") + (step-over-name "Step over") + (go-name "Go") + (eval-name "Eval ...") + (quit-name "Quit") + (clicked "clicked") + (qptr "qptr")) + (let* ((buttons (list + (#_gtk_button_new_with_label step-name) + (#_gtk_button_new_with_label step-over-name) + (#_gtk_button_new_with_label go-name) + (#_gtk_button_new_with_label eval-name) + (#_gtk_button_new_with_label quit-name))) + (commands *gtk-step-window-button-commands*) + (tips '("step through evaluation of form" + "step over evaluation of form" + "continue evaluation without stepping" + "evaluate an expression in current env" + "exit from the stepper (returning NIL)")) + (p (#_g_malloc0 4))) + (declare (dynamic-extent buttons)) + (dolist (b buttons) + (#_gtk_box_pack_start box3 b #$TRUE #$TRUE 0) + (#_gtk_object_set_data b qptr p) + (#_gtk_signal_connect b clicked + gtk-step-window-button-clicked + (%int-to-ptr (pop commands))) + (with-cstrs ((tip-text (pop tips))) + (let* ((tip (#_gtk_tooltips_new ))) + (#_gtk_tooltips_set_tip tip b tip-text (%null-ptr)))) + (#_gtk_widget_show b)) + (let* ((step-button (car buttons))) + (setf (pref step-button :tkbject.flags) + (logior (pref step-button :tkbject.flags) + #$GTK_CAN_DEFAULT)) + (#_gtk_widget_grab_default step-button)) + (with-cstrs ((destroy "destroy")) + (let* ((close-signal-id + (#_gtk_signal_connect window destroy + gtk-step-window-closed + (%int-to-ptr + gtk-step-window-command-window-closed)))) + (#_gtk_widget_show window) + (values text p window close-signal-id (reverse buttons))))))))))) + +;;; A GTK+ user-interface to OpenMCL's stepper. +(defclass step-gtk-window-ui (step-ui) + ((text :accessor step-gtk-window-ui-text) + (queue-ptr :accessor step-gtk-window-ui-queue-ptr) + (window :accessor step-gtk-window-ui-window) + (close-signal-id :accessor step-gtk-window-ui-close-signal-id) + (closed :initform nil :accessor step-gtk-window-ui-closed) + (finished :initform nil :accessor step-gtk-window-ui-finished) + (buttons :initform nil :accessor step-gtk-window-ui-buttons) + (normal-font :initform nil) + (bold-font :initform nil))) + +(defun ui-output-formatted-string (ui string font-id) + (unless (step-gtk-window-ui-closed ui) + (let* ((text (step-gtk-window-ui-text ui)) + (vadj (pref text :tkext.vadj)) + (font (if (eql 2 font-id) + (slot-value ui 'bold-font) + (slot-value ui 'normal-font)))) + (with-cstrs ((string string)) + (#_gtk_text_freeze text) + (#_gtk_text_insert text font (pref text :tkidget.style.black) + (%null-ptr) string -1) + (#_gtk_text_set_point text (#_gtk_text_get_length text)) + (unless (%null-ptr-p vadj) + (#_gtk_adjustment_set_value vadj (pref vadj :tkdjustment.upper))) + (#_gtk_text_thaw text))))) + +(defmethod step-prin1 ((ui step-gtk-window-ui) form font &optional prefix) + (ui-output-formatted-string + ui + (with-output-to-string + (stream) + (let ((*print-level* *step-print-level*) + (*print-length* *step-print-length*) + (*print-readably* nil) + (*print-array* nil) + (*print-case* :downcase)) + (when prefix (princ prefix stream)) + (prin1 form stream))) + font)) + +(defmethod step-tab ((ui step-gtk-window-ui)) + (ui-output-formatted-string + ui + (with-output-to-string + (stream) + (terpri stream) + (dotimes (i (min *step-level* *trace-max-indent*)) + (write-char #\Space stream))) + 1)) + +(defmethod step-show-error ((ui step-gtk-window-ui) err) + (ui-output-formatted-string + ui + (with-output-to-string + (stream) + (step-tab ui) + (princ "Error >> " stream) + (format stream "~A" err)) + 1)) + +(defmethod initialize-instance ((ui step-gtk-window-ui) &key) + (multiple-value-bind (text ptr window signal-id buttons) + (make-gtk-step-window) + (setf (step-gtk-window-ui-text ui) text + (step-gtk-window-ui-queue-ptr ui) ptr + (step-gtk-window-ui-window ui) window + (step-gtk-window-ui-close-signal-id ui) signal-id + (step-gtk-window-ui-buttons ui) buttons + (step-gtk-window-ui-finished ui) nil + (step-gtk-window-ui-closed ui) nil) + (with-cstrs ((medium "-misc-fixed-medium-r-*-*-*-120-*-*-*-*-*-*") + (bold "-misc-fixed-bold-r-*-*-*-120-*-*-*-*-*")) + (setf (slot-value ui 'normal-font) (#_gdk_font_load medium) + (slot-value ui 'bold-font) (#_gdk_font_load bold))))) + +(defmethod step-ask ((ui step-gtk-window-ui)) + (let* ((qptr (step-gtk-window-ui-queue-ptr ui)) + (cmd nil) + (wait-function #'(lambda () + (let* ((c (gtk-step-window-command qptr))) + (when c + (setq cmd c)))))) + (declare (dynamic-extent wait-function)) + (process-wait "step command wait" wait-function) + (cond + ((eql cmd gtk-step-window-command-step) :step) + ((eql cmd gtk-step-window-command-step-over) :step-over) + ((eql cmd gtk-step-window-command-go) :go) + ((eql cmd gtk-step-window-command-eval) :eval) + ((eql cmd gtk-step-window-command-quit) :quit) + (t :quit)))) + +(defmethod step-ui-finish ((ui step-gtk-window-ui)) + (unless (step-gtk-window-ui-finished ui) + (setf (step-gtk-window-ui-finished ui) t) + (let* ((window (step-gtk-window-ui-window ui))) + (#_gtk_signal_disconnect window + (step-gtk-window-ui-close-signal-id ui)) + (let* ((buttons (prog1 + (step-gtk-window-ui-buttons ui) + (setf (step-gtk-window-ui-buttons ui) nil))) + (parent (pref (car buttons) :tkidget.parent))) + (with-cstrs ((close "Close") + (clicked "clicked")) + (let* ((close-button (#_gtk_button_new_with_label close))) + (#_gtk_signal_connect_object close-button clicked + (foreign-symbol-address + "gtk_widget_destroy") + window) + (#_gtk_box_pack_start parent close-button #$TRUE #$TRUE 0) + (dolist (b buttons) + (#_gtk_widget_destroy b)) + (#_gtk_widget_show close-button))))))) + + + + +;;; Prompt for a string, via a GtkEntry widget. +;;; + +;;; Tell lisp that the dialog's closed (for whatever reason.) +(defcallback gtk-get-string-dialog-closed + (:address dialog :address info-ptr :void) + (declare (ignore dialog)) + (setf (%get-ptr info-ptr 0) (%null-ptr))) + +;;; String is ready. +(defcallback gtk-get-string-dialog-get-string + (:address entry :address info-ptr :void) + (setf (%get-ptr info-ptr 4) (#_g_strdup (#_gtk_entry_get_text entry))) + ;;; Close the dialog. + (#_gtk_widget_destroy (%get-ptr info-ptr 0))) + +(defun gtk-get-string-from-user (prompt) + (%stack-block ((info-ptr 12)) + (setf (%get-ptr info-ptr 0) (%null-ptr) ; backptr to window + (%get-ptr info-ptr 4) (%null-ptr)) ;string ptr + (let* ((dialog-window (#_gtk_window_new #$GTK_WINDOW_DIALOG)) + (vbox (#_gtk_vbox_new #$FALSE 0))) + (setf (%get-ptr info-ptr 0) dialog-window) + (#_gtk_container_add dialog-window vbox) + (#_gtk_widget_show vbox) + (with-cstrs ((destroy "destroy") + (activate "activate") + (prompt prompt)) + (#_gtk_signal_connect dialog-window destroy + gtk-get-string-dialog-closed info-ptr) + (#_gtk_widget_set_usize dialog-window 400 80) + (let* ((label (#_gtk_label_new prompt)) + (entry (#_gtk_entry_new))) + (#_gtk_box_pack_start vbox label #$TRUE #$TRUE 0) + (#_gtk_widget_show label) + (#_gtk_entry_set_max_length entry #x0000ffff) + (#_gtk_signal_connect entry activate gtk-get-string-dialog-get-string + info-ptr) + (#_gtk_box_pack_end vbox entry #$TRUE #$TRUE 0) + (#_gtk_widget_show entry) + (#_gtk_widget_show dialog-window)) + (process-wait "text entry" #'(lambda () (%null-ptr-p (%get-ptr info-ptr 0)))) + (let* ((strptr (%get-ptr info-ptr 4)) + (string ())) + (unless (%null-ptr-p strptr) + (unless (zerop (%get-byte strptr)) + (setq string (%get-cstring strptr)) + (#_g_free strptr))) + string))))) + +(defmethod step-prompt-for-string ((ui step-gtk-window-ui) prompt) + (gtk-get-string-from-user prompt)) + + +(setq *default-step-ui-class-name* 'step-gtk-window-ui) + + + Index: /branches/experimentation/later/source/examples/gtk2-clock.lisp =================================================================== --- /branches/experimentation/later/source/examples/gtk2-clock.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/gtk2-clock.lisp (revision 8058) @@ -0,0 +1,274 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CL-USER") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-interface-dir :gtk2)) + + +;;; Loading "libgnomeui-2.so" seems to be the easiest way to force all of +;;; its dependent libraries to be loaded +(open-shared-library "libgnomeui-2.so") + +(defloadvar *gdk-threads-inited* nil) +(defloadvar *gthread-inited* nil) + + +;;; Set things up so that GDK will use lisp locks internally. +;;; There are a few advantages to this, including the fact +;;; that lisp locks are that newfangled recursive kind (a thread +;;; that owns the lock can lock it agains, which is slightly +;;; better than waiting forever for it to be released.) +(defvar *gdk-lock* (make-lock)) + + +;;; Callbacks called by #_gdk_threads_enter and #_gdk_threads_leave. +(defcallback lock-gdk-lock (:void) + (grab-lock *gdk-lock*)) + +(defcallback unlock-gdk-lock (:void) + (release-lock *gdk-lock*)) + + +(defmacro with-gdk-lock-grabbed (&body body) + `(with-lock-grabbed (*gdk-lock*) + ,@body)) + +;;; gtk_signal_connect is a C macro. Emulate it. +(defmacro gtk-signal-connect (object name function user-data) + `(external-call "gtk_signal_connect_full" + :address ,object + :address ,name + :address ,function + :tkallbackarshal (%null-ptr) + :gpointer ,user-data + :tkestroyotify (%null-ptr) + :gint 0 + :gint 0 + :gulong)) + +(defcallback window-destroy-handler (:address window :void) + (declare (ignore window)) + (#_gtk_main_quit)) + + + +(defconstant single-float-pi (coerce pi 'single-float)) + +;;; A global alist mapping clock windows to their offscreen pixmaps. +(defvar *gtk-clock-window-pixmaps* ()) + + +(defun draw-tick-at (pixmap gc nhour cx cy radius) + (let* ((radians (/ (* single-float-pi nhour) 6.0)) + (sin-radians (sin radians)) + (cos-radians (cos radians)) + (95%radius (* radius .95))) + (#_gdk_draw_line pixmap gc + (+ cx (floor (* 95%radius sin-radians))) + (+ cy (floor (* 95%radius cos-radians))) + (+ cx (floor (* radius sin-radians))) + (+ cy (floor (* radius cos-radians)))))) + +;;; It seems like this can get called when the drawing area's in the +;;; process of being destroyed. Try not to segfault in that case. +(defcallback gtk-clock-repaint (:address data :signed-fullword) + (if (or (%null-ptr-p data) + (%null-ptr-p (pref data :tkidget.style))) + #$FALSE + (let* ((drawing-area data) + (radius 0) + (white-gc (pref drawing-area :tkidget.style.white_gc)) + (black-gc (pref drawing-area :tkidget.style.black_gc)) + (area-width (pref drawing-area :tkidget.allocation.width)) + (area-height (pref drawing-area :tkidget.allocation.height)) + (dradians) + (midx 0) + (midy 0) + (vbox (pref drawing-area :tkidget.parent)) + (window (pref vbox :tkidget.parent)) + (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*)))) + (rlet ((update-rect :dkectangle)) + ;; Clear pixmap (background image) + (#_gdk_draw_rectangle + pixmap white-gc #$TRUE 0 0 area-width area-height) + + ;; Calculate midpoint of clock. + (setq midx (ash area-width -1) + midy (ash area-height -1)) + + ;; Calculate radius + (setq radius (min midx midy)) + + ;; Draw circle + (#_gdk_draw_arc pixmap black-gc 0 0 0 + (+ midx midx) (+ midy midy) 0 (* 360 64)) + + ;; Draw tickmarks on clock face. + (do* ((nhour 1 (1+ nhour))) + ((> nhour 12)) + (draw-tick-at pixmap black-gc nhour midx midy radius)) + (multiple-value-bind (seconds minutes hours) + (get-decoded-time) + + ;; Get radians from seconds + (setq dradians (/ (* seconds single-float-pi) 30.0)) + + ;; Draw second hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.9 radius (sin dradians)))) + (- midy (floor (* 0.9 radius (cos dradians))))) + + ;; Get radians from minutes & seconds. + (setq dradians (+ (/ (* minutes single-float-pi) 30.0) + (/ (* seconds single-float-pi) 1800.0))) + + ;; Draw minute hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.7 radius (sin dradians)))) + (- midy (floor (* 0.7 radius (cos dradians))))) + + ;; Get radians from hours & minutes. + (setq dradians (+ (/ (* (mod hours 12) pi) 6.0) + (/ (* minutes pi) 360.0))) + + ;; Draw hour hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.5 radius (sin dradians)))) + (- midy (floor (* 0.5 radius (cos dradians))))) + + ;; Setup the update rectangle; this will force an expose event. + ;; The expose event handler will then copy the pixmap to the + ;; window. + + (setf (pref update-rect :dkectangle.x) 0 + (pref update-rect :dkectangle.y) 0 + (pref update-rect :dkectangle.width) area-width + (pref update-rect :dkectangle.height) area-height) + + ;; Draw the update rectangle. + (#_gtk_widget_draw drawing-area update-rect) + #$TRUE))))) + + +;;; This is called when the window's created and whenever it's +;;; resized. Create a new pixmap of appropriate +;;; size; free the old one (if it's non-null). +(defcallback gtk-clock-configure-event + (:address widget :address event :address window :signed-fullword) + (declare (ignore event)) + (let* ((pair (assoc window *gtk-clock-window-pixmaps*))) + (if (cdr pair) + (#_gdk_drawable_unref (cdr pair))) + (setf (cdr pair) + (#_gdk_pixmap_new (pref widget :tkidget.window) + (pref widget :tkidget.allocation.width) + (pref widget :tkidget.allocation.height) + -1))) + #$TRUE) + +;;; Copy the window's pixmap to the exposed region of the window. +(defcallback gtk-clock-expose-event + (:address widget :address event :address window :signed-fullword) + (let* ((state (pref widget :tkidget.state)) + (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*))) + (fg-gc (pref widget :tkidget.style.fg_gc)) + (x (pref event :dkventxpose.area.x)) + (y (pref event :dkventxpose.area.y)) + (width (pref event :dkventxpose.area.width)) + (height (pref event :dkventxpose.area.height))) + (#_gdk_draw_drawable + (pref widget :tkidget.window) + (%get-ptr fg-gc (ash state target::word-shift)) + pixmap + x y + x y + width height) + #$FALSE)) + +;;; When the window's destroyed, delete its entry from the +;;; *gtk-clock-window-pixmaps* alist. + +(defcallback gtk-clock-close (:address window :void) + (let* ((pair (assoc window *gtk-clock-window-pixmaps*))) + (if pair + (if (null (setq *gtk-clock-window-pixmaps* + (delete pair *gtk-clock-window-pixmaps*))) + (#_gtk_main_quit)) + (break "No entry for window!")))) + +(defun gtk-clock () + (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL)) + (vbox (#_gtk_vbox_new #$FALSE 0))) + (push (cons window nil) *gtk-clock-window-pixmaps*) + (#_gtk_container_add window vbox) + (#_gtk_widget_show vbox) + (let* ((drawing-area (#_gtk_drawing_area_new))) + (#_gtk_drawing_area_size drawing-area 200 200) + (#_gtk_box_pack_start vbox drawing-area #$TRUE #$TRUE 0) + (#_gtk_widget_show drawing-area) + (with-cstrs ((expose-name "expose_event") + (configure-name "configure_event") + (destroy-name "destroy") + (window-title + "Takes a licking. Keeps on ticking.")) + (#_gtk_window_set_title window window-title) + (gtk-signal-connect drawing-area + expose-name + gtk-clock-expose-event + window) + (gtk-signal-connect drawing-area + configure-name + gtk-clock-configure-event + window) + (gtk-signal-connect window + destroy-name + gtk-clock-close + (%null-ptr))) + (#_gtk_widget_show window) + (#_gtk_timeout_add 1000 gtk-clock-repaint drawing-area) + (values)))) + + +(defun main (&rest args) + (unless *gthread-inited* + (#_g_thread_init (%null-ptr)) + (setq *gthread-inited* t)) + (unless *gdk-threads-inited* + ;; Tell GDK to use our locks. + (#_gdk_threads_set_lock_functions lock-gdk-lock unlock-gdk-lock) + (#_gdk_threads_init) + (setq *gdk-threads-inited* t)) + (process-run-function "GTK Event thread" + #'(lambda () + (#_gdk_threads_enter) + (rlet ((argc :int) + (argvp (:* t))) + (with-string-vector (argv args) + (setf (pref argc :int) (length args) + (%get-ptr argvp ) argv) + (#_gtk_init argc argvp))) + (gtk-clock) + (#_gtk_main) + (#_gdk_threads_leave)))) + +;;; calling (MAIN) starts an event thread and displays a clock. +;;; subsequent calls to (GTK-CLOCK) display additional clocks, +;;; if/when they can get a word in edgewise ... Index: /branches/experimentation/later/source/examples/hons-example.lisp =================================================================== --- /branches/experimentation/later/source/examples/hons-example.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/hons-example.lisp (revision 8058) @@ -0,0 +1,221 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2005 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CL-USER") + +;;; A sample HONS (hash-consing) implementation, based on the +;;; primitives defined in "ccl:library;hash-cons.lisp". + +(defun largest-prime-less-than-or-equal-to (n) + (flet ((primep (n) + (or (eql n 1) + (eql n 2) + (and (oddp n) + (let* ((max (isqrt n))) + (do* ((i 3 (+ i 2))) + ((> i max) t) + (when (zerop (mod n i)) + (return nil)))))))) + (if (primep n) + n + (do* ((m (if (oddp n) (- n 2) (- n 1)) (- m 2))) + ((primep m) m))))) + + +;;; A "hons-table" just represents a range of indices in a +;;; static memory region dedicated to hash-consing (and +;;; a little information about the contents of that region.) +(defstruct (hons-table (:constructor %make-hons-table)) + start-index ;lower inclusive index + end-index ;upper exclusive index + size ;(<= size (- end-index start-index)) + max ;maximum "full" point + (used 0) ;current number of used pairs + ) + +(defmethod print-object ((ht hons-table) stream) + (print-unreadable-object (ht stream :type t :identity t) + (format stream "indices ~d-~d, used ~d/~d" + (hons-table-start-index ht) + (hons-table-end-index ht) + (hons-table-used ht) + (hons-table-max ht)))) + +;;; The "active" HONS table is the CAR of this list. +(defparameter *all-hons-tables* () + "A list of all hons tables, maintained in reverse order of creation (e.g., the CAR of this list is the most recently created.)") + +(defparameter *hons-table-max-full-ratio* .85 + "Controls how full a hons table can get.") + +;;; Try to allocate a new HONS table, which describes a newly +;;; allocated range of indices in HONS space. If successful, +;;; that new table gets pushed onto the front of *ALL-HONS-TABLES* +;;; and returned. +(defun make-hons-table (size &optional (max-full-ratio + *hons-table-max-full-ratio*)) + (check-type size (and fixnum unsigned-byte)) + (setq size (largest-prime-less-than-or-equal-to size)) + (let* ((current (openmcl-hons:hons-space-size)) + (new (setf (openmcl-hons:hons-space-size) + (+ current (the fixnum size))))) + (declare (fixnum current new)) + (if (>= (- new current) size) + (let* ((table (%make-hons-table :start-index current + :end-index new + :size size + :max (floor (* size max-full-ratio))))) + (push table *all-hons-tables*) + table) + ;; As of 12/30/05, there's a slight possibility that + ;; #'(setf opencl-hons:hons-space-size) can fail + ;; even though address-space/memory are available. + ;; (The problem has to do with the way that CCL:WITHOUT-GCING + ;; works; if the GC is disabled, we can't move things around, + ;; but there isn't currently an easy way to detect that.) + (error "Couldn't increase hons space size by ~d pairs" size)))) + +(defun hons-hash-string (s) + (let* ((h 0)) + (declare (fixnum h)) + (dotimes (i (length s) (logand h most-positive-fixnum)) + (setq h (+ (the fixnum (* 4999 h)) (the fixnum (ccl::%scharcode s i))))))) + +;;; Exactly what types of objects can go in the CAR or CDR of +;;; a HONS table is application dependent, but it's reasonable +;;; to insist that all CONSes are HONSes. + + +(defun hash-pair-for-honsing (car cdr) + ;; This often calls CCL::%%EQLHASH, which is (as one might + ;; assume) a primitive used with EQL hash tables. It tries + ;; to "scramble the bits" a little, so that "related" keys + ;; (like numerically adjacent integers) hash to unrelated + ;; values. + (flet ((hash-for-honsing (thing) + (logand + (the fixnum + (etypecase thing + (cons (let* ((idx (openmcl-hons::honsp thing))) + (if idx + (ccl::%%eqlhash idx) + (error "~s is not HONSP." thing)))) + (fixnum (ccl::%%eqlhash thing)) + ((or bignum single-float double-float) + (ccl::%%eqlhash thing)) + (null target::nil-value) + (symbol (hons-hash-string (symbol-name thing))) + (simple-string (hons-hash-string thing)) + ((complex rational) (ccl::%%eqlhash thing)))) + most-positive-fixnum))) + (the fixnum + (+ (the fixnum (* 37 (the fixnum (hash-for-honsing car)))) + (the fixnum (* 33 (the fixnum (hash-for-honsing cdr)))))))) + +(defparameter *hons-probes* 0) +(defparameter *hons-secondary-probes* 0) + + +(defun hons-table-get (ht hash car cdr) + "Tries to find a HONS with matching (EQL) CAR and CDR in the hash table HT. +Returns a CONS if a match is found, a fixnum index otherwise." + (declare (fixnum hash) (optimize (speed 3))) + (incf *hons-probes*) + (do* ((size (hons-table-size ht)) + (start (hons-table-start-index ht)) + (end (+ start size)) + (idx (+ start (the fixnum (ccl::fast-mod hash size))) (+ idx 1)) + (first-deleted-index nil)) + () + (declare (fixnum start end size idx)) + (if (>= idx end) + (decf idx size)) + (let* ((hcar (openmcl-hons:hons-space-ref-car idx)) + (hcdr (openmcl-hons:hons-space-ref-cdr idx))) + (cond ((and (eql hcar car) (eql hcdr cdr)) + (return (openmcl-hons:hons-from-index idx))) + (t + (if (eq hcar (openmcl-hons:hons-space-deleted-marker)) + (unless first-deleted-index + (setq first-deleted-index idx)) + (if (eq hcar (openmcl-hons:hons-space-free-marker)) + (return (or first-deleted-index idx)))))) + (incf *hons-secondary-probes*)))) + + +;;; These values are entirely arbitrary. + +(defparameter *initial-hons-table-size* (ash 100 20) + "The number of pairs to allocate in the initially allocated hons table.") + +(defparameter *secondary-hons-table-size* (ash 25 20) + "The number of pairs to allocate in subsequently allocated hons tables.") + +;;; Find HONS (a statically allocated CONS cell) with matching CAR and +;;; CDR, or create a new one. +(defun hons (car cdr) + (let* ((tables *all-hons-tables*) + (active-table (if tables + (car tables) + (make-hons-table *initial-hons-table-size*))) + (hash (hash-pair-for-honsing car cdr)) + (h (hons-table-get active-table hash car cdr))) + (declare (fixnum hash)) + (cond ((consp h) h) + ((< (hons-table-used active-table) + (hons-table-max active-table)) + (incf (hons-table-used active-table)) + (openmcl-hons:hons-space-cons h car cdr)) + (t (error "Active hons table is full."))))) + + + +;;; Some utilities. + +(defun discard-active-hons-table () + (let* ((table (pop *all-hons-tables*))) + (when table + (setf (openmcl-hons:hons-space-size) (hons-table-start-index table) + (hons-table-start-index table) nil) + t))) + + +(defun discard-all-hons-tables () + (dolist (table *all-hons-tables*) + ;; Invalidate the table. + (setf (hons-table-start-index table) nil)) + (setq *all-hons-tables* nil) + (setf (openmcl-hons:hons-space-size) 0) + t) + +#|| + +(defvar *test-var*) + +(defun test (n) + (setq *test-var* nil) + (loop for i from 1 to n do + (print i) + (loop for i from 1 to 1000000 do + (setq *test-var* (hons i *test-var*))))) + + +||# + + + + + Index: /branches/experimentation/later/source/examples/jni.lisp =================================================================== --- /branches/experimentation/later/source/examples/jni.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/jni.lisp (revision 8058) @@ -0,0 +1,29 @@ +(eval-when (:compile-toplevel :execute) + (use-interface-dir :java)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (open-shared-library "/System/Library/Frameworks/JavaVM.framework/JavaVM")) + +(defun %init-java-vm (&rest args) + (declare (dynamic-extent args)) + (let* ((nargs (length args))) + (rlet ((initargs :avanitrgs) + (env (* :nv)) + (vm (* :ava))) + (%stack-block ((options (* nargs (record-length :avaption)))) + (do* ((i 0 (1+ i)) + (args args (cdr args)) + (p options (%inc-ptr p (record-length :avaption)))) + ((= i nargs)) + (setf (pref p :avaption.optiontring) + (car args))) + (setf (pref initargs :avanitrgs.version) #$JNI_VERSION_1_2 + (pref initargs :avanitrgs.nptions) nargs + (pref initargs :avanitrgs.options) options + (pref initargs :avanitrgs.ignorenrecognized) #$JNI_TRUE) + (let* ((result (#_JNI_CreateJavaVM :monitor-exception-ports vm env initargs))) + (if (>= result 0) + (values (%get-ptr vm) (%get-ptr env)) + (error "Can't create Java VM: result = ~d" result))))))) + + Index: /branches/experimentation/later/source/examples/opengl-ffi.lisp =================================================================== --- /branches/experimentation/later/source/examples/opengl-ffi.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/opengl-ffi.lisp (revision 8058) @@ -0,0 +1,144 @@ +;;; Example openmcl FFI by hamlink +;;; +;;; 2d Gasket example taken from +;;; "Interactive Computer Graphics: +;;; A Top-Down Approach with OpenGL" by Ed Angel + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:use-interface-dir :GL)) + +(defpackage "2DGASKET") +(defpackage "OPENGL" + (:nicknames :opengl :gl) + (:export "INITIALIZE-GLUT" + "WITH-MATRIX-MODE")) + +;;; Opening "libglut.so" should also open "libGL.so", "libGLU.so", +;;; and other libraries that they depend on. +;;; It seems that it does on some platforms and not on others; +;;; explicitly open what we require here. +(eval-when (:compile-toplevel :load-toplevel :execute) + #+linux-target + (dolist (lib '("libGL.so" "libGLU.so" "libglut.so")) + (open-shared-library lib)) + #+darwin-target + (open-shared-library "GLUT.framework/GLUT") + ) + +(in-package :opengl) + +;; glut complains if it's initialized redundantly +(let ((glut-initialized-p nil)) + (defun initialize-glut () + (let ((command-line-strings (list "openmcl"))) + (when (not glut-initialized-p) + (ccl::with-string-vector (argv command-line-strings) + (rlet ((argvp (* t)) ; glutinit takes (* (:signed 32)) and (* (* (:unsigned 8))) + (argcp :signed)) ; so why are these declared as (* t) and :signed? + (setf (%get-long argcp) (length command-line-strings) + (%get-ptr argvp) argv) + (#_glutInit argcp argvp))) + (setf glut-initialized-p t)))) + ;; When a saved image is restarted, it needs to know that glut + ;; hasn't been initialized yet. + (defun uninitialize-glut () + (setf glut-initialized-p nil)) + ) + +(pushnew #'uninitialize-glut ccl::*save-exit-functions* + :key #'ccl::function-name) + +(defparameter *matrix-mode* #$GL_MODELVIEW) +(defmacro with-matrix-mode (mode &body body) + `(unwind-protect + (let ((*matrix-mode* ,mode)) + (#_glMatrixMode *matrix-mode*) + ,@body) + (#_glMatrixMode *matrix-mode*))) + +(in-package :2dgasket) + +(defun myinit () + (#_glClearColor 1.0 1.0 1.0 0.0) ; white background + (#_glColor3f 1.0 0.0 0.0) ; red pen color + + (opengl:with-matrix-mode #$GL_PROJECTION + (#_glLoadIdentity) + (#_gluOrtho2D 0.0D0 500.0D0 0.0D0 500.0D0)) + + ; (#_glEnable #$GL_DEPTH_TEST) ; for 3d only + + (#_srand (#_time (%null-ptr))) + ) + +;; 2d gasket using points + +(ccl::defcallback display-cb (:void) + (let ((bounds #2a((0.0 0.0) (250.0 500.0) (500.0 0.0))) + (point #(75.0 50.0))) + (#_glClear #$GL_COLOR_BUFFER_BIT) + (#_glBegin #$GL_POINTS) + (dotimes (i 5000) + (let ((j (random 3))) + (setf (aref point 0) (/ (+ (aref point 0) (aref bounds j 0)) 2.0) + (aref point 1) (/ (+ (aref point 1) (aref bounds j 1)) 2.0)) + (#_glVertex2f (aref point 0) (aref point 1)))) + (#_glEnd) + (#_glFlush))) + +(defun main () ; no int argc or char **argv + (opengl:initialize-glut) + (#_glutInitDisplayMode (logior #$GLUT_RGB + #$GLUT_SINGLE + #+ignore #$GLUT_DEPTH)) + (#_glutInitWindowSize 500 500) + (#_glutInitWindowPosition 0 0) + (ccl::with-cstrs ((title "simple OpenGL example")) + (#_glutCreateWindow title)) + (#_glutDisplayFunc display-cb) + (myinit) +; It appears that glut provides no mechanism for doing the event loop +; yourself -- if you want to do that, you should use some other set of +; libraries and make your own GUI toolkit. + + (#_glutMainLoop) ; this never returns and interferes w/scheduling + ) + + +;;; With native threads, #_glutMainLoop doesn't necessarily interfere +;;; with scheduling: we can just run all of the OpenGL code in a separate +;;; thread (which'll probably spend most of its time blocked in GLUT's +;;; event loop.) On OSX, we need to use an undocumented API or two +;;; to ensure that the thread we're creating is seen as the "main" +;;; event handling thread (that's what the code that sets the current +;;; thread's CFRunLoop to the main CFRunLoop does.) +#+OpenMCL-native-threads +(ccl:process-run-function + "OpenGL main thread" + #'(lambda () + #+darwin-target + (progn + ;;; In OSX, a "run loop" is a data structure that + ;;; describes how event-handling code should block + ;;; for events, timers, and other event sources. + ;;; Ensure that this thread has a "current run loop". + ;;; (Under some circumstances, there may not yet be + ;;; a "main" run loop; setting the "current" run loop + ;;; ensures that a main run loop exists.) + (ccl::external-call "_CFRunLoopGetCurrent" :address) + ;;; Make the current thread's run loop be the "main" one; + ;;; only the main run loop can interact with the window + ;;; server. + (ccl::external-call + "__CFRunLoopSetCurrent" + :address (ccl::external-call "_CFRunLoopGetMain" :address)) + ;;; Set the OSX Window Server's notion of the name of the + ;;; current process. + (%stack-block ((psn 8)) + (ccl::external-call "_GetCurrentProcess" :address psn) + (with-cstrs ((name "simple OpenGL example")) + (ccl::external-call "_CPSSetProcessName" :address psn :address name)))) + (main))) + +; (main) + Index: /branches/experimentation/later/source/examples/rubix/.cvsignore =================================================================== --- /branches/experimentation/later/source/examples/rubix/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/examples/rubix/blocks.lisp =================================================================== --- /branches/experimentation/later/source/examples/rubix/blocks.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/blocks.lisp (revision 8058) @@ -0,0 +1,410 @@ +(in-package :cl-user) + +(defparameter *cube* nil) + +(defparameter *camera-pos* #(10.0 5.0 12.0)) + +(defparameter *selection-buffer-size* 256) + +;; some things have no scale or rotation, such as point light sources +;; (note lights use a 4d vector to hold both positoin and pointsourceness) +(defclass positioned-object () + ((location :initform nil :initarg :location :accessor location)) + (:default-initargs :location (make-array 3 :initial-element 0.0))) + +(defmethod move-relative ((obj positioned-object) v) + (add-vectors (location obj) v (location obj)) + (location obj)) +(defmethod move-relative-3 ((obj positioned-object) dx dy dz) + (incf (elt (location obj) 0) dx) + (incf (elt (location obj) 1) dy) + (incf (elt (location obj) 2) dz) + (location obj)) +(defmethod move-absolute ((obj positioned-object) p) + (dotimes (i 3) (setf (elt (location obj) i) (elt p i))) + (location obj)) +(defmethod move-absolute-3 ((obj positioned-object) x y z) + (setf (elt (location obj) 0) x + (elt (location obj) 1) y + (elt (location obj) 2) z) + (location obj)) + +(defmethod gl-translate ((obj positioned-object)) + (#_glTranslatef (elt (location obj) 0) + (elt (location obj) 1) + (elt (location obj) 2))) + +(defclass rotated-object () + ((quaternion :initform nil :initarg :quaternion :accessor quaternion)) + (:default-initargs :quaternion (make-instance 'quaternion))) + +(defmethod rotate-relative ((obj rotated-object) quaternion) + ;; recall mulquats applies q2's rotation first... + (mulquats quaternion (quaternion obj) (quaternion obj)) + (quaternion obj)) +(defmethod rotate-absolute ((obj rotated-object) quaternion) + (setf (w (quaternion obj)) (w quaternion)) + (dotimes (i 3) + (setf (elt (xyz (quaternion obj)) i) (elt quaternion i))) + (quaternion obj)) + +(defmethod gl-rotate ((obj rotated-object)) + (let ((axis-angle (quat->axis-angle (quaternion obj)))) + (#_glRotatef (cdr axis-angle) + (elt (car axis-angle) 0) + (elt (car axis-angle) 1) + (elt (car axis-angle) 2)))) + +(defclass scaled-object () + ((dilation :initform nil :initarg :dilation :accessor dilation)) + (:default-initargs :dilation (make-array 3 :initial-element 1.0))) + +(defmethod gl-scale ((obj scaled-object)) + (#_glScalef (elt (dilation obj) 0) + (elt (dilation obj) 1) + (elt (dilation obj) 2))) + +(defclass transformed-object (positioned-object + rotated-object + scaled-object) + ()) + +(defmacro with-transformation ((transformed-object) &body body) + (let ((tobj-sym (gensym))) + `(let ((,tobj-sym ,transformed-object)) + (#_glPushMatrix) + (gl-translate ,tobj-sym) + (gl-rotate ,tobj-sym) + (gl-scale ,tobj-sym) + ,@body + (#_glPopMatrix)))) + +(defmethod render ((obj transformed-object)) ; should this be on something else? + (#_glMatrixMode #$GL_MODELVIEW) + (with-transformation (obj) + (render-children obj))) + +(defclass block (transformed-object) + (;; need to generate matrices of this form so that copy-ivector-etc will work + (vertices :initform (coerce + (list (make-array 3 :initial-contents '(-0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 -0.5) + :element-type 'single-float)) + 'vector) + :initarg :vertices :accessor vertices + ;; :allocation :class + ))) + +;; I expect that especially with the FFI overhead, one call to render +;; a static object's prefabbed display list will beat out a lot of +;; calls to render the various portions... this will be an interesting +;; conversionn and test going from code to DL, and good prep for +;; moving from DL-creating code to DL file readers +#+ignore +(defmethod render-children ((obj block)) + (let ((curve-radius 0.1)) ; 90-degree curve in 3 sections for edges and for corners + ;; strip for faces 0134 and their edges + ;; strip for face 2 and edges to 0 and 3 + ;; strip for face 5 and edges to 0 and 3 + ;; edges 15, 54, 42, and 21 + ;; corner + )) + +(defmethod render-children ((obj block)) + (flet ((norm (axis) (#_glNormal3f (aref axis 0) (aref axis 1) (aref axis 2))) + (material (color) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 double-floats + (ccl::%copy-ivector-to-ptr color + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glMaterialfv #$GL_FRONT_AND_BACK + #$GL_AMBIENT_AND_DIFFUSE + foreign-float-vector))) + (quad (a b c d) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) a) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) b) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) c) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) d) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + t)) + (opengl:with-gl (#$GL_QUADS) + (norm *x-axis*) (material *hel-orange*) (quad 1 2 6 5) + (norm *y-axis*) (material *hel-yellow*) (quad 2 3 7 6) + (norm *z-axis*) (material *hel-green*) (quad 0 3 2 1) + (norm *neg-x-axis*) (material *hel-red*) (quad 0 4 7 3) + (norm *neg-y-axis*) (material *hel-white*) (quad 0 1 5 4) + (norm *neg-z-axis*) (material *hel-blue*) (quad 4 5 6 7)))) + +(defclass rubix-cube (transformed-object) + ((blocks :initform nil :initarg :blocks :accessor blocks) + (faces :initform nil :initarg :faces :accessor faces) + (faces-axes :initform (coerce (list *neg-x-axis* *neg-y-axis* *neg-z-axis* + *x-axis* *y-axis* *z-axis*) 'vector) + :initarg :faces-axes :reader faces-axes + ;; :allocation :class + ) + (face-turning-p :initform nil :initarg :face-turning-p :accessor face-turning-p) + (turning-face :initform nil :initarg :turning-face :accessor turning-face) + (face-theta :initform nil :initarg :face-theta :accessor face-theta) + ;; vertices for rendering full cube's faces for selection + (vertices :initform (coerce + (list (make-array 3 :initial-contents '(-0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 -0.5) + :element-type 'single-float)) + 'vector) + :initarg :vertices :reader vertices + ;; :allocation :class + )) + (:default-initargs + :blocks (let ((list nil)) + (loop for x from -1.0 to 1.0 do + (loop for y from -1.0 to 1.0 do + (loop for z from -1.0 to 1.0 do + (push (make-instance 'block + :location (coerce (list (/ x 3.0) + (/ y 3.0) + (/ z 3.0)) 'vector) + :dilation (coerce (list (/ 1.0 3.0) + (/ 1.0 3.0) + (/ 1.0 3.0)) 'vector)) + list)))) + (coerce list 'vector)))) + +(defparameter *child-positions* (let ((list nil)) + (loop for x from -1.0 to 1.0 do + (loop for y from -1.0 to 1.0 do + (loop for z from -1.0 to 1.0 do + (push (coerce (list (/ x 3.0) + (/ y 3.0) + (/ z 3.0)) 'vector) + list)))) + (coerce list 'vector))) + +;; blocks in faces start at a corner, go clockwise around the face, +;; and finish in the center; blocks in the cube are numbered to +;; correspond to *child-positions*; faces that share blocks are +;; associated in faces-neighbors -- all 3 of these variables depend on +;; each other +(defparameter *initial-blocks-in-faces* #2a((0 1 2 5 8 7 6 3 4) + (0 9 18 19 20 11 2 1 10) + (0 3 6 15 24 21 18 9 12) + (26 23 20 19 18 21 24 25 22) + (26 25 24 15 6 7 8 17 16) + (26 17 8 5 2 11 20 23 14))) + +(defmethod shared-initialize :after ((obj rubix-cube) slot-names &key) + (declare (ignore slot-names)) + (setf (faces obj) (make-array (list 6 9))) + (dotimes (face 6) + (dotimes (blok 9) + (setf (aref (faces obj) face blok) + (aref (blocks obj) (aref *initial-blocks-in-faces* face blok)))))) + +(let ((faces-neighbors #2a((1 5 4 2) + (2 3 5 0) + (0 4 3 1) + (5 1 2 4) + (3 2 0 5) + (4 0 1 3)))) + (defun faces-neighbor (face neighbor) + (aref faces-neighbors face neighbor)) + (defun faces-index-from-neighbor (face neighbor) + (loop for i from 0 to 3 do + (when (= face (faces-neighbor (faces-neighbor face neighbor) i)) + (return i)))) + ) + +(defmethod turnfaceclockwise ((cube rubix-cube) face &aux temp) + (with-slots (faces) cube + ;; rotate blocks through adjacent faces + (dotimes (neighbor 4) + (let* ((neighbors-face (faces-neighbor face neighbor)) + (my-index (faces-index-from-neighbor face neighbor)) + (my-block-index (* 2 my-index)) + (his-new-block-index (* 2 (mod (+ neighbor 3) 4)))) + (setf (aref faces neighbors-face (mod my-block-index 8)) + (aref faces face (mod (+ 2 his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (1+ my-block-index) 8)) + (aref faces face (mod (1+ his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (+ 2 my-block-index) 8)) + (aref faces face (mod his-new-block-index 8))))) + ;; rotate blocks in this face + (setf temp (aref faces face 0) + (aref faces face 0) (aref faces face 6) + (aref faces face 6) (aref faces face 4) + (aref faces face 4) (aref faces face 2) + (aref faces face 2) temp + temp (aref faces face 1) + (aref faces face 1) (aref faces face 7) + (aref faces face 7) (aref faces face 5) + (aref faces face 5) (aref faces face 3) + (aref faces face 3) temp) + ;; update positions and orientation of blocks in this face + (dotimes (i 9) + (move-absolute (aref faces face i) + (elt *child-positions* (aref *initial-blocks-in-faces* face i))) + (rotate-relative (aref faces face i) + (axis-angle->quat (aref (faces-axes cube) face) + 90.0))) + )) + +(defmethod turnfacecounterclockwise ((cube rubix-cube) face &aux temp) + (with-slots (faces) cube + ;; rotate blocks through adjacent faces + (dotimes (neighbor 4) + (let* ((neighbors-face (faces-neighbor face neighbor)) + (my-index (faces-index-from-neighbor face neighbor)) + (my-block-index (* 2 my-index)) + (his-new-block-index (* 2 (mod (+ neighbor 1) 4)))) + (setf (aref faces neighbors-face (mod my-block-index 8)) + (aref faces face (mod (+ 2 his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (1+ my-block-index) 8)) + (aref faces face (mod (1+ his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (+ 2 my-block-index) 8)) + (aref faces face (mod his-new-block-index 8))))) + ;; rotate blocks in this face + (setf temp (aref faces face 0) + (aref faces face 0) (aref faces face 2) + (aref faces face 2) (aref faces face 4) + (aref faces face 4) (aref faces face 6) + (aref faces face 6) temp + temp (aref faces face 1) + (aref faces face 1) (aref faces face 3) + (aref faces face 3) (aref faces face 5) + (aref faces face 5) (aref faces face 7) + (aref faces face 7) temp) + ;; update positions and orientation of blocks in this face + (dotimes (i 9) + (move-absolute (aref faces face i) + (elt *child-positions* (aref *initial-blocks-in-faces* face i))) + (rotate-relative (aref faces face i) + (axis-angle->quat (aref (faces-axes cube) face) + -90.0))) + )) + +(defmethod render-children ((obj rubix-cube)) + (flet ((in-face-p (face blok) + (dotimes (i 9) + (when (eq (aref (blocks obj) blok) + (aref (faces obj) face i)) + (return t))))) + (cond ((not (face-turning-p obj)) + (dotimes (blok 27) + (render (aref (blocks obj) blok)))) + (t + (dotimes (blok 27) + (unless (in-face-p (turning-face obj) blok) + (render (aref (blocks obj) blok)))) + (opengl:with-rotation ((face-theta obj) + (aref (faces-axes obj) (turning-face obj))) + (dotimes (blok 9) + (render (aref (faces obj) (turning-face obj) blok)))))))) + + +(defmethod render-for-selection ((objc rubix-cube) picked-point) + (let ((gl-uint-size (ccl::foreign-size :uint :bytes)) ; 4, as it turns out... + (selection-buffer-size 256)) + (ccl::%stack-block ((selection-buffer (* gl-uint-size selection-buffer-size))) + (#_glSelectBuffer selection-buffer-size selection-buffer) + (let (;; FYI - this loses a lot of structure and becomes a lot + ;; longer in C++ for lack of macros + (hits (opengl:with-render-mode (#$GL_SELECT) + (#_glInitNames) + (#_glPushName 0) + (opengl:with-culling (#$GL_FRONT) + ;; set up the modified camera looking around the mouse's region + (opengl:with-matrix-mode (#$GL_PROJECTION) + (opengl:with-matrix (t) + (#_glFrustum -0.01d0 0.01d0 -0.01d0 0.01d0 10.0d0 20.0d0) + (opengl:with-matrix-mode (#$GL_MODELVIEW) + (opengl:with-matrix (t) + (mylookat *camera-pos* picked-point *y-axis*) + ;; NOW render the cube like we were doing before + (opengl:with-matrix-mode (#$GL_MODELVIEW) + (with-transformation (objc) + (render-children-for-selection objc))))))) + (#_glFlush))))) + (when (and (numberp hits) + (< 0 hits)) + ;; the first hit name is at selectBuf[3], though i don't recall why + (ccl::%get-unsigned-long selection-buffer (* 3 4))))))) + +(defmethod render-children-for-selection ((objc rubix-cube)) + (flet ((norm (axis) (#_glNormal3f (aref axis 0) (aref axis 1) (aref axis 2))) + (material (color) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr color + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glMaterialfv #$GL_FRONT_AND_BACK + #$GL_AMBIENT_AND_DIFFUSE + foreign-float-vector))) + (quad (a b c d) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) a) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) b) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) c) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) d) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + t)) + (#_glLoadName 0) + (opengl:with-gl (#$GL_QUADS) + (norm *x-axis*) (material *hel-orange*) (quad 1 2 6 5)) + (#_glLoadName 1) + (opengl:with-gl (#$GL_QUADS) + (norm *y-axis*) (material *hel-yellow*) (quad 2 3 7 6)) + (#_glLoadName 2) + (opengl:with-gl (#$GL_QUADS) + (norm *z-axis*) (material *hel-green*) (quad 0 3 2 1)) + (#_glLoadName 3) + (opengl:with-gl (#$GL_QUADS) + (norm *neg-x-axis*) (material *hel-red*) (quad 0 4 7 3)) + (#_glLoadName 4) + (opengl:with-gl (#$GL_QUADS) + (norm *neg-y-axis*) (material *hel-white*) (quad 0 1 5 4)) + (#_glLoadName 5) + (opengl:with-gl (#$GL_QUADS) + (norm *neg-z-axis*) (material *hel-blue*) (quad 4 5 6 7)))) Index: /branches/experimentation/later/source/examples/rubix/lights.lisp =================================================================== --- /branches/experimentation/later/source/examples/rubix/lights.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/lights.lisp (revision 8058) @@ -0,0 +1,79 @@ +(in-package :cl-user) + +;; ah, lights, one of my favorite subjects in OpenGL -- because they way +;; they work when you're using C++ stinks! I seem to recall i have extensive +;; discussions of how i would rather deal with TL&M if i was using lisp in +;; one of my code files somewhere, but first let me get it working then i can +;; get it working properly + +(defclass light () + ((lightid :initform 0 :initarg :lightid :accessor lightid) + (on-p :initform nil :accessor on-p) + (pointsourcep :initform nil :initarg :pointsourcep :accessor pointsourcep) + (location :initform nil :initarg :location :accessor location) + (ambient :initform nil :initarg :ambient :accessor ambient) + (diffuse :initform nil :initarg :diffuse :accessor diffuse) + (specular :initform nil :initarg :specular :accessor specular)) + (:default-initargs :location (make-array 4 :initial-element 0.0 ; lights are special! + :element-type 'single-float) + :ambient (make-array 4 :initial-element 0.0 + :element-type 'single-float) + :diffuse (make-array 4 :initial-element 0.0 + :element-type 'single-float) + :specular (make-array 4 :initial-element 0.0 + :element-type 'single-float))) + +(defmethod on ((light light)) + (#_glEnable (lightid light)) + (setf (on-p light) t)) +(defmethod off ((light light)) + (#_glDisable (lightid light)) + (setf (on-p light) nil)) + +(defmethod setlocation ((light light) pos) + (dotimes (i 3) (setf (elt (location light) i) (elt pos i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (location light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_POSITION foreign-float-vector))) +(defmethod setpointsource ((light light) bool) + (setf (pointsourcep light) (if bool t nil) ; <- don't hang on to non-nils + (elt (location light) 3) (if bool 1.0 0.0)) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (location light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_POSITION foreign-float-vector))) + +(defmethod setambient ((light light) color) + (dotimes (i 4) (setf (elt (ambient light) i) (elt color i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (ambient light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_AMBIENT foreign-float-vector))) +(defmethod setdiffuse ((light light) color) + (dotimes (i 4) (setf (elt (diffuse light) i) (elt color i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (diffuse light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_DIFFUSE foreign-float-vector))) +(defmethod setspecular ((light light) color) + (dotimes (i 4) (setf (elt (specular light) i) (elt color i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (specular light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_SPECULAR foreign-float-vector))) Index: /branches/experimentation/later/source/examples/rubix/loader.lisp =================================================================== --- /branches/experimentation/later/source/examples/rubix/loader.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/loader.lisp (revision 8058) @@ -0,0 +1,15 @@ +(in-package :cl-user) + +(require "COCOA") + +(let* ((containing-dir (make-pathname :directory (pathname-directory *load-truename*) :defaults nil))) + (flet ((load-relative (path) + (load (merge-pathnames path containing-dir)))) + (load-relative "opengl.lisp") + (load-relative "vectors.lisp") + (load-relative "lights.lisp") + (load-relative "blocks.lisp") + (load-relative "rubix.lisp"))) + + +; (run-rubix-demo) Index: /branches/experimentation/later/source/examples/rubix/opengl.lisp =================================================================== --- /branches/experimentation/later/source/examples/rubix/opengl.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/opengl.lisp (revision 8058) @@ -0,0 +1,173 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:use-interface-dir :GL)) + +;;; Cocoa-based OpenGL package, for handy macros and classes of common +;;; things like transformations, lights, cameras, quaternions, etc. +;;; (note not all of this has been consolidated into this package yet) + +#| + +To use this functionality from cocoa, subclass NSOpenGLView, +specialize drawRect on your class to render whatever you like, +and make an intance in a window. + +|# + +#| +;;; Some design notes for OpenGL programming in lisp... + +OpenGL is a very stateful API. with-X macros are invaluable for +managing OpenGL's stacks and modes. + +The rubix demo is not set up this way, but really the main +objects in a scene need to contain references to their structure, +so that the structure can be reused between identical objects. +For large objects that are not always going to be present, the +structure could be compiled into a fasl and loaded only when +necessary using a sentinel in place of the structure reference. + +Objects should capture the instance-specific state of objects in +a scene and be used to parameterize the drawing of skeleton-based +things. This can get tricky, but generic functions that draw +skeleton structures when passed specific data about the object's +state and the object's structure are probably the way to go. + +Display lists are handy for static models. Something that loaded +easily-edited display list descriptions and turned them into fasl +data that rebuilt the display lists would be useful... if I can +find some EBNF and regexp forms my parser would build the ASTs +that could be turned into objects easily enough and from there +fasl data is easy to generate and save. If the file created a +fasl that set a hash entry from a structure id to a usable opengl +display list that would be good. A function that requested a +structure by id that loaded a file if there was no hash entry +would be slick. + +Since this is lisp, it should be possible to create a display +list or an analogous lexical closure depending on what you want +from the same model information (to be later rendered as a static +object or rendered with a instance-state-driven function). I +don't know how many DLs OpenGL can have at one time or how big +they can be, it'd be good to know. + +|# + +(defpackage "OPENGL" + (:nicknames :opengl :gl) + (:export ;; Cocoa helpers + "WITH-OPENGL-CONTEXT" + "NEW-PIXEL-FORMAT" + ;; OpenGL helpers + "WITH-MATRIX-MODE" + "WITH-RENDER-MODE" + "WITH-ROTATION" + "WITH-GL" + "WITH-CULLING" + "WITH-MATRIX" + "UNPROJECT" + )) + +(in-package :opengl) + +;; WITH-OPENGL-CONTEXT is not needed in the PREPARE-OPENGL +;; and DRAW-RECT functions of a specialized NS-OPENGL-VIEW +(defparameter *opengl-context* nil) +(defmacro with-opengl-context (context &body body) + (let ((contextsym (gensym))) + `(let ((,contextsym ,context)) + (unwind-protect + (let ((*opengl-context* ,contextsym)) + (#/makeCurrentContext ,contextsym) + ,@body) + ;; the following resets the current context to what it was + ;; previously as far as the special bindings are concerned + (if *opengl-context* + (#/makeCurrentContext *opengl-context*) + (#/clearCurrentConext ns:ns-opengl-context)))))) + +(defun new-pixel-format (&rest attributes) + ;; take a list of opengl pixel format attributes (enums and other + ;; small ints), make an array (character array?), and create and + ;; return an NSOpenGLPixelFormat + (let* ((attribute-size (ccl::foreign-size :penixelormatttribute :bytes)) + (nattributes (length attributes))) + (ccl::%stack-block ((objc-attributes (* attribute-size (1+ nattributes)))) + (loop for i from 0 to nattributes + for attribute in attributes do + (setf (ccl:paref objc-attributes (:* :penixelormatttribute) i) attribute) ; <- autocoerced? + finally (setf (ccl:paref objc-attributes (:* :penixelormatttribute) nattributes) 0)) ; <- objc nil = null ptr + (make-instance ns:ns-opengl-pixel-format :with-attributes objc-attributes)))) + +#| +(setf pf (opengl:new-pixel-format #$NSOpenGLPFADoubleBuffer #$NSOpenGLPFADepthSize 32)) +(%stack-block ((a-long 4)) + (#/getValues:forAttribute:forVirtualScreen: pf a-long #$NSOpenGLPFADepthSize 0) + (%get-long a-long)) +|# + +(defparameter *matrix-mode* #$GL_MODELVIEW) +(defmacro with-matrix-mode ((mode) &body body) + `(unwind-protect + (let ((*matrix-mode* ,mode)) + (#_glMatrixMode *matrix-mode*) + ,@body) + (#_glMatrixMode *matrix-mode*))) + +(defparameter *render-mode* #$GL_RENDER) +(defmacro with-render-mode ((mode) &body body) + `(block nil + (unwind-protect + (let ((*render-mode* ,mode)) + (#_glRenderMode *render-mode*) + ,@body) + (return (#_glRenderMode *render-mode*))))) + +(defmacro with-rotation ((angle axis) &body body) + (let ((anglesym (gensym)) + (axissym (gensym))) + `(let ((,anglesym ,angle) + (,axissym ,axis)) + (unwind-protect + (with-matrix-mode (#$GL_MODELVIEW) + (#_glPushMatrix) + (#_glRotatef ,anglesym (aref ,axissym 0) (aref ,axissym 1) (aref ,axissym 2)) + ,@body) + (#_glPopMatrix))))) + +(defmacro with-gl ((value) &body body) + `(progn (#_glBegin ,value) + ,@body + (#_glEnd))) + +(defmacro with-culling ((cull-face) &body body) + `(progn (#_glEnable #$GL_CULL_FACE) + (#_glCullFace ,cull-face) + ,@body + (#_glDisable #$GL_CULL_FACE))) + +(defmacro with-matrix ((load-identity-p) &body body) + `(progn (#_glPushMatrix) + ,@(when load-identity-p `((#_glLoadIdentity))) + ,@body + (#_glPopMatrix))) + +(defun unproject (x y) + (let (;; yeah, yeah... I think I know how big these are... + (gl-int-size (ccl::foreign-size :int :bytes)) + (gl-double-size (ccl::foreign-size :double :bytes))) + (ccl::%stack-block ((viewport (* gl-int-size 4)) + (modelview-matrix (* gl-double-size 16)) + (projection-matrix (* gl-double-size 16)) + (wx gl-double-size) + (wy gl-double-size) + (wz gl-double-size)) + (#_glGetIntegerv #$GL_VIEWPORT viewport) + (#_glGetDoublev #$GL_MODELVIEW_MATRIX modelview-matrix) + (#_glGetDoublev #$GL_PROJECTION_MATRIX projection-matrix) + (#_gluUnProject (ccl::%double-float x) (ccl::%double-float y) 0.0d0 + modelview-matrix projection-matrix viewport + wx wy wz) + (coerce (list (ccl::%get-double-float wx) + (ccl::%get-double-float wy) + (ccl::%get-double-float wz)) + 'vector)))) Index: /branches/experimentation/later/source/examples/rubix/rubix.lisp =================================================================== --- /branches/experimentation/later/source/examples/rubix/rubix.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/rubix.lisp (revision 8058) @@ -0,0 +1,246 @@ +(in-package :cl-user) + + +(defparameter light0 nil) +(defparameter light0-pos (make-array 3 :initial-contents '(5.0 3.0 0.0) ;; default to distant light source + :element-type 'single-float)) +(defparameter diffuse0 (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter ambient0 (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) + :element-type 'single-float)) +(defparameter specular0 (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0) + :element-type 'single-float)) + +(defparameter global-ambient (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) :element-type 'single-float)) ;; really really dim grey light + +(defclass rubix-opengl-view (ns:ns-opengl-view) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/prepareOpenGL :void) ((self rubix-opengl-view)) + (declare (special *the-origin* *y-axis*)) + (declare (ignore a-rect)) + (opengl:with-matrix-mode (#$GL_PROJECTION) ;; default is GL_MODELVIEW + (#_glLoadIdentity) + (#_glFrustum -0.6d0 0.6d0 -0.6d0 0.6d0 10.0d0 20.0d0)) + (#_glLoadIdentity) + (mylookat *camera-pos* *the-origin* *y-axis*) + + (#_glShadeModel #$GL_SMOOTH) + (#_glClearColor 0.05 0.05 0.05 0.0) + ;; these next three are all needed to enable the z-buffer + (#_glClearDepth 1.0d0) + (#_glEnable #$GL_DEPTH_TEST) + (#_glDepthFunc #$GL_LEQUAL) + (#_glHint #$GL_PERSPECTIVE_CORRECTION_HINT #$GL_NICEST) + + (setf *cube* (make-instance 'rubix-cube)) + + (#_glEnable #$GL_LIGHTING) + + (setf light0 (make-instance 'light :lightid #$GL_LIGHT0)) + (setpointsource light0 t) + (setlocation light0 light0-pos) + (setdiffuse light0 diffuse0) + (setambient light0 ambient0) + (setspecular light0 specular0) + (on light0) + + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr global-ambient ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightModelfv #$GL_LIGHT_MODEL_AMBIENT foreign-float-vector)) ;; <- coersion issue + + (#_glFlush)) + +(objc:defmethod (#/drawRect: :void) ((self rubix-opengl-view) (a-rect :ns-rect)) + (declare (ignorable a-rect)) + ;; drawing callback + (#_glClear (logior #$GL_COLOR_BUFFER_BIT #$GL_DEPTH_BUFFER_BIT)) + (render *cube*) + (#_glFlush)) + +;; want to be able to send keystrokes to the rubix cube +#+ignore +(objc:defmethod (#/acceptsFirstResponder :) ((self rubix-opengl-view)) + t) + +;; want to be able to click and start dragging (without moving the window) +(objc:defmethod (#/acceptsFirstMouse: :) ((self rubix-opengl-view) + event) + (declare (ignore event)) + t) + + +(defparameter *rubix-face-snap* 8.0) ; degrees + +(objc:defmethod (#/mouseDown: :void) ((self rubix-opengl-view) the-event) + ;; this makes dragging spin the cube + (cond ((zerop (logand #$NSControlKeyMask (#/modifierFlags the-event))) ; not ctrl-click + (let ((dragging-p t)) + (let ((last-loc (#/locationInWindow the-event))) + (loop while dragging-p do + (let ((the-event (#/nextEventMatchingMask: + (#/window self) + (logior #$NSLeftMouseUpMask + #$NSLeftMouseDraggedMask)))) + (let ((mouse-loc (#/locationInWindow the-event))) + (cond ((eq #$NSLeftMouseDragged (#/type the-event)) + (let ((deltax (float + (- (pref mouse-loc :oint.x) + (pref last-loc :oint.x)) + 0.0f0)) + (deltay (float + (- (pref last-loc :oint.y) + (pref mouse-loc :oint.y)) + 0.0f0)) + (vert-rot-axis (cross *y-axis* *camera-pos*))) + (setf (pref last-loc :oint.x) (pref mouse-loc :oint.x) + (pref last-loc :oint.y) (pref mouse-loc :oint.y)) + (rotate-relative *cube* + (mulquats (axis-angle->quat vert-rot-axis deltay) + (axis-angle->quat *y-axis* deltax)))) + (#/setNeedsDisplay: self t)) + (t + (setf dragging-p nil)))))) + (#/setNeedsDisplay: self t)))) + (t;; ctrl-click, do what right-click does... note that once + ;; ctrl-click is done dragging will not require ctrl be held down + + ;; NOTE THE GRATUITOUS CUT-AND-PASTE, debug the right-mouse-down + ;; version preferentially and update this one with fixes as needed + (let* ((first-loc (#/locationInWindow the-event)) + (pick-loc (#/convertPoint:fromView: self first-loc +null-ptr+))) + (let ((dragging-p t) + (reference-snap 0)) + (setf (turning-face *cube*) (render-for-selection + *cube* + (opengl:unproject (pref pick-loc :oint.x) + (pref pick-loc :oint.y))) + (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t) + (face-theta *cube*) 0.0) + (loop while (and dragging-p (face-turning-p *cube*)) do + (let ((the-event (#/nextEventMatchingMask: + (#/window self) + (logior #$NSLeftMouseUpMask + #$NSLeftMouseDraggedMask)))) + (let ((mouse-loc (#/locationInWindow the-event))) + (cond ((eq #$NSLeftMouseDragged (#/type the-event)) + (let ((deltax (float + (- (ns:ns-point-x mouse-loc) + (ns:ns-point-x first-loc)) + 0.0f0))) + (multiple-value-bind (snap-to snap-dist) (round deltax 90.0) + (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap + ;; update cube structure + (let ((rotations (- snap-to reference-snap))) + (cond ((zerop rotations) nil) + ((< 0 rotations) + (dotimes (i rotations) + (turnfaceclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)) + ((> 0 rotations) + (dotimes (i (abs rotations)) + (turnfacecounterclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)))) + ;; determine where face will be drawn + (setf (face-theta *cube*) 0.0)) + (t ; no snap + (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap)))) + ))) + (#/setNeedsDisplay: self t)) + (t + (setf (face-turning-p *cube*) nil + (turning-face *cube*) nil + (face-theta *cube*) nil + dragging-p nil)))))) + (#/setNeedsDisplay: self t))) + ))) + +(objc:defmethod (#/rightMouseDown: :void) ((self rubix-opengl-view) the-event) + ;; this makes dragging left/right turn a face counterclockwise/clockwise + ;; ... clicked-on face determines face turned + ;; ... with an n-degree "snap" + ;; ... with the snap updating the data structure + ;; ... releasing the mouse clears rotation angle (face will snap to last position) + (let* ((first-loc (#/locationInWindow the-event)) + (pick-loc (#/convertPoint:fromView: self first-loc +null-ptr+))) + (let ((dragging-p t) + (reference-snap 0)) + (setf (turning-face *cube*) (render-for-selection + *cube* + (opengl:unproject (pref pick-loc :oint.x) + (pref pick-loc :oint.y))) + (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t) + (face-theta *cube*) 0.0) + (loop while (and dragging-p (face-turning-p *cube*)) do + (let ((the-event (#/nextEventMatchingMask: + (#/window self) + (logior #$NSRightMouseUpMask + #$NSRightMouseDraggedMask)))) + (let ((mouse-loc (#/locationInWindow the-event))) + (cond ((eq #$NSRightMouseDragged (#/type the-event)) + (let ((deltax (float + (- (pref mouse-loc :oint.x) + (pref first-loc :oint.x)) + 0.0f0))) + (multiple-value-bind (snap-to snap-dist) (round deltax 90.0) + (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap + ;; update cube structure + (let ((rotations (- snap-to reference-snap))) + (cond ((zerop rotations) nil) + ((< 0 rotations) + (dotimes (i rotations) + (turnfaceclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)) + ((> 0 rotations) + (dotimes (i (abs rotations)) + (turnfacecounterclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)))) + ;; determine where face will be drawn + (setf (face-theta *cube*) 0.0)) + (t ; no snap + (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap)))) + ))) + (#/setNeedsDisplay: self t)) + (t + (setf (face-turning-p *cube*) nil + (turning-face *cube*) nil + (face-theta *cube*) nil + dragging-p nil)))))) + (#/setNeedsDisplay: self t)))) + +(defclass rubix-window (ns:ns-window) + () + (:metaclass ns:+ns-object)) + +(defparameter *aluminum-margin* 5.0f0) + +(defun run-rubix-demo () + (let* ((w (ccl::new-cocoa-window :class (find-class 'rubix-window) + :title "Rubix Cube" + :height 250 + :width 250 + :expandable nil)) + (w-content-view (#/contentView w))) + (let ((w-frame (#/frame w-content-view))) + (ns:with-ns-rect (glview-rect *aluminum-margin* + *aluminum-margin* + (- (pref w-frame :ect.size.width) + (* 2 *aluminum-margin*)) + (- (pref w-frame :ect.size.height) + *aluminum-margin*)) + ;; Q: why make-objc-instance here? + (let ((glview (make-instance 'rubix-opengl-view + :with-frame glview-rect + :pixel-format #+ignore + (#/defaultPixelFormat nsLns-opengl-view) + (opengl:new-pixel-format ;#$NSOpenGLPFADoubleBuffer + #$NSOpenGLPFAAccelerated + #$NSOpenGLPFAColorSize 32 + #$NSOpenGLPFADepthSize 32)))) + (#/addSubview: w-content-view glview) + w))))) Index: /branches/experimentation/later/source/examples/rubix/vectors.lisp =================================================================== --- /branches/experimentation/later/source/examples/rubix/vectors.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/rubix/vectors.lisp (revision 8058) @@ -0,0 +1,170 @@ +(in-package :cl-user) + +;; A stylistic ideosynchracy of C++ was passing result pointers into functions +;; to reduce the impact of the lack of garbage collection. It reduces consing +;; and allows functions to modify wrapped vectors and the like in place, so +;; it's laudable to keep around, but in general I've made such things an +;; optional final argument. + +;; To-do list: +;; When i make foreign function calls in to glut, glu, or opengl, i should +;; do type checking to trap errors in lisp. + +(defparameter *x-axis* (make-array 3 :initial-contents '( 1.0 0.0 0.0) + :element-type 'single-float)) +(defparameter *y-axis* (make-array 3 :initial-contents '( 0.0 1.0 0.0) + :element-type 'single-float)) +(defparameter *z-axis* (make-array 3 :initial-contents '( 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *neg-x-axis* (make-array 3 :initial-contents '(-1.0 0.0 0.0) + :element-type 'single-float)) +(defparameter *neg-y-axis* (make-array 3 :initial-contents '( 0.0 -1.0 0.0) + :element-type 'single-float)) +(defparameter *neg-z-axis* (make-array 3 :initial-contents '( 0.0 0.0 -1.0) + :element-type 'single-float)) +(defparameter *the-origin* (make-array 3 :initial-contents '( 0.0 0.0 0.0) + :element-type 'single-float)) + +(defparameter *hel-white* (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-grey* (make-array 4 :initial-contents '(0.3 0.3 0.3 1.0) + :element-type 'single-float)) +(defparameter *hel-black* (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-red* (make-array 4 :initial-contents '(1.0 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-green* (make-array 4 :initial-contents '(0.0 0.33 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-blue* (make-array 4 :initial-contents '(0.0 0.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-yellow* (make-array 4 :initial-contents '(1.0 1.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-cyan* (make-array 4 :initial-contents '(0.0 1.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-magenta* (make-array 4 :initial-contents '(1.0 0.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-peach* (make-array 4 :initial-contents '(1.0 0.3 0.2 1.0) + :element-type 'single-float)) +(defparameter *hel-pink* (make-array 4 :initial-contents '(1.0 0.3 0.3 1.0) + :element-type 'single-float)) +(defparameter *hel-orange* (make-array 4 :initial-contents '(1.0 0.3 0.0 1.0) + :element-type 'single-float)) + +(defun radians (degrees) + (/ (* 3.14159 degrees) 180.0)) +(defun degrees (radians) + (/ (* 180.0 radians) 3.14159)) +(defun mag (p) + (let ((p0 (elt p 0)) + (p1 (elt p 1)) + (p2 (elt p 2))) + (+ (* p0 p0) (* p1 p1) (* p2 p2)))) +(defun normalize (p) + (let ((d 0.0)) + (dotimes (i 3) (incf d (expt (elt p i) 2))) + (when (< 0.0 d) + (setf d (sqrt d)) + (dotimes (i 3) (setf (elt p i) (/ (elt p i) d)))) + p)) + +(defun add-vectors (a b &optional result) + (or result (setf result (make-array 3))) + (dotimes (i 3) + (setf (elt result i) (+ (elt a i) (elt b i)))) + result) +(defun scale-vector (a n &optional result) + (or result (setf result (make-array 3))) + (dotimes (i 3) + (setf (elt result i) (* (elt a i) n))) + result) +#+ignore ; overridden by lower defn anyway +(defun cross (a b c &optional norm) + (or norm (setf norm (make-array 3))) + (let ((a0 (elt a 0)) (a1 (elt a 1)) (a2 (elt a 2)) + (b0 (elt b 0)) (b1 (elt b 1)) (b2 (elt b 2)) + (c0 (elt c 0)) (c1 (elt c 1)) (c2 (elt c 2))) + (setf (elt norm 0) (- (* (- b1 a1) (- c2 a2)) (* (- b2 a2) (- c1 a1))) + (elt norm 1) (- (* (- b2 a2) (- c0 a0)) (* (- b0 a0) (- c2 a2))) + (elt norm 2) (- (* (- b0 a0) (- c1 a1)) (* (- b1 a1) (- c0 a0))))) + norm) +(defun cross (v1 v2 &optional crossproduct) + (or crossproduct (setf crossproduct (make-array 3))) + (setf (elt crossproduct 0) (- (* (elt v1 1) (elt v2 2)) + (* (elt v1 2) (elt v2 1))) + (elt crossproduct 1) (- (* (elt v1 2) (elt v2 0)) + (* (elt v1 0) (elt v2 2))) + (elt crossproduct 2) (- (* (elt v1 0) (elt v2 1)) + (* (elt v1 1) (elt v2 0)))) + crossproduct) +(defun dot (v1 v2) + (+ (* (elt v1 0) (elt v2 0)) + (* (elt v1 1) (elt v2 1)) + (* (elt v1 2) (elt v2 2)))) + + +;; quaterion class (note that in my c++ code i use a type for this, +;; but since the quaternions aren't ever going to be in the C world +;; the lisp representation doesn't matter) +(defclass quaternion () + ((w :initform 1.0 :initarg :w :accessor w) + (xyz :initform nil :initarg :xyz :accessor xyz)) + (:default-initargs :xyz (make-array 3 :initial-element 0.0))) +(defmethod addquats ((q1 quaternion) (q2 quaternion) &optional result) + (or result (setf result (make-instance 'quaternion))) + (setf (w result) (+ (w q1) (w q2))) + (add-vectors (xyz q1) (xyz q2) (xyz result)) + result) +;; this computes q1*q2 not the other way around, so it does q2's rotation first +(defmethod mulquats ((q1 quaternion) (q2 quaternion) &optional result) + (or result (setf result (make-instance 'quaternion))) + (let ((t1 (make-array 3 :initial-element 0.0)) + (t2 (make-array 3 :initial-element 0.0)) + (t3 (make-array 3 :initial-element 0.0))) + (scale-vector (xyz q1) (w q2) t1) + (scale-vector (xyz q2) (w q1) t2) + (cross (xyz q1) (xyz q2) t3) + + (setf (w result) (- (* (w q1) (w q2)) (dot (xyz q1) (xyz q2)))) + (add-vectors t1 t2 (xyz result)) + (add-vectors t3 (xyz result) (xyz result)) + result)) + +;; unit quaternions are made up of the axis of rotation (xyz) as a vector with +;; magnitude sin(theta/2) and a scalar (w) with magnitude cos(theta/2); +(defun axis-angle->quat (axis angle &optional q) + (or q (setf q (make-instance 'quaternion))) + (let ((theta (radians angle))) + (setf (w q) (cos (/ theta 2.0))) + (dotimes (i 3) (setf (elt (xyz q) i) (elt axis i))) + (normalize (xyz q)) + (scale-vector (xyz q) (sin (/ theta 2.0)) (xyz q)) + q)) +(defun quat->axis-angle (q &optional axis-angle) ; <- cons pair, bleah + (or axis-angle (setf axis-angle (cons (make-array 3 :initial-element 0.0) + 0.0))) + (let ((len (mag (xyz q)))) + (cond ((> len 0.0001) + (setf (cdr axis-angle) (degrees (* 2.0 (acos (w q))))) + (dotimes (i 3) (setf (elt (car axis-angle) i) + (/ (elt (xyz q) i) len)))) + (t ;; if len is near 0, angle of rotation is too, which can cause + ;; trouble elsewhere, so just return zero + (setf (cdr axis-angle) 0.0) + (setf (elt (car axis-angle) 0) 0.0 + (elt (car axis-angle) 1) 0.0 + (elt (car axis-angle) 2) 1.0))) + axis-angle)) + +;; this wraps a 9-number function with a point/point/vector function +;; note that this could REALLY stand to do some type checking... +(defun myLookAt (camera-position target-position upvector) + (#_gluLookAt + (coerce (elt camera-position 0) 'double-float) + (coerce (elt camera-position 1) 'double-float) + (coerce (elt camera-position 2) 'double-float) + (coerce (elt target-position 0) 'double-float) + (coerce (elt target-position 1) 'double-float) + (coerce (elt target-position 2) 'double-float) + (coerce (elt upvector 0) 'double-float) + (coerce (elt upvector 1) 'double-float) + (coerce (elt upvector 2) 'double-float))) Index: /branches/experimentation/later/source/examples/tiny.lisp =================================================================== --- /branches/experimentation/later/source/examples/tiny.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/tiny.lisp (revision 8058) @@ -0,0 +1,90 @@ +;;;; -*- Mode: Lisp; Package: CCL -*- +;;;; tiny.lisp +;;;; +;;;; A fairly direct translation into Lisp of the Tiny application (Chapter 4) +;;;; from "Building Cocoa Applications" by Garfinkel and Mahoney +;;;; +;;;; The original Tiny example was meant to illustrate the programmatic use of +;;;; Cocoa without Interface Builder. Its purpose here is to illustrate the +;;;; programmatic use of the Cocoa bridge. +;;;; +;;;; Copyright (c) 2003 Randall D. Beer +;;;; +;;;; This software is licensed under the terms of the Lisp Lesser GNU Public +;;;; License , known as the LLGPL. The LLGPL consists of a preamble and +;;;; the LGPL. Where these conflict, the preamble takes precedence. The +;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. +;;;; +;;;; Please send comments and bug reports to + +;;; Temporary package and module stuff + +(in-package "CCL") + +(require "COCOA") + + +;;; Define the DemoView class + +(defclass demo-view (ns:ns-view) + () + (:metaclass ns:+ns-object)) + + +;;; Define the drawRect: method for DemoView +;;; NOTE: The (THE NS-COLOR ...) forms are currently necessary for full +;;; optimization because the SET message has a nonunique type signature +;;; NOTE: This will be replaced by a DEFMETHOD once ObjC objects have been +;;; integrated into CLOS +;;; NOTE: The (@class XXX) forms will probably be replaced by +;;; (find-class 'XXX) once ObjC objects have been integrated into CLOS + +(defconstant short-pi (coerce pi 'short-float)) +(defconstant numsides 12) + +(objc:defmethod (#/drawRect: :void) ((self demo-view) (rect :ect)) + (declare (ignore rect)) + (let* ((bounds (#/bounds self)) + (width (ns:ns-rect-width bounds)) + (height (ns:ns-rect-height bounds))) + (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5)) + (Y (tt) `(* (1+ (cos ,tt)) height 0.5))) + ;; Fill the view with white + (#/set (#/whiteColor ns:ns-color)) + (#_NSRectFill bounds) + ;; Trace two polygons with N sides and connect all of the vertices + ;; with lines + (#/set (#/blackColor ns:ns-color)) + (loop + for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do + (loop + for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do + (#/strokeLineFromPoint:toPoint: ns:ns-bezier-path (ns:make-ns-point (X f) (Y f)) (ns:make-ns-point (X g) (Y g)))))))) + + +;;; This performs the actions that would normally be performed by loading +;;; a nib file. + +(defun tiny-setup () + (with-autorelease-pool + (let* ((r (ns:make-ns-rect 100 350 400 400)) + (w (make-instance + 'ns:ns-window + :with-content-rect r + :style-mask (logior #$NSTitledWindowMask + #$NSClosableWindowMask + #$NSMiniaturizableWindowMask) + :backing #$NSBackingStoreBuffered + :defer t))) + (#/setTitle: w "Tiny Window Application") + (let ((my-view (make-instance 'demo-view :with-frame r))) + (#/setContentView: w my-view) + (#/setDelegate: w my-view)) + (#/makeKeyAndOrderFront: w nil) + w))) + + +;;; Neither the windowWillClose method nor the main from the original Tiny +;;; application is necessary here Index: /branches/experimentation/later/source/examples/webkit.lisp =================================================================== --- /branches/experimentation/later/source/examples/webkit.lisp (revision 8058) +++ /branches/experimentation/later/source/examples/webkit.lisp (revision 8058) @@ -0,0 +1,73 @@ + +;;;-*-Mode: LISP; Package: CCL -*- + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "COCOA")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (objc:load-framework "WebKit" :webkit)) + + +(defun pathname-to-file-url (pathname) + ;; NATIVE-TRANSLATED-NAMESTRING returns a simple string that can be + ;; passed to a filesystem function. (It may be exactly the same as + ;; what NAMESTRING returns, or it may differ if special characters + ;; were escaped in NAMESTRING's result.) + (with-autorelease-pool + (#/retain + (#/fileURLWithPath: ns:ns-url (%make-nsstring + (native-translated-namestring pathname)))))) + +(defun url-from-string (s) + (with-autorelease-pool + (#/retain (#/URLWithString: ns:ns-url (%make-nsstring (string s)))))) + + +(defun browser-window (urlspec) + ;; Content rect for window, bounds rect for view. + (ns:with-ns-rect (r 100.0 100.0 800.0 600.0) + (with-autorelease-pool + (let* ((url (if (typep urlspec 'pathname) + (pathname-to-file-url urlspec) + (url-from-string urlspec))) + ;; Create a window with titlebar, close & iconize buttons + (w (make-instance + 'ns:ns-window + :with-content-rect r + :style-mask (logior #$NSTitledWindowMask + #$NSClosableWindowMask + #$NSMiniaturizableWindowMask + #$NSResizableWindowMask) + ;; Backing styles other than #$NSBackingStoreBuffered + ;; don't work at all in Cocoa. + :backing #$NSBackingStoreBuffered + :defer t))) + (#/setTitle: w (#/absoluteString url)) + ;; Create a web-view instance, + (let* ((v (make-instance + 'ns:web-view + :with-frame r + :frame-name #@"frame" ; could be documented a bit better ... + :group-name #@"group"))) ; as could this + ;; Make the view be the window's content view. + (#/setContentView: w v) + ;; Start a URL request. The request is processed + ;; asynchronously, but apparently needs to be initiated + ;; from the event-handling thread. + (let* ((webframe (#/mainFrame v)) + (request (#/requestWithURL: ns:ns-url-request url))) + ;; Failing to wait until the main thread has + ;; initiated the request seems to cause + ;; view-locking errors. Maybe that's just + ;; an artifact of some other problem. + (#/performSelectorOnMainThread:withObject:waitUntilDone: + webframe (@selector #/loadRequest:) request t) + ;; Make the window visible & activate it + ;; The view knows how to draw itself and respond + ;; to events. + (#/makeKeyAndOrderFront: w +null-ptr+)) + v))))) + +;;; (browser-window "http://openmcl.clozure.com") Index: /branches/experimentation/later/source/freebsd-headers64/gl/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gl/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gl/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gl/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gl/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gl/C/populate.sh =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gl/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gl/C/populate.sh (revision 8058) @@ -0,0 +1,6 @@ +#!/bin/sh +rm -rf usr +CFLAGS="-m64 -I/usr/X11R6/include";export CFLAGS +h-to-ffi.sh /usr/X11R6/include/GL/glx.h +h-to-ffi.sh /usr/X11R6/include/GL/glu.h +h-to-ffi.sh /usr/X11R6/include/GL/glut.h Index: /branches/experimentation/later/source/freebsd-headers64/gmp/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gmp/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gmp/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gmp/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gmp/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gmp/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gmp/C/populate.sh =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gmp/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gmp/C/populate.sh (revision 8058) @@ -0,0 +1,3 @@ +#!/bin/sh +rm -rf usr +h-to-ffi.sh -m64 /usr/local/include/gmp.h Index: /branches/experimentation/later/source/freebsd-headers64/gnome2/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gnome2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gnome2/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gnome2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gnome2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gnome2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gnome2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gnome2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gnome2/C/populate.sh (revision 8058) @@ -0,0 +1,4 @@ +#!/bin/sh +rm -rf usr +CFLAGS="-m64"; export CFLAGS +h-to-ffi.sh `pkg-config --cflags libgnomeui-2.0` /usr/local/include/libgnomeui-2.0/gnome.h Index: /branches/experimentation/later/source/freebsd-headers64/gtk2/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gtk2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gtk2/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gtk2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gtk2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gtk2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/gtk2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/gtk2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/gtk2/C/populate.sh (revision 8058) @@ -0,0 +1,3 @@ +#!/bin/sh +rm -rf usr +h-to-ffi.sh `pkg-config --cflags gtk+-2.0` -m64 /usr/local/include/gtk-2.0/gtk/gtk.h Index: /branches/experimentation/later/source/freebsd-headers64/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/libc/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/freebsd-headers64/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/freebsd-headers64/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/freebsd-headers64/libc/C/populate.sh (revision 8058) @@ -0,0 +1,1265 @@ +#|/bin/sh +rm -rf usr +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/a.out.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/assert.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bitstring.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/complex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cpio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/_ctype.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ctype.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/db.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dirent.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dlfcn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/elf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/elf-hints.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fmtmsg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fstab.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fnmatch.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fts.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ftw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/getopt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/glob.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/grp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/hesiod.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/histedit.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ieeefp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ifaddrs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/inttypes.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/iso646.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kenv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/langinfo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libgen.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/limits.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/link.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/locale.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/malloc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/memory.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/monetary.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h -include /usr/include/db.h /usr/include/mpool.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ndbm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netconfig.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netdb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nl_types.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nlist.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nss.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nsswitch.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objformat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/paths.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/proc_service.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pthread.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pthread_np.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pwd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ranlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readpassphrase.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/regex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/regexp.h + h-to-ffi.sh -m64 -include /usr/include/sys/types.h -include /usr/include/sys/socket.h -include /usr/include/netinet/in.h /usr/include/resolv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/runetype.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/search.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/setjmp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sgtty.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/signal.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stab.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stdbool.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stddef.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stdio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stdlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/string.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stringlist.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/strings.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sysexits.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/tar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/tgmath.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/time.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/timeconv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/timers.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ttyent.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ulimit.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/unistd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/utime.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/utmp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/uuid.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/varargs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vis.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/wchar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/wctype.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/wordexp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/osreldate.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/com_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/com_right.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kvm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fenv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/math.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/md2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/md4.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/md5.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ripemd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sha.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sha256.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/curses.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/term.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/termcap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/unctrl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ncurses_dll.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/radlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/radlib_vs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/taclib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libutil.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/login_cap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ypclnt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/alias.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/archive.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/archive_entry.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libatm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpoll.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bluetooth.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bzlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/calendar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/camlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/devinfo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/devstat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libdisk.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsdxml.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fetch.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/form.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ftpio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libgeom.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/magic.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/memstat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/menu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/eti.h +# conflicts with things defined in math.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/mp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/opie.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/panel.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pcap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pcap-int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pcap-namedb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pmc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pmclog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sdp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/stand.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/thread_db.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libufs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ugidfw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/usbhid.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/tcpd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/zconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/zlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dialog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/gnuregex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/g2c.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/emmintrin.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/mmintrin.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pmmintrin.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/xmmintrin.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/asn1_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/krb5_asn1.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/gssapi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/hdb-private.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/hdb-protos.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/hdb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/hdb_asn1.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/hdb_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kafs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/heim_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/k524_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/krb5-protos.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/krb5-types.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/krb5.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/krb5_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/roken.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/roken-common.h +# +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_cbq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_cdnr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_classq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_hfsc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_priq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_red.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_rio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_rmclass.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_rmclass_debug.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altq_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/altqconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/altq/if_altq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/arpa/ftp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/arpa/inet.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/arpa/nameser.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/arpa/nameser_compat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/arpa/telnet.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/arpa/tftp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsm/audit.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsm/audit_kevents.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/asn1.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmpagent.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmpclient.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmpmod.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmp_atm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmp_mibII.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/bsnmp/snmp_netgraph.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_all.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_cd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_ch.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_da.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_dvcfg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_iu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_low.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_low_pisa.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_message.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_pass.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_pt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_sa.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_ses.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/scsi/scsi_targetio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_ccb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_debug.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_periph.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_queue.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_sim.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_xpt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_xpt_periph.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/cam/cam_xpt_sim.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/rijndael.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/cast.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/castsb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/cryptodev.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/cryptosoft.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/deflate.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/rmd160.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/skipjack.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/crypto/xform.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/acpica/acpiio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/an/if_aironet_ieee.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/an/if_anreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/bktr/ioctl_bt848.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/bktr/ioctl_meteor.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/firewire.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/firewire_phy.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/firewirereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/fwdma.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/fwmem.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/fwohcireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/fwohcivar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/fwphyreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/iec13213.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/iec68113.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/if_fwevar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/if_fwipvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/firewire/sbp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/hwpmc/hwpmc_amd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/hwpmc/hwpmc_pentium.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/hwpmc/hwpmc_piv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/hwpmc/hwpmc_ppro.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/hwpmc/pmc_events.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/cd1400.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/cd180.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/esp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/hd64570.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/i8237.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/i8251.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/i8253reg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/i82586.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/i8259.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/nec765.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/ns16550.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/rsa.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/sab82532.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/wd33c93reg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ic/z8530.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ieee488/ibfoo_int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ieee488/ugpib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ieee488/upd7210.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/iicbus/iic.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/iicbus/iicbus.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/iicbus/iiconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ofw/ofw_bus.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ofw/ofw_pci.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ofw/openfirm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ofw/openfirmio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ofw/openpromio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/pbio/pbioio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/lpt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/lptio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/ppb_1284.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/ppb_msq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/ppbconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/ppbio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/ppi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/ppbus/vpoio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/smbus/smb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/smbus/smbconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/smbus/smbus.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/dsbr100io.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ehcireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ehcivar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/hid.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_auereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_axereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_cdcereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_cuereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_kuereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_ruereg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_udavreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_uralreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/if_uralvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/kue_fw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ohcireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ohcivar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/rio500_usb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ubser.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ucomvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/udbp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/uftdireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/ugraphire_rdesc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/uhcireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/uhcivar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usb_ethersubr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usb_mem.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usb_port.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usb_quirks.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usbcdc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usbdi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usbdi_util.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usbdivar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/usb/usbhid.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/utopia/idtphy.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/utopia/suni.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/utopia/utopia.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/utopia/utopia_priv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/wi/if_wavelan_ieee.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/wi/if_wireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/wi/if_wivar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/dev/wi/spectrum24t_cf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/devfs/devfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/devfs/devfs_int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/fdescfs/fdesc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/fifofs/fifo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/msdosfs/bootsect.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/msdosfs/bpb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/msdosfs/denode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/msdosfs/direntry.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/msdosfs/fat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/msdosfs/msdosfsmount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfs_compr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfs_ihash.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfs_inode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfs_subr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfs_vfsops.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/ntfs/ntfsmount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/nullfs/null.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/nwfs/nwfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/nwfs/nwfs_mount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/nwfs/nwfs_node.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/nwfs/nwfs_subr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/portalfs/portal.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/procfs/procfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/smbfs/smbfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/smbfs/smbfs_node.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/smbfs/smbfs_subr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/udf/ecma167-udf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/udf/osta.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/udf/udf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/udf/udf_mount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/umapfs/umap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/fs/unionfs/union.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/concat/g_concat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/eli/g_eli.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/eli/pkcs5v2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/gate/g_gate.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/label/g_label.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/mirror/g_mirror.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/nop/g_nop.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/raid3/g_raid3.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/shsec/g_shsec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/stripe/g_stripe.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/geom.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/geom_ctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/geom_disk.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/geom_int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/geom_slice.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/geom/geom_vfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/gnu/posix/regex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/gnu/regex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/gpib/gpib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/isofs/cd9660/cd9660_mount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/isofs/cd9660/cd9660_node.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/isofs/cd9660/cd9660_rrip.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/isofs/cd9660/iso.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/isofs/cd9660/iso_rrip.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kadm5/admin.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kadm5/kadm5-private.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kadm5/kadm5-protos.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kadm5/kadm5_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/kadm5/private.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libmilter/mfapi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/libmilter/mfdef.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/context.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/ipv6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/lang.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/list.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/lwbuffer.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/lwpacket.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/lwres.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/result.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/version.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/net.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/netdb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/lwres/platform.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pc/bios.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pc/display.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/_bus.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/_inttypes.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/_limits.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/_stdint.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/_types.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/acpica_machdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/apicreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/apicvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/asm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/asmacros.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/atomic.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/bus.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/bus_dma.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/clock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/cpu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/cpufunc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/cputypes.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/db_machdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/elf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/endian.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/exec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/float.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/floatingpoint.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/fpu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/frame.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/gdb_machdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/ieeefp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/intr_machdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/iodev.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/kdb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/legacyvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/limits.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/md_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/memdev.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/metadata.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/mp_watchdog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/mptable.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/mutex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/param.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pcb_ext.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pci_cfgreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pcpu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pmap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/pmc_mdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/ppireg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/proc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/profile.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/psl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/ptrace.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/reg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/reloc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/resource.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/runq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/segments.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/setjmp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/sf_buf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/sigframe.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/signal.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/smp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/specialreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/stdarg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/sysarch.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/timerreg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/trap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/tss.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/ucontext.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/varargs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/machine/vmparam.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/bpf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/bpf_compat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/bpfdesc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/bridge.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/ethernet.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/fddi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/firewire.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_arc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_arp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_atm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_bridgevar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_clone.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_dl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_gif.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_gre.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_llc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_media.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_mib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_ppp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_pppvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_slvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_sppp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_stf.h +# defines conflicting "log" +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/pfil.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_tap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_tapvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_tun.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_types.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_vlan_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/iso88025.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/net_osdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/netisr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/pfkeyv2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/ppp_comp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/ppp_defs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/radix.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/raw_cb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/route.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/slcompress.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/slip.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/zlib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_pflog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/if_pfsync.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net/pfvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/_ieee80211.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_crypto.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_freebsd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_ioctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_node.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_proto.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_radiotap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/net80211/ieee80211_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/aarp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/at.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/at_extern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/at_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/ddp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/ddp_pcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/ddp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/endian.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatalk/phase2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/ipatm/ipatm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/ipatm/ipatm_serv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/ipatm/ipatm_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/sigpvc/sigpvc_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/spans/spans_cls.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/spans/spans_kxdr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/spans/spans_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/sscf_uni.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/sscf_uni_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/sscop.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/sscop_misc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/sscop_pdu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/sscop_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/uni.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/uniip_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/unisig.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/unisig_decode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/unisig_mbuf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/unisig_msg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/unisig_print.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/uni/unisig_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_cm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_if.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_ioctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_pcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_sap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_sigmgr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_stack.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_sys.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/atm_vc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/port.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netatm/queue.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ng_atm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ng_atmpif.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ng_ccatm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ng_sscfu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ng_sscop.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ng_uni.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/atm/ngatmbase.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_bluetooth.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_bt3c.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_btsocket.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_btsocket_hci_raw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_btsocket_l2cap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_btsocket_rfcomm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_h4.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_hci.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_l2cap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/bluetooth/include/ng_ubt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/netflow/netflow.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/netflow/ng_netflow.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/netgraph.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_UI.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_async.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_atmllc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_bpf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_bridge.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_cisco.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_device.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_echo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_eiface.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_etf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_ether.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_fec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_frame_relay.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_gif.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_gif_demux.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_hole.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_hub.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_iface.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_ip_input.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_ipfw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_ksocket.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_l2tp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_lmi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_message.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_mppc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_nat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_one2many.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_parse.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_ppp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_pppoe.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_pptpgre.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_rfc1490.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_sample.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_socket.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_socketvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_source.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_split.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_sppp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_tcpmss.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_tee.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_tty.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_vjc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netgraph/ng_vlan.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/icmp6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/icmp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/if_atm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/if_ether.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/igmp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/igmp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/in.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/in_gif.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/in_pcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/in_systm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/in_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_carp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_divert.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_dummynet.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_ecn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_encap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_fw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_gre.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_icmp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_mroute.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_var.h +# defines log +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ipprotosw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/pim.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/pim_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcp_debug.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcp_fsm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcp_seq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcp_timer.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/tcpip.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/udp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/udp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_auth.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_compat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_fil.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_frag.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_htable.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_lookup.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_nat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_pool.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_proxy.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_rules.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_scan.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_state.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ip_sync.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet/ipl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ah.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ah6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ah_aesxcbcmac.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/esp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/esp6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/esp_aesctr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/esp_rijndael.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/icmp6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/in6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/in6_gif.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/in6_ifattach.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/in6_pcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/in6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ip6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ip6_ecn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ip6_fw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ip6_mroute.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ip6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ip6protosw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ipcomp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ipcomp6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ipsec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/ipsec6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/mld6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/nd6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/pim6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/pim6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/raw_ip6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/scope6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/tcp6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netinet6/udp6_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ah.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ah_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/esp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/esp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ipcomp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ipcomp_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ipip_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ipsec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ipsec6.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/ipsec_osdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/key.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/key_debug.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/key_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/keydb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/keysock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipsec/xform.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/ipx.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/ipx_if.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/ipx_ip.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/ipx_pcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/ipx_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/spx.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/spx_debug.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/spx_timer.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netipx/spx_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netkey/key.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netkey/key_debug.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netkey/key_var.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netkey/keydb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netkey/keysock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/api/atmapi.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/api/ccatm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/api/unisap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/uni_config.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/uni_hdr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/uni_ie.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/uni_msg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/unimsglib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/uniprint.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/msg/unistruct.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/saal/sscfu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/saal/sscfudef.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/saal/sscop.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/saal/sscopdef.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/sig/uni.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/sig/unidef.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/sig/unisig.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/natm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/unimsg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netnatm/addr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_cfg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_conn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_file.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_lib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_ncp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_nls.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_rcfile.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_rq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_sock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_subr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncp_user.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/ncpio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netncp/nwerror.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/netbios.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb_conn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb_dev.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb_rq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb_subr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb_tran.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/netsmb/smb_trantcp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfs/nfs_common.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfs/nfsproto.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfs/rpcv2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfs/xdr_subs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/krpc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfs_lock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfsargs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfsdiskless.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfsm_subs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfsmount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfsnode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nfsstats.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsclient/nlminfo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsserver/nfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsserver/nfsm_subs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsserver/nfsrvcache.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/nfsserver/nfsrvstats.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/encoding.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/hash.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/objc-api.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/objc-list.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/objc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/runtime.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/sarray.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/thr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/typedstream.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/NXConstStr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/Object.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/objc/Protocol.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/crypto.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ebcdic.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/opensslv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ossl_typ.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/symhacks.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/tmdiff.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/e_os.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/e_os2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/aes.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/aes_locl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/asn1.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/asn1_mac.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/asn1t.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/blowfish.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/bio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/bn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/buffer.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/cast.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/comp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/conf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/conf_api.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/des.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/des_old.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/dh.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/dsa.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/dso.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/eng_int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/engine.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_4758_cca_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_aep_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_atalla_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_cswift_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_ncipher_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_nuron_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_sureware_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hw_ubsec_err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/err.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/evp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/fips.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/fips_rand.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/hmac.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/krb5_asn.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/lhash.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/md2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/md4.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/md5.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/mdc2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/objects.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/obj_mac.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ocsp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/pem.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/pem2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/pkcs12.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/pkcs7.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/rand.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/rc2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/rc4.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/rc5.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ripemd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/rsa.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/sha.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/stack.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/safestack.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/txt_db.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ui.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ui_compat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ui_locl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/x509.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/x509_vfy.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/x509v3.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/opensslconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/kssl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ssl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ssl2.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ssl23.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/ssl3.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/openssl/tls1.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/cardinfo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/cis.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/driver.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/i82365.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/meciareg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/pccard_nbk.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/pcic_pci.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/pcicvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/pccard/slot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/posix4/_semaphore.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/posix4/ksem.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/posix4/mqueue.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/posix4/posix4.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/posix4/sched.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/posix4/semaphore.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/protocols/dumprestore.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/protocols/routed.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/protocols/rwhod.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/protocols/talkd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/protocols/timed.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/readline.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/chardefs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/keymaps.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/history.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/tilde.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/rlstdc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/rlconf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/readline/rltypedefs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/key_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/auth.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/auth_unix.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/clnt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/clnt_soc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/clnt_stat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/nettype.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/pmap_clnt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/pmap_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/pmap_rmt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/raw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpc_msg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpcb_clnt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpcent.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpc_com.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/svc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/svc_auth.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/svc_soc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/svc_dg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/types.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/xdr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/auth_des.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/des.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/des_crypt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/auth_kerb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpcb_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpc/rpcb_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_db.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_tags.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nislib.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/bootparam_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/key_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/klm_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/mount.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nfs_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nlm_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rex.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rnusers.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rquota.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rstat.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rwall.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/sm_inter.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/spray.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/yppasswd.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/yp.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/ypxfrd.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/ypupdate_prot.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_cache.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_object.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_callback.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/crypt.x +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/key_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/mount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rnusers.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rquota.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rstat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/rwall.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/spray.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/yp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/ypxfrd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/ypupdate_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_cache.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/nis_callback.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/rpcsvc/crypt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/mac_biba/mac_biba.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/mac_bsdextended/mac_bsdextended.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/mac_lomac/mac_lomac.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/mac_mls/mac_mls.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/mac_partition/mac_partition.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/openpam.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/openpam_version.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/pam_appl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/pam_constants.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/pam_modules.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/pam_types.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/security/pam_mod_misc.h +# +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/_pthreadtypes.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/aac_ioctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/acct.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/acl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/agpio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/aio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/alq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/assym.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ata.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/bio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/bitstring.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/blist.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/buf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/bufobj.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/bus.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/callout.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/cdefs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/cdio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/cdrio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/chio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h -include /usr/include/sys/param.h /usr/include/sys/clist.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h -include /usr/include/sys/bus.h /usr/include/sys/clock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/condvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h -include /usr/include/sys/param.h /usr/include/sys/conf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h -include /usr/include/sys/param.h /usr/include/sys/cons.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/consio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/copyright.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/cpu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ctype.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/dataacq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/device_port.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/devicestat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/digiio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/dirent.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/disk.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/disklabel.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/diskmbr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/diskpc98.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/dkstat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/domain.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/dvdio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/elf32.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/elf64.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/elf_common.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/endian.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/errno.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/eui64.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/event.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/eventhandler.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/eventvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/exec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/extattr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/fbio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/fcntl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/fdcio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/file.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/filedesc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/filio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/fnv_hash.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/gmon.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/gpt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/iconv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/imgact.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/imgact_aout.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/imgact_elf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/inflate.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/interrupt.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ioccom.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ioctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ioctl_compat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ipc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/jail.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/joystick.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kbio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kdb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kenv.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kernel.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kerneldump.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kobj.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kse.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/kthread.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ktr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ktrace.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/libkern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/limits.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/linedisc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/link_aout.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/link_elf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/linker.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/linker_set.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/lock.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/lockf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/lockmgr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mac.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mac_policy.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mbpool.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mbuf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mchain.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/md4.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/md5.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mdioctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/memrange.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mman.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/module.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mouse.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/msg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/msgbuf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mtio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/mutex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/namei.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/nlist_aout.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/param.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pciio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pcpu.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pioctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pipe.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pmc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pmckern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/pmclog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/poll.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/power.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/priority.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/proc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/procfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/protosw.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ptio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ptrace.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/queue.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/random.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/reboot.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/refcount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/regression.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/resource.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/resourcevar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/rman.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/rtprio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/runq.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sbuf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sched.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/select.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/selinfo.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sem.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sema.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/serial.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sf_buf.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/shm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sigio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/signal.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/signalvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sleepqueue.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/smp.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/snoop.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/socket.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/socketvar.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sockio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/soundcard.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/stat.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/statvfs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/stddef.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/stdint.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sun_disklabel.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sx.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/syscall.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/syscallsubr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sysctl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sysent.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/syslimits.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/syslog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/sysproto.h +# defines conflicting log() +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/systm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/taskqueue.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/termios.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/thr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/tiio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/time.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/timeb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/timepps.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/timers.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/times.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/timespec.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/timetc.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/timex.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/tree.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/tty.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ttychars.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ttycom.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ttydefaults.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ttydev.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/turnstile.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/types.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ucontext.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/ucred.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/uio.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/umtx.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/un.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/unistd.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/unpcb.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/user.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/utsname.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/uuid.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/vmmeter.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/vnode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/wait.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/watchdog.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/sys/xrpuio.h +# +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ffs/ffs_extern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ffs/fs.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ffs/softdep.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/acl.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/dinode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/dir.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/dirhash.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/extattr.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/inode.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/quota.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/ufs_extern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/ufs/ufs/ufsmount.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/memguard.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/pmap.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/swap_pager.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/uma.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/uma_dbg.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/uma_int.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_extern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_kern.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_map.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_object.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_page.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_pageout.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_pager.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vm_param.h +h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/vm/vnode_pager.h +#h-to-ffi.sh -m64 -include /usr/include/sys/types.h /usr/include/FlexLexer.h Index: /branches/experimentation/later/source/headers/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/headers/gl/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gl/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/gl/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gl/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gl/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/gl/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/gl/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/gl/C/populate.sh (revision 8058) @@ -0,0 +1,4 @@ +#!/bin/sh +h-to-ffi.sh /usr/include/GL/glx.h +h-to-ffi.sh /usr/include/GL/glu.h +h-to-ffi.sh /usr/include/GL/glut.h Index: /branches/experimentation/later/source/headers/gnome/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gnome/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gnome/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/gnome/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gnome/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gnome/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/gnome/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/gnome/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/gnome/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh `gnome-config --cflags gnome` /usr/include/gnome-1.0/gnome.h Index: /branches/experimentation/later/source/headers/gnome2/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gnome2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gnome2/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/gnome2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gnome2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gnome2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/gnome2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/gnome2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/gnome2/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh `pkg-config --cflags libgnomeui-2.0` /usr/include/libgnomeui-2.0/gnome.h Index: /branches/experimentation/later/source/headers/gnustep/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gnustep/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gnustep/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/gnustep/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gnustep/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gnustep/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/gnustep/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/gnustep/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/gnustep/C/populate.sh (revision 8058) @@ -0,0 +1,10 @@ +#!/bin/sh +# This assumes a fairly standard/fairly recent GNUstep installation, +# with objc headers installed in the GNUstep hierarchy (i.e., in +# /usr/GNUstep/System/Library/Headers/objc +# +# I -think- that NXConstStr.h is effectively obsolete ... +#h-to-ffi.sh -x objective-c -I/usr/GNUstep/System/Library/Headers/ /usr/GNUstep/System/Library/Headers/objc/NXConstStr.h +h-to-ffi.sh -x objective-c -I/usr/GNUstep/System/Library/Headers/ /usr/GNUstep/System/Library/Headers/objc/objc.h +h-to-ffi.sh -x objective-c -I/usr/GNUstep/System/Library/Headers/ /usr/GNUstep/System/Library/Headers/Foundation/Foundation.h +h-to-ffi.sh -x objective-c -I/usr/GNUstep/System/Library/Headers/ /usr/GNUstep/System/Library/Headers/AppKit/AppKit.h Index: /branches/experimentation/later/source/headers/gtk/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gtk/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gtk/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/gtk/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gtk/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gtk/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/gtk/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/gtk/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/gtk/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh `gtk-config --cflags` /usr/include/gtk-1.2/gtk/gtk.h Index: /branches/experimentation/later/source/headers/gtk2/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gtk2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gtk2/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/gtk2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/gtk2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/gtk2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/gtk2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/gtk2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/gtk2/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh `pkg-config --cflags gtk+-2.0` /usr/include/gtk-2.0/gtk/gtk.h Index: /branches/experimentation/later/source/headers/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/libc/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers/libc/C/populate.sh (revision 8058) @@ -0,0 +1,272 @@ +#!/bin/sh +# Note that it may be necessary to patch , since +# it (mis)uses features not supported by GCC 4.0. See +# +h-to-ffi.sh /usr/include/_G_config.h +h-to-ffi.sh /usr/include/a.out.h +h-to-ffi.sh /usr/include/aio.h +h-to-ffi.sh /usr/include/aliases.h +h-to-ffi.sh /usr/include/alloca.h +h-to-ffi.sh /usr/include/ar.h +h-to-ffi.sh /usr/include/argp.h +h-to-ffi.sh /usr/include/argz.h +h-to-ffi.sh /usr/include/arpa/ftp.h +h-to-ffi.sh /usr/include/arpa/inet.h +h-to-ffi.sh /usr/include/arpa/nameser.h +h-to-ffi.sh /usr/include/arpa/telnet.h +h-to-ffi.sh /usr/include/arpa/tftp.h +h-to-ffi.sh /usr/include/assert.h +h-to-ffi.sh /usr/include/byteswap.h +h-to-ffi.sh /usr/include/complex.h +h-to-ffi.sh /usr/include/cpio.h +h-to-ffi.sh /usr/include/crypt.h +h-to-ffi.sh /usr/include/ctype.h +#h-to-ffi.sh /usr/include/db1/db.h +#h-to-ffi.sh /usr/include/db1/mpool.h +#h-to-ffi.sh /usr/include/db1/ndbm.h +h-to-ffi.sh /usr/include/dirent.h +h-to-ffi.sh -D _GNU_SOURCE /usr/include/dlfcn.h +h-to-ffi.sh /usr/include/elf.h +h-to-ffi.sh /usr/include/endian.h +h-to-ffi.sh /usr/include/envz.h +h-to-ffi.sh /usr/include/err.h +h-to-ffi.sh /usr/include/errno.h +h-to-ffi.sh /usr/include/error.h +h-to-ffi.sh /usr/include/execinfo.h +h-to-ffi.sh /usr/include/fcntl.h +h-to-ffi.sh /usr/include/features.h +h-to-ffi.sh /usr/include/fenv.h +h-to-ffi.sh /usr/include/fmtmsg.h +h-to-ffi.sh /usr/include/fnmatch.h +h-to-ffi.sh /usr/include/fpu_control.h +h-to-ffi.sh /usr/include/fstab.h +h-to-ffi.sh /usr/include/fts.h +h-to-ffi.sh /usr/include/ftw.h +h-to-ffi.sh /usr/include/gconv.h +h-to-ffi.sh /usr/include/getopt.h +h-to-ffi.sh /usr/include/glob.h +h-to-ffi.sh /usr/include/gnu-versions.h +h-to-ffi.sh /usr/include/gnu/lib-names.h +h-to-ffi.sh /usr/include/gnu/libc-version.h +h-to-ffi.sh /usr/include/gnu/stubs.h +h-to-ffi.sh /usr/include/grp.h +h-to-ffi.sh /usr/include/iconv.h +h-to-ffi.sh /usr/include/ieee754.h +h-to-ffi.sh /usr/include/ifaddrs.h +h-to-ffi.sh /usr/include/inttypes.h +h-to-ffi.sh /usr/include/langinfo.h +h-to-ffi.sh /usr/include/lastlog.h +h-to-ffi.sh /usr/include/libgen.h +h-to-ffi.sh /usr/include/libintl.h +h-to-ffi.sh /usr/include/libio.h +#h-to-ffi.sh /usr/include/limits.h +h-to-ffi.sh /usr/include/link.h +h-to-ffi.sh /usr/include/locale.h +h-to-ffi.sh /usr/include/malloc.h +h-to-ffi.sh /usr/include/math.h +h-to-ffi.sh /usr/include/mcheck.h +h-to-ffi.sh /usr/include/memory.h +h-to-ffi.sh /usr/include/mntent.h +h-to-ffi.sh /usr/include/monetary.h +h-to-ffi.sh /usr/include/net/ethernet.h +h-to-ffi.sh /usr/include/net/if.h +h-to-ffi.sh /usr/include/net/if_arp.h +h-to-ffi.sh /usr/include/net/if_packet.h +h-to-ffi.sh /usr/include/net/if_ppp.h +h-to-ffi.sh /usr/include/net/if_shaper.h +h-to-ffi.sh /usr/include/net/if_slip.h +h-to-ffi.sh -include /usr/include/net/ppp_defs.h /usr/include/net/ppp-comp.h +h-to-ffi.sh /usr/include/net/route.h +h-to-ffi.sh /usr/include/netash/ash.h +h-to-ffi.sh -include /usr/include/sys/socket.h /usr/include/netatalk/at.h +h-to-ffi.sh /usr/include/netax25/ax25.h +h-to-ffi.sh /usr/include/netdb.h +h-to-ffi.sh /usr/include/neteconet/ec.h +h-to-ffi.sh /usr/include/netinet/ether.h +h-to-ffi.sh /usr/include/netinet/icmp6.h +h-to-ffi.sh /usr/include/netinet/if_ether.h +h-to-ffi.sh /usr/include/netinet/if_fddi.h +h-to-ffi.sh /usr/include/netinet/if_tr.h +h-to-ffi.sh /usr/include/netinet/igmp.h +h-to-ffi.sh /usr/include/netinet/in.h +h-to-ffi.sh /usr/include/netinet/in_systm.h +h-to-ffi.sh /usr/include/netinet/ip.h +h-to-ffi.sh /usr/include/netinet/ip6.h +h-to-ffi.sh /usr/include/netinet/ip_icmp.h +h-to-ffi.sh /usr/include/netinet/tcp.h +h-to-ffi.sh /usr/include/netinet/udp.h +h-to-ffi.sh /usr/include/netipx/ipx.h +h-to-ffi.sh /usr/include/netpacket/packet.h +h-to-ffi.sh /usr/include/netrom/netrom.h +h-to-ffi.sh -include /usr/include/netax25/ax25.h /usr/include/netrose/rose.h +h-to-ffi.sh /usr/include/nfs/nfs.h +h-to-ffi.sh /usr/include/nl_types.h +h-to-ffi.sh /usr/include/nss.h +h-to-ffi.sh /usr/include/obstack.h +h-to-ffi.sh /usr/include/paths.h +h-to-ffi.sh -include /usr/include/sys/types.h -include /usr/include/sys/time.h -include /usr/include/stdio.h -include /usr/include/pcap-bpf.h /usr/include/pcap-namedb.h +h-to-ffi.sh /usr/include/pcap.h +h-to-ffi.sh /usr/include/pci/config.h +h-to-ffi.sh /usr/include/pci/header.h +h-to-ffi.sh /usr/include/pci/pci.h +h-to-ffi.sh /usr/include/poll.h +h-to-ffi.sh /usr/include/printf.h +h-to-ffi.sh /usr/include/protocols/routed.h +h-to-ffi.sh /usr/include/protocols/rwhod.h +h-to-ffi.sh /usr/include/protocols/talkd.h +h-to-ffi.sh /usr/include/protocols/timed.h +h-to-ffi.sh /usr/include/pthread.h +h-to-ffi.sh /usr/include/pty.h +h-to-ffi.sh /usr/include/pwd.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/re_comp.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/regex.h +#h-to-ffi.sh /usr/include/regexp.h +h-to-ffi.sh /usr/include/rpc/auth.h +h-to-ffi.sh /usr/include/rpc/auth_des.h +h-to-ffi.sh /usr/include/rpc/auth_unix.h +h-to-ffi.sh /usr/include/rpc/clnt.h +h-to-ffi.sh /usr/include/rpc/des_crypt.h +h-to-ffi.sh /usr/include/rpc/key_prot.h +h-to-ffi.sh /usr/include/rpc/netdb.h +h-to-ffi.sh /usr/include/rpc/pmap_clnt.h +h-to-ffi.sh /usr/include/rpc/pmap_prot.h +h-to-ffi.sh /usr/include/rpc/pmap_rmt.h +h-to-ffi.sh /usr/include/rpc/rpc.h +h-to-ffi.sh /usr/include/rpc/rpc_des.h +h-to-ffi.sh /usr/include/rpc/rpc_msg.h +h-to-ffi.sh /usr/include/rpc/svc.h +h-to-ffi.sh /usr/include/rpc/svc_auth.h +h-to-ffi.sh /usr/include/rpc/types.h +h-to-ffi.sh /usr/include/rpc/xdr.h +h-to-ffi.sh /usr/include/rpcsvc/bootparam.h +h-to-ffi.sh /usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh /usr/include/rpcsvc/key_prot.h +h-to-ffi.sh /usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh /usr/include/rpcsvc/mount.h +h-to-ffi.sh /usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh /usr/include/rpcsvc/nis.h +h-to-ffi.sh /usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh /usr/include/rpcsvc/rex.h +h-to-ffi.sh /usr/include/rpcsvc/rquota.h +h-to-ffi.sh /usr/include/rpcsvc/rstat.h +h-to-ffi.sh /usr/include/rpcsvc/rusers.h +h-to-ffi.sh /usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh /usr/include/rpcsvc/spray.h +h-to-ffi.sh /usr/include/rpcsvc/yp.h +h-to-ffi.sh /usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh /usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh /usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh /usr/include/rpcsvc/ypupd.h +h-to-ffi.sh /usr/include/sched.h +h-to-ffi.sh /usr/include/scsi/scsi.h +h-to-ffi.sh /usr/include/scsi/scsi_ioctl.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/scsi/sg.h +h-to-ffi.sh /usr/include/search.h +h-to-ffi.sh /usr/include/semaphore.h +h-to-ffi.sh /usr/include/setjmp.h +h-to-ffi.sh /usr/include/sgtty.h +h-to-ffi.sh /usr/include/shadow.h +h-to-ffi.sh /usr/include/spawn.h +h-to-ffi.sh /usr/include/signal.h +h-to-ffi.sh /usr/include/stab.h +#h-to-ffi.sh /usr/include/stack-alloc.h +h-to-ffi.sh /usr/include/stdint.h +h-to-ffi.sh /usr/include/stdio.h +h-to-ffi.sh -D_GNU_SOURCE /usr/include/stdlib.h +h-to-ffi.sh /usr/include/string.h +h-to-ffi.sh /usr/include/strings.h +h-to-ffi.sh /usr/include/stropts.h +h-to-ffi.sh /usr/include/sys/acct.h +h-to-ffi.sh /usr/include/sys/bitypes.h +h-to-ffi.sh /usr/include/sys/cdefs.h +h-to-ffi.sh /usr/include/sys/dir.h +h-to-ffi.sh /usr/include/sys/errno.h +h-to-ffi.sh /usr/include/sys/fcntl.h +h-to-ffi.sh /usr/include/sys/file.h +h-to-ffi.sh /usr/include/sys/fsuid.h +h-to-ffi.sh /usr/include/sys/gmon.h +h-to-ffi.sh /usr/include/sys/gmon_out.h +h-to-ffi.sh /usr/include/sys/ioctl.h +h-to-ffi.sh /usr/include/sys/ipc.h +h-to-ffi.sh /usr/include/sys/kd.h +h-to-ffi.sh /usr/include/sys/kdaemon.h +h-to-ffi.sh /usr/include/sys/klog.h +h-to-ffi.sh /usr/include/sys/mman.h +h-to-ffi.sh /usr/include/sys/mount.h +h-to-ffi.sh /usr/include/sys/msg.h +h-to-ffi.sh /usr/include/sys/mtio.h +h-to-ffi.sh /usr/include/sys/param.h +h-to-ffi.sh /usr/include/sys/pci.h +h-to-ffi.sh /usr/include/sys/poll.h +h-to-ffi.sh /usr/include/sys/prctl.h +h-to-ffi.sh /usr/include/sys/procfs.h +h-to-ffi.sh /usr/include/sys/profil.h +h-to-ffi.sh /usr/include/sys/ptrace.h +h-to-ffi.sh /usr/include/sys/queue.h +h-to-ffi.sh /usr/include/sys/quota.h +h-to-ffi.sh /usr/include/sys/raw.h +h-to-ffi.sh /usr/include/sys/reboot.h +h-to-ffi.sh /usr/include/sys/resource.h +h-to-ffi.sh /usr/include/sys/select.h +h-to-ffi.sh /usr/include/sys/sem.h +h-to-ffi.sh /usr/include/sys/sendfile.h +h-to-ffi.sh /usr/include/sys/shm.h +h-to-ffi.sh /usr/include/sys/signal.h +h-to-ffi.sh /usr/include/sys/socket.h +h-to-ffi.sh /usr/include/sys/socketvar.h +h-to-ffi.sh /usr/include/sys/soundcard.h +h-to-ffi.sh /usr/include/sys/stat.h +h-to-ffi.sh /usr/include/sys/statfs.h +h-to-ffi.sh /usr/include/sys/statvfs.h +h-to-ffi.sh /usr/include/sys/stropts.h +h-to-ffi.sh /usr/include/sys/swap.h +h-to-ffi.sh /usr/include/sys/syscall.h +h-to-ffi.sh /usr/include/sys/sysctl.h +h-to-ffi.sh /usr/include/sys/sysinfo.h +h-to-ffi.sh /usr/include/sys/syslog.h +h-to-ffi.sh /usr/include/sys/sysmacros.h +h-to-ffi.sh /usr/include/sys/termios.h +h-to-ffi.sh /usr/include/sys/time.h +h-to-ffi.sh /usr/include/sys/timeb.h +h-to-ffi.sh /usr/include/sys/times.h +h-to-ffi.sh /usr/include/sys/timex.h +h-to-ffi.sh /usr/include/sys/ttychars.h +h-to-ffi.sh /usr/include/sys/ttydefaults.h +h-to-ffi.sh /usr/include/sys/types.h +h-to-ffi.sh /usr/include/sys/ucontext.h +h-to-ffi.sh /usr/include/sys/uio.h +h-to-ffi.sh /usr/include/sys/ultrasound.h +h-to-ffi.sh /usr/include/sys/un.h +h-to-ffi.sh /usr/include/sys/unistd.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/sys/user.h +h-to-ffi.sh /usr/include/sys/ustat.h +h-to-ffi.sh /usr/include/sys/utsname.h +h-to-ffi.sh /usr/include/sys/vfs.h +h-to-ffi.sh /usr/include/sys/vlimit.h +h-to-ffi.sh /usr/include/sys/vt.h +h-to-ffi.sh /usr/include/sys/vtimes.h +h-to-ffi.sh /usr/include/sys/wait.h +h-to-ffi.sh /usr/include/syscall.h +h-to-ffi.sh /usr/include/sysexits.h +h-to-ffi.sh /usr/include/syslog.h +h-to-ffi.sh /usr/include/tar.h +h-to-ffi.sh /usr/include/termio.h +h-to-ffi.sh /usr/include/termios.h +h-to-ffi.sh /usr/include/tgmath.h +h-to-ffi.sh /usr/include/thread_db.h +h-to-ffi.sh /usr/include/time.h +h-to-ffi.sh /usr/include/ttyent.h +h-to-ffi.sh /usr/include/ucontext.h +h-to-ffi.sh /usr/include/ulimit.h +h-to-ffi.sh /usr/include/unistd.h +h-to-ffi.sh /usr/include/ustat.h +h-to-ffi.sh /usr/include/utime.h +h-to-ffi.sh /usr/include/utmp.h +h-to-ffi.sh /usr/include/utmpx.h +h-to-ffi.sh /usr/include/values.h +h-to-ffi.sh /usr/include/wait.h +h-to-ffi.sh /usr/include/wchar.h +h-to-ffi.sh /usr/include/wctype.h +h-to-ffi.sh /usr/include/wordexp.h +h-to-ffi.sh /usr/include/xlocale.h + Index: /branches/experimentation/later/source/headers64/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/headers64/gl/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/gl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/gl/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers64/gl/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/gl/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/gl/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers64/gl/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers64/gl/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers64/gl/C/populate.sh (revision 8058) @@ -0,0 +1,5 @@ +#!/bin/sh +CFLAGS="-m64";export CFLAGS +h-to-ffi.sh /usr/include/GL/glx.h +h-to-ffi.sh /usr/include/GL/glu.h +h-to-ffi.sh /usr/include/GL/glut.h Index: /branches/experimentation/later/source/headers64/gnome2/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/gnome2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/gnome2/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers64/gnome2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/gnome2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/gnome2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers64/gnome2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers64/gnome2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers64/gnome2/C/populate.sh (revision 8058) @@ -0,0 +1,3 @@ +#!/bin/sh +CFLAGS="-m64"; export CFLAGS +h-to-ffi.sh `pkg-config --cflags libgnomeui-2.0` /usr/include/libgnomeui-2.0/gnome.h Index: /branches/experimentation/later/source/headers64/gtk2/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/gtk2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/gtk2/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers64/gtk2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/gtk2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/gtk2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers64/gtk2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers64/gtk2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers64/gtk2/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh `pkg-config --cflags gtk+-2.0` -m64 /usr/include/gtk-2.0/gtk/gtk.h Index: /branches/experimentation/later/source/headers64/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/libc/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/headers64/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/headers64/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/headers64/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/headers64/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/headers64/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/headers64/libc/C/populate.sh (revision 8058) @@ -0,0 +1,273 @@ +#!/bin/sh +# Note that it may be necessary to patch , since +# it (mis)uses features not supported by GCC 4.0. See +# +CFLAGS=-m64;export CFLAGS +h-to-ffi.sh /usr/include/_G_config.h +h-to-ffi.sh /usr/include/a.out.h +h-to-ffi.sh /usr/include/aio.h +h-to-ffi.sh /usr/include/aliases.h +h-to-ffi.sh /usr/include/alloca.h +h-to-ffi.sh /usr/include/ar.h +h-to-ffi.sh /usr/include/argp.h +h-to-ffi.sh /usr/include/argz.h +h-to-ffi.sh /usr/include/arpa/ftp.h +h-to-ffi.sh /usr/include/arpa/inet.h +h-to-ffi.sh /usr/include/arpa/nameser.h +h-to-ffi.sh /usr/include/arpa/telnet.h +h-to-ffi.sh /usr/include/arpa/tftp.h +h-to-ffi.sh /usr/include/assert.h +h-to-ffi.sh /usr/include/byteswap.h +h-to-ffi.sh /usr/include/complex.h +h-to-ffi.sh /usr/include/cpio.h +h-to-ffi.sh /usr/include/crypt.h +h-to-ffi.sh /usr/include/ctype.h +#h-to-ffi.sh /usr/include/db1/db.h +#h-to-ffi.sh /usr/include/db1/mpool.h +#h-to-ffi.sh /usr/include/db1/ndbm.h +h-to-ffi.sh /usr/include/dirent.h +h-to-ffi.sh -D _GNU_SOURCE /usr/include/dlfcn.h +h-to-ffi.sh /usr/include/elf.h +h-to-ffi.sh /usr/include/endian.h +h-to-ffi.sh /usr/include/envz.h +h-to-ffi.sh /usr/include/err.h +h-to-ffi.sh /usr/include/errno.h +h-to-ffi.sh /usr/include/error.h +h-to-ffi.sh /usr/include/execinfo.h +h-to-ffi.sh /usr/include/fcntl.h +h-to-ffi.sh /usr/include/features.h +h-to-ffi.sh /usr/include/fenv.h +h-to-ffi.sh /usr/include/fmtmsg.h +h-to-ffi.sh /usr/include/fnmatch.h +h-to-ffi.sh /usr/include/fpu_control.h +h-to-ffi.sh /usr/include/fstab.h +h-to-ffi.sh /usr/include/fts.h +h-to-ffi.sh /usr/include/ftw.h +h-to-ffi.sh /usr/include/gconv.h +h-to-ffi.sh /usr/include/getopt.h +h-to-ffi.sh /usr/include/glob.h +h-to-ffi.sh /usr/include/gnu-versions.h +h-to-ffi.sh /usr/include/gnu/lib-names.h +h-to-ffi.sh /usr/include/gnu/libc-version.h +h-to-ffi.sh /usr/include/gnu/stubs.h +h-to-ffi.sh /usr/include/grp.h +h-to-ffi.sh /usr/include/iconv.h +h-to-ffi.sh /usr/include/ieee754.h +h-to-ffi.sh /usr/include/ifaddrs.h +h-to-ffi.sh /usr/include/inttypes.h +h-to-ffi.sh /usr/include/langinfo.h +h-to-ffi.sh /usr/include/lastlog.h +h-to-ffi.sh /usr/include/libgen.h +h-to-ffi.sh /usr/include/libintl.h +h-to-ffi.sh /usr/include/libio.h +#h-to-ffi.sh /usr/include/limits.h +h-to-ffi.sh /usr/include/link.h +h-to-ffi.sh /usr/include/locale.h +h-to-ffi.sh /usr/include/malloc.h +h-to-ffi.sh /usr/include/math.h +h-to-ffi.sh /usr/include/mcheck.h +h-to-ffi.sh /usr/include/memory.h +h-to-ffi.sh /usr/include/mntent.h +h-to-ffi.sh /usr/include/monetary.h +h-to-ffi.sh /usr/include/net/ethernet.h +h-to-ffi.sh /usr/include/net/if.h +h-to-ffi.sh /usr/include/net/if_arp.h +h-to-ffi.sh /usr/include/net/if_packet.h +h-to-ffi.sh /usr/include/net/if_ppp.h +h-to-ffi.sh /usr/include/net/if_shaper.h +h-to-ffi.sh /usr/include/net/if_slip.h +h-to-ffi.sh -include /usr/include/net/ppp_defs.h /usr/include/net/ppp-comp.h +h-to-ffi.sh /usr/include/net/route.h +h-to-ffi.sh /usr/include/netash/ash.h +h-to-ffi.sh -include /usr/include/sys/socket.h /usr/include/netatalk/at.h +h-to-ffi.sh /usr/include/netax25/ax25.h +h-to-ffi.sh /usr/include/netdb.h +h-to-ffi.sh /usr/include/neteconet/ec.h +h-to-ffi.sh /usr/include/netinet/ether.h +h-to-ffi.sh /usr/include/netinet/icmp6.h +h-to-ffi.sh /usr/include/netinet/if_ether.h +h-to-ffi.sh /usr/include/netinet/if_fddi.h +h-to-ffi.sh /usr/include/netinet/if_tr.h +h-to-ffi.sh /usr/include/netinet/igmp.h +h-to-ffi.sh /usr/include/netinet/in.h +h-to-ffi.sh /usr/include/netinet/in_systm.h +h-to-ffi.sh /usr/include/netinet/ip.h +h-to-ffi.sh /usr/include/netinet/ip6.h +h-to-ffi.sh /usr/include/netinet/ip_icmp.h +h-to-ffi.sh /usr/include/netinet/tcp.h +h-to-ffi.sh /usr/include/netinet/udp.h +h-to-ffi.sh /usr/include/netipx/ipx.h +h-to-ffi.sh /usr/include/netpacket/packet.h +h-to-ffi.sh /usr/include/netrom/netrom.h +h-to-ffi.sh -include /usr/include/netax25/ax25.h /usr/include/netrose/rose.h +h-to-ffi.sh /usr/include/nfs/nfs.h +h-to-ffi.sh /usr/include/nl_types.h +h-to-ffi.sh /usr/include/nss.h +h-to-ffi.sh /usr/include/obstack.h +h-to-ffi.sh /usr/include/paths.h +h-to-ffi.sh -include /usr/include/sys/types.h -include /usr/include/sys/time.h -include /usr/include/stdio.h -include /usr/include/pcap-bpf.h /usr/include/pcap-namedb.h +h-to-ffi.sh /usr/include/pcap.h +h-to-ffi.sh /usr/include/pci/config.h +h-to-ffi.sh /usr/include/pci/header.h +h-to-ffi.sh /usr/include/pci/pci.h +h-to-ffi.sh /usr/include/poll.h +h-to-ffi.sh /usr/include/printf.h +h-to-ffi.sh /usr/include/protocols/routed.h +h-to-ffi.sh /usr/include/protocols/rwhod.h +h-to-ffi.sh /usr/include/protocols/talkd.h +h-to-ffi.sh /usr/include/protocols/timed.h +h-to-ffi.sh /usr/include/pthread.h +h-to-ffi.sh /usr/include/pty.h +h-to-ffi.sh /usr/include/pwd.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/re_comp.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/regex.h +#h-to-ffi.sh /usr/include/regexp.h +h-to-ffi.sh /usr/include/rpc/auth.h +h-to-ffi.sh /usr/include/rpc/auth_des.h +h-to-ffi.sh /usr/include/rpc/auth_unix.h +h-to-ffi.sh /usr/include/rpc/clnt.h +h-to-ffi.sh /usr/include/rpc/des_crypt.h +h-to-ffi.sh /usr/include/rpc/key_prot.h +h-to-ffi.sh /usr/include/rpc/netdb.h +h-to-ffi.sh /usr/include/rpc/pmap_clnt.h +h-to-ffi.sh /usr/include/rpc/pmap_prot.h +h-to-ffi.sh /usr/include/rpc/pmap_rmt.h +h-to-ffi.sh /usr/include/rpc/rpc.h +h-to-ffi.sh /usr/include/rpc/rpc_des.h +h-to-ffi.sh /usr/include/rpc/rpc_msg.h +h-to-ffi.sh /usr/include/rpc/svc.h +h-to-ffi.sh /usr/include/rpc/svc_auth.h +h-to-ffi.sh /usr/include/rpc/types.h +h-to-ffi.sh /usr/include/rpc/xdr.h +h-to-ffi.sh /usr/include/rpcsvc/bootparam.h +h-to-ffi.sh /usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh /usr/include/rpcsvc/key_prot.h +h-to-ffi.sh /usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh /usr/include/rpcsvc/mount.h +h-to-ffi.sh /usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh /usr/include/rpcsvc/nis.h +h-to-ffi.sh /usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh /usr/include/rpcsvc/rex.h +h-to-ffi.sh /usr/include/rpcsvc/rquota.h +h-to-ffi.sh /usr/include/rpcsvc/rstat.h +h-to-ffi.sh /usr/include/rpcsvc/rusers.h +h-to-ffi.sh /usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh /usr/include/rpcsvc/spray.h +h-to-ffi.sh /usr/include/rpcsvc/yp.h +h-to-ffi.sh /usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh /usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh /usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh /usr/include/rpcsvc/ypupd.h +h-to-ffi.sh /usr/include/sched.h +h-to-ffi.sh /usr/include/scsi/scsi.h +h-to-ffi.sh /usr/include/scsi/scsi_ioctl.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/scsi/sg.h +h-to-ffi.sh /usr/include/search.h +h-to-ffi.sh /usr/include/semaphore.h +h-to-ffi.sh /usr/include/setjmp.h +h-to-ffi.sh /usr/include/sgtty.h +h-to-ffi.sh /usr/include/shadow.h +h-to-ffi.sh /usr/include/spawn.h +h-to-ffi.sh /usr/include/signal.h +h-to-ffi.sh /usr/include/stab.h +#h-to-ffi.sh /usr/include/stack-alloc.h +h-to-ffi.sh /usr/include/stdint.h +h-to-ffi.sh /usr/include/stdio.h +h-to-ffi.sh -D_GNU_SOURCE /usr/include/stdlib.h +h-to-ffi.sh /usr/include/string.h +h-to-ffi.sh /usr/include/strings.h +h-to-ffi.sh /usr/include/stropts.h +h-to-ffi.sh /usr/include/sys/acct.h +h-to-ffi.sh /usr/include/sys/bitypes.h +h-to-ffi.sh /usr/include/sys/cdefs.h +h-to-ffi.sh /usr/include/sys/dir.h +h-to-ffi.sh /usr/include/sys/errno.h +h-to-ffi.sh /usr/include/sys/fcntl.h +h-to-ffi.sh /usr/include/sys/file.h +h-to-ffi.sh /usr/include/sys/fsuid.h +h-to-ffi.sh /usr/include/sys/gmon.h +h-to-ffi.sh /usr/include/sys/gmon_out.h +h-to-ffi.sh /usr/include/sys/ioctl.h +h-to-ffi.sh /usr/include/sys/ipc.h +h-to-ffi.sh /usr/include/sys/kd.h +h-to-ffi.sh /usr/include/sys/kdaemon.h +h-to-ffi.sh /usr/include/sys/klog.h +h-to-ffi.sh /usr/include/sys/mman.h +h-to-ffi.sh /usr/include/sys/mount.h +h-to-ffi.sh /usr/include/sys/msg.h +h-to-ffi.sh /usr/include/sys/mtio.h +h-to-ffi.sh /usr/include/sys/param.h +h-to-ffi.sh /usr/include/sys/pci.h +h-to-ffi.sh /usr/include/sys/poll.h +h-to-ffi.sh /usr/include/sys/prctl.h +h-to-ffi.sh /usr/include/sys/procfs.h +h-to-ffi.sh /usr/include/sys/profil.h +h-to-ffi.sh /usr/include/sys/ptrace.h +h-to-ffi.sh /usr/include/sys/queue.h +h-to-ffi.sh /usr/include/sys/quota.h +h-to-ffi.sh /usr/include/sys/raw.h +h-to-ffi.sh /usr/include/sys/reboot.h +h-to-ffi.sh /usr/include/sys/resource.h +h-to-ffi.sh /usr/include/sys/select.h +h-to-ffi.sh /usr/include/sys/sem.h +h-to-ffi.sh /usr/include/sys/sendfile.h +h-to-ffi.sh /usr/include/sys/shm.h +h-to-ffi.sh /usr/include/sys/signal.h +h-to-ffi.sh /usr/include/sys/socket.h +h-to-ffi.sh /usr/include/sys/socketvar.h +h-to-ffi.sh /usr/include/sys/soundcard.h +h-to-ffi.sh /usr/include/sys/stat.h +h-to-ffi.sh /usr/include/sys/statfs.h +h-to-ffi.sh /usr/include/sys/statvfs.h +h-to-ffi.sh /usr/include/sys/stropts.h +h-to-ffi.sh /usr/include/sys/swap.h +h-to-ffi.sh /usr/include/sys/syscall.h +h-to-ffi.sh /usr/include/sys/sysctl.h +h-to-ffi.sh /usr/include/sys/sysinfo.h +h-to-ffi.sh /usr/include/sys/syslog.h +h-to-ffi.sh /usr/include/sys/sysmacros.h +h-to-ffi.sh /usr/include/sys/termios.h +h-to-ffi.sh /usr/include/sys/time.h +h-to-ffi.sh /usr/include/sys/timeb.h +h-to-ffi.sh /usr/include/sys/times.h +h-to-ffi.sh /usr/include/sys/timex.h +h-to-ffi.sh /usr/include/sys/ttychars.h +h-to-ffi.sh /usr/include/sys/ttydefaults.h +h-to-ffi.sh /usr/include/sys/types.h +h-to-ffi.sh /usr/include/sys/ucontext.h +h-to-ffi.sh /usr/include/sys/uio.h +h-to-ffi.sh /usr/include/sys/ultrasound.h +h-to-ffi.sh /usr/include/sys/un.h +h-to-ffi.sh /usr/include/sys/unistd.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/sys/user.h +h-to-ffi.sh /usr/include/sys/ustat.h +h-to-ffi.sh /usr/include/sys/utsname.h +h-to-ffi.sh /usr/include/sys/vfs.h +h-to-ffi.sh /usr/include/sys/vlimit.h +h-to-ffi.sh /usr/include/sys/vt.h +h-to-ffi.sh /usr/include/sys/vtimes.h +h-to-ffi.sh /usr/include/sys/wait.h +h-to-ffi.sh /usr/include/syscall.h +h-to-ffi.sh /usr/include/sysexits.h +h-to-ffi.sh /usr/include/syslog.h +h-to-ffi.sh /usr/include/tar.h +h-to-ffi.sh /usr/include/termio.h +h-to-ffi.sh /usr/include/termios.h +h-to-ffi.sh /usr/include/tgmath.h +h-to-ffi.sh /usr/include/thread_db.h +h-to-ffi.sh /usr/include/time.h +h-to-ffi.sh /usr/include/ttyent.h +h-to-ffi.sh /usr/include/ucontext.h +h-to-ffi.sh /usr/include/ulimit.h +h-to-ffi.sh /usr/include/unistd.h +h-to-ffi.sh /usr/include/ustat.h +h-to-ffi.sh /usr/include/utime.h +h-to-ffi.sh /usr/include/utmp.h +h-to-ffi.sh /usr/include/utmpx.h +h-to-ffi.sh /usr/include/values.h +h-to-ffi.sh /usr/include/wait.h +h-to-ffi.sh /usr/include/wchar.h +h-to-ffi.sh /usr/include/wctype.h +h-to-ffi.sh /usr/include/wordexp.h +h-to-ffi.sh /usr/include/xlocale.h + Index: /branches/experimentation/later/source/l1-fasls/.cvsignore =================================================================== --- /branches/experimentation/later/source/l1-fasls/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/l1-fasls/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*fsl + + Index: /branches/experimentation/later/source/level-0/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-0/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-0/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/experimentation/later/source/level-0/PPC/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-0/PPC/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/.cvsignore (revision 8058) @@ -0,0 +1,6 @@ +*.pfsl +*.p64fsl +*.dfsl +*.d64fsl + +*~.* Index: /branches/experimentation/later/source/level-0/PPC/PPC32/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-0/PPC/PPC32/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/PPC32/.cvsignore (revision 8058) @@ -0,0 +1,6 @@ +*.pfsl +*.p64fsl +*.dfsl +*.d64fsl + +*~.* Index: /branches/experimentation/later/source/level-0/PPC/PPC32/ppc32-bignum.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/PPC32/ppc32-bignum.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/PPC32/ppc32-bignum.lisp (revision 8058) @@ -0,0 +1,1785 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "PPC32-ARCH") + (require "PPC-LAPMACROS") + + ;; Set RES to 1 if (u< x y), to 0 otherwise. + (defppclapmacro sltu (res x y) + `(progn + (subfc ,res ,x ,y) + (subfe ,res ,res ,res) + (neg ,res ,res))) + + (defppclapmacro 48x32-divide (x-hi16 x-lo y freg temp-freg freg2 immx) + `(let ((temp 16) + (temp.h 16) + (temp.l 20) + (zero 8) + (zero.h 8) + (zero.l 12)) + (stwu tsp -24 tsp) + (stw tsp 4 tsp) + (lwi ,immx #x43300000) ; 1075 = 1022+53 + (stw ,immx zero.h tsp) + (stw rzero zero.l tsp) + (lfd ,temp-freg zero tsp) + (rlwimi ,immx ,x-hi16 0 16 31) + (stw ,immx temp.h tsp) + (stw ,x-lo temp.l tsp) + (lfd ,freg temp tsp) + + (fsub ,freg ,freg ,temp-freg) + (lwi ,immx #x43300000) + (stw ,immx temp.h tsp) + (stw ,y temp.l tsp) + (lfd ,freg2 temp tsp) + (lwz tsp 0 tsp) + (fsub ,freg2 ,freg2 ,temp-freg) + (fdiv ,freg ,freg ,freg2) + )) + + ) + +;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs +;;; to be able to return 32 bits somewhere no one looks for real objects. +;;; +;;; The easiest thing to do is to store the 32 raw bits in two fixnums +;;; and return multiple values. +(defppclapfunction %bignum-ref ((bignum arg_y) (i arg_z)) + (vref32 imm0 bignum i imm1) + (digit-h temp0 imm0) + (digit-l temp1 imm0) + (vpush temp0) + (vpush temp1) + (la temp0 8 vsp) ; ?? why not (mr temp0 vsp) before vpushing? + (set-nargs 2) ; that doesn't make any difference. And, in this case, + ; we can get away without setting nargs (since the caller + ; called us with 2 args, but that's horrible style.) + (ba .SPvalues)) + + +;;; Set the 0th element of DEST (a bignum or some other 32-bit ivector) +;;; to the Ith element of the bignum SRC. +(defppclapfunction %ref-digit ((bignum arg_x) (i arg_y) (dest arg_z)) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm0 bignum imm1) + (stw imm0 ppc32::misc-data-offset dest) + (blr)) + +;;; BIGNUM[I] := DIGIT[0] +(defppclapfunction %set-digit ((bignum arg_x) (i arg_y) (digit arg_z)) + (la imm1 ppc32::misc-data-offset i) + (lwz imm0 ppc32::misc-data-offset digit) + (stwx imm0 bignum imm1) + (blr)) + +;;; Return 0 if the 0th digit in X is 0. +(defppclapfunction %digit-zerop ((x arg_z)) + (lwz imm0 ppc32::misc-data-offset x) + (cntlzw imm0 imm0) + (srwi imm0 imm0 5) + (rlwimi imm0 imm0 4 27 27) + (addi arg_z imm0 ppc32::nil-value) + (blr)) + +;;; store the sign of bignum (0 or -1) in the one-word bignum "digit". +(defppclapfunction %bignum-sign-digit ((bignum arg_y) (digit arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (srawi imm0 imm0 31) ;propagate sign bit + (stw imm0 ppc32::misc-data-offset digit) + (blr)) + +;;; Return the sign of bignum (0 or -1) as a fixnum +(defppclapfunction %bignum-sign ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (srawi imm0 imm0 31) ;propagate sign bit + (box-fixnum arg_z imm0) + (blr)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defppclapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (cmpwi imm0 0) + (not imm0 imm0) + (blt @wasneg) + (not imm0 imm0) + @wasneg + (cntlzw imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %digit-0-or-plusp ((bignum arg_y) (idx arg_z)) + (la imm0 ppc32::misc-data-offset idx) + (lwzx imm0 bignum imm0) + (xoris imm0 imm0 #x8000) ; invert sign bit + (srwi imm0 imm0 31) + (bit0->boolean arg_z imm0 imm0) ; return T if sign bit was clear before inversion + (blr)) + +;;; For oddp, evenp +(defppclapfunction %bignum-oddp ((bignum arg_z)) + (lwz imm0 ppc32::misc-data-offset bignum) + (clrlwi imm0 imm0 31) + (bit0->boolean arg_z imm0 imm0) + (blr)) + +(defppclapfunction bignum-plusp ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (xoris imm0 imm0 #x8000) ; invert sign bit + (srwi imm0 imm0 31) + (bit0->boolean arg_z imm0 imm0) ; return T if sign bit was clear before inversion + (blr)) + +(defppclapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (unbox-fixnum imm0 fixnum) + (stw imm0 ppc32::misc-data-offset bignum) + (blr)) + +(defppclapfunction bignum-minusp ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (srwi imm0 imm0 31) + (rlwimi imm0 imm0 4 27 27) + (addi arg_z imm0 ppc32::nil-value) ; return T if sign bit was clear before inversion + (blr)) + + +;;; Add the digits A[I] and B[J], and the incoming carry C (a fixnum). +;;; Store the result in R[K], and return the outgoing carry. +;;; If I is NIL, A is a fixnum. If J is NIL, B is a fixnum. + +(defppclapfunction %add-with-carry ((r 12) (k 8) (c 4) (a 0) (i arg_x) (b arg_y) (j arg_z)) + (cmpwi cr1 j ppc32::nil-value) + (cmpwi cr0 i ppc32::nil-value) + (lwz temp0 a vsp) + (unbox-fixnum imm1 temp0) + (unbox-fixnum imm2 b) + (beq cr0 @got-a) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm1 temp0 imm1) + @got-a + (beq cr1 @got-b) + (la imm2 ppc32::misc-data-offset j) + (lwzx imm2 b imm2) + @got-b + (lwz temp0 c vsp) + (unbox-fixnum imm0 temp0) + (addic imm0 imm0 -1) + (lwz temp1 r vsp) + (lwz temp0 k vsp) + (la vsp 16 vsp) + (adde imm0 imm1 imm2) + (la imm2 ppc32::misc-data-offset temp0) + (stwx imm0 temp1 imm2) + (addze imm0 rzero) + (box-fixnum arg_z imm0) + (blr)) + + + + + +;;; Store the result of A[I] - B[J] - borrow into R[K], returning the borrow. +;;; If I is NIL, A is a fixnum; likewise for J and B. +(defppclapfunction %subtract-with-borrow ((r 12) (k 8) (borrow 4) (a 0) (i arg_x) (b arg_y) (j arg_z)) + (cmpwi cr0 i ppc32::nil-value) + (cmpwi cr1 j ppc32::nil-value) + (lwz temp0 a vsp) + (unbox-fixnum imm2 b) + (unbox-fixnum imm1 temp0) + (beq cr1 @got-b) + (la imm2 ppc32::misc-data-offset j) + (lwzx imm2 b imm2) + @got-b + (beq cr0 @got-a) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm1 temp0 imm1) + @got-a + (lwz temp0 borrow vsp) + (unbox-fixnum imm0 temp0) + (addic imm0 imm0 -1) + (lwz temp0 r vsp) + (lwz temp1 k vsp) + (la vsp 16 vsp) + (subfe imm0 imm2 imm1) + (la imm1 ppc32::misc-data-offset temp1) + (stwx imm0 temp0 imm1) + (addze imm0 rzero) + (box-fixnum arg_z imm0) + (blr)) + +;; multiply i'th digit of x by y and add to result starting at digit i +(defppclapfunction %multiply-and-add-harder-loop-2 + ((x-ptr 4) (y-ptr 0) (resptr arg_x)(residx arg_y) (count arg_z)) + (let ((tem imm0) + (y imm1) + (prod-h imm2) + (prod-l imm3) + (x imm4) + (xptr temp2) + (yidx temp1) + (yptr temp0)) + (lwz xptr x-ptr vsp) + (la tem ppc32::misc-data-offset residx) + (lwzx x xptr tem) + (lwz yptr y-ptr vsp) + (li yidx 0) ; init yidx 0 + (addc prod-h rzero rzero) ; init carry 0, mumble 0 + @loop + (subi count count '1) + (cmpwi count 0) + (la tem ppc32::misc-data-offset yidx) ; get yidx + (lwzx y yptr tem) + (mullw prod-l x y) + (addc prod-l prod-l prod-h) + (mulhwu prod-h x y) + (addze prod-h prod-h) + (la tem ppc32::misc-data-offset residx) + (lwzx y resptr tem) + (addc prod-l prod-l y) + (addze prod-h prod-h) + (stwx prod-l resptr tem) + (addi residx residx '1) + (addi yidx yidx '1) + (bgt @loop) + (la tem ppc32::misc-data-offset residx) + (stwx prod-h resptr tem) + (la vsp 8 vsp) + (blr))) + + + +;;; Multiply X[I] by the unboxed value of the (non-negative) fixnum Y; +;;; add the incoming carry from CARRY[0] to the 64-bit product. Store +;;; the low word of the 64-bit sum in R[0] and the high word in +;;; CARRY[0]. + +(defppclapfunction %multiply-and-add ((r 4) (carry 0) (x arg_y) (i arg_x) (y arg_z)) + (unbox-fixnum imm0 arg_z) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm1 x imm1) + (mulhwu imm2 imm0 imm1) + (mullw imm1 imm0 imm1) + (lwz temp0 carry vsp) + (lwz imm0 ppc32::misc-data-offset temp0) + (addc imm1 imm1 imm0) + (addze imm2 imm2) + (stw imm2 ppc32::misc-data-offset temp0) + (lwz arg_z r vsp) + (la vsp 8 vsp) + (stw imm1 ppc32::misc-data-offset arg_z) + (blr)) + +(defppclapfunction %floor ((q 4) (r 0) (num-high arg_x) (num-low arg_y) (denom-arg arg_z)) + (let ((rem imm0) + (rem-low imm1) + (quo imm2) + (temp imm3) + (denom imm4)) + (lwz denom ppc32::misc-data-offset denom) + (lwz rem ppc32::misc-data-offset num-high) + (lwz rem-low ppc32::misc-data-offset num-low) + (mr temp denom) + (sltu quo rem denom) + (subi temp temp quo) + (and temp temp denom) + (sub rem temp rem) + (li temp0 '32) + @loop + (subi temp0 temp0 '1) + (cmpwi temp0 0) + (slwi rem rem 1) + (srwi temp rem-low 31) + (or rem rem temp) + (slwi rem-low rem-low 1) + (sltu rem rem denom) + (slwi quo quo 1) + (or quo quo temp) + (subi temp temp 1) + (and temp temp denom) + (sub rem rem temp) + (bne @loop) + (not quo quo) + (lwz temp0 q vsp) + (stw quo ppc32::misc-data-offset temp0) + (lwz arg_z r vsp) + (la vsp 8 vsp) + (stw rem ppc32::misc-data-offset arg_z) + (blr))) + +(defppclapfunction %bignum-ref-hi ((bignum arg_y) (i arg_z)) + (la imm1 ppc32::misc-data-offset i) + (lhzx imm0 bignum imm1) + (box-fixnum arg_z imm0) + (blr)) + + +(defppclapfunction %bignum-set ((bignum 0) (i arg_x) (high arg_y) (low arg_z)) + (compose-digit imm0 high low) + (lwz arg_z bignum vsp) + (vset32 imm0 arg_z i imm1) + (la vsp 4 vsp) + (blr)) + + + + +; this is silly +(defppclapfunction %add-the-carry ((b-h arg_x) (b-l arg_y) (carry-in arg_z)) + (let ((a imm0) + (b imm1) + (temp imm2) + (c imm3)) + (compose-digit b b-h b-l) + (unbox-fixnum c carry-in) + (add b c b) + (digit-h temp0 b) + (digit-l temp1 b) + (vpush temp0) + (vpush temp1) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + + + + +;;; %SUBTRACT-WITH-BORROW -- Internal. +;;; +;;; This should be in assembler, and should not cons intermediate results. It +;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and +;;; subtracting a possible incoming borrow. +;;; +;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. +;;; + +(defppclapfunction %subtract-with-borrow-1 ((a-h 4) (a-l 0) (b-h arg_x) (b-l +arg_y) (borrow-in arg_z)) + (let ((a imm0) + (b imm1) + (temp imm2) + (c imm3)) + (lwz temp0 a-h vsp) + (lwz temp1 a-l vsp) + (compose-digit a temp0 temp1) + (compose-digit b b-h b-l) + (unbox-fixnum c borrow-in) + (li temp -1) + (addc temp c temp) + (subfe a b a) + (addze c rzero) + (box-fixnum c c) + (digit-h temp0 a) + (digit-l temp1 a) + (vpush temp0) + (vpush temp1) + (vpush c) + (la temp0 20 vsp) + (set-nargs 3) + (ba .SPvalues))) + + + +(defppclapfunction %subtract-one ((a-h arg_y)(a-l arg_z)) + (let ((a imm0)) + (compose-digit a a-h a-l) + (subi a a 1) + (digit-h temp0 a) + (vpush temp0) + (digit-l temp0 a) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .spvalues))) + + + + +;;; %MULTIPLY-AND-ADD -- Internal. +;;; +;;; This multiplies x-digit and y-digit, producing high and low digits +;;; manifesting the result. Then it adds the low digit, res-digit, and +;;; carry-in-digit. Any carries (note, you still have to add two digits at a +;;; time possibly producing two carries) from adding these three digits get +;;; added to the high digit from the multiply, producing the next carry digit. +;;; Res-digit is optional since two uses of this primitive multiplies a single +;;; digit bignum by a multiple digit bignum, and in this situation there is no +;;; need for a result buffer accumulating partial results which is where the +;;; res-digit comes from. +;;; [slh] I assume that the returned carry "digit" can only be 0, 1 or 2 + + +(defppclapfunction %multiply-and-add-1 ((x-high 8) + (x-low 4) + (y-high 0) + (y-low arg_x) + (carry-in-high arg_y) + (carry-in-low arg_z)) + (let ((x imm0) + (y imm1) + (carry-in imm2) + (lo imm3) + (hi imm4)) + (compose-digit carry-in carry-in-high carry-in-low) + (vpop temp0) + (compose-digit y temp0 y-low) + (vpop temp0) + (vpop temp1) + (compose-digit x temp1 temp0) + (mullw lo x y) + (mulhwu hi x y) + (addc lo lo carry-in) + (addze hi hi) + (digit-h temp0 hi) + (digit-l temp1 hi) + (digit-h temp2 lo) + (digit-l temp3 lo) + (vpush temp0) + (vpush temp1) + (vpush temp2) + (vpush temp3) + (set-nargs 4) + (la temp0 16 vsp) + (ba .SPvalues))) + + +(defppclapfunction %logcount-complement ((bignum arg_y) (idx arg_z)) + (let ((arg imm0) + (shift imm1) + (temp imm2)) + (la arg ppc32::misc-data-offset idx) + (lwzx arg bignum arg) + (not. shift arg) + (li arg_z 0) + (if ne + (progn + @loop + (la temp -1 shift) + (and. shift shift temp) + (la arg_z '1 arg_z) + (bne @loop))) + (blr))) + +(defppclapfunction %logcount ((bignum arg_y) (idx arg_z)) + (let ((arg imm0) + (shift imm1) + (temp imm2)) + (la arg ppc32::misc-data-offset idx) + (lwzx arg bignum arg) + (mr. shift arg) + (li arg_z 0) + (if ne + (progn + @loop + (la temp -1 shift) + (and. shift shift temp) + (la arg_z '1 arg_z) + (bne @loop))) + (blr))) + +; return res +(defppclapfunction bignum-add-loop-2 ((aptr arg_x)(bptr arg_y) (result arg_z)) + (let ((idx imm0) + (count imm1) + (x imm2) + (y imm3) + (len-a temp0) + (len-b temp1) + (tem temp2)) + (li idx ppc32::misc-data-offset) + (lwz imm4 ppc32::misc-header-offset aptr) + (header-length len-a imm4) + (lwz imm4 ppc32::misc-header-offset bptr) + (header-length len-b imm4) + ; make a be shorter one + (cmpw len-a len-b) + (li count 0) + ; initialize carry 0 + (addc x rzero rzero) + (ble @loop) + ; b shorter - swap em + (mr tem len-a) + (mr len-a len-b) + (mr len-b tem) + (mr tem aptr) + (mr aptr bptr) + (mr bptr tem) + @loop + (lwzx y aptr idx) + (lwzx x bptr idx) + (addi count count '1) + (cmpw count len-a) + (adde x x y) + (stwx x result idx) + (addi idx idx '1) + (blt @loop) + ; now propagate carry thru longer (b) using sign of shorter + ;(SUBI imm4 idx '1) ; y has hi order word of a + ;(lwzx y aptr imm4) + (cmpw len-a len-b) + (adde imm4 rzero rzero) ; get carry + (srawi y y 31) ; p.o.s clobbers carry + (addic imm4 imm4 -1) ; restore carry + (beq @l3) ; unless equal + @loop2 + (lwzx x bptr idx) + (adde x x y) + (stwx x result idx) + (addi count count '1) + (cmpw count len-b) + (addi idx idx '1) + (blt @loop2) + ; y has sign of shorter - get sign of longer to x + @l3 + (subi imm4 idx '1) + (lwzx x bptr imm4) + (adde imm4 rzero rzero) ; get carry + (srawi x x 31) ; clobbers carry + (addic imm4 imm4 -1) + (adde x x y) + (stwx x result idx) + (blr))) + +;; same as above but with initial a index and finishes +(defppclapfunction bignum-add-loop-+ ((init-a 0)(aptr arg_x)(bptr arg_y)(length arg_z)) + (let ((idx imm0) + (count imm1) + (x imm2) + (y imm3) + (aidx imm4)) + (li idx ppc32::misc-data-offset) + (lwz aidx init-a vsp) + (addi aidx aidx ppc32::misc-data-offset) + (li count 0) + ; initialize carry 0 + (addc x rzero rzero) + @loop + (lwzx x aptr aidx) + (lwzx y bptr idx) + (adde x x y) + (stwx x aptr aidx) + (addi count count '1) + (cmpw count length) + (addi idx idx '1) + (addi aidx aidx '1) + (blt @loop) + (lwzx x aptr aidx) ; add carry into next one + (adde x x rzero) + (stwx x aptr aidx) + (la vsp 4 vsp) + (blr))) + + + +(defppclapfunction bignum-negate-loop-really ((big arg_x) (len arg_y) (result arg_z)) + (let ((idx imm0) + (one imm1) + (x imm2)) + (li idx ppc32::misc-data-offset) + (li one '1) + ; initialize carry 1 + (li x -1) + (addic x x 1) + @loop + ;(addi count count '1) + ;(cmpw count len) + (subf. len one len) + (lwzx x big idx) + (not x x) + (adde x x rzero) + (stwx x result idx) + (addi idx idx '1) + (bgt @loop) + ; return carry + (li x 0) + (adde x x rzero) + (box-fixnum arg_z x) + (blr))) + +(defppclapfunction bignum-negate-to-pointer ((big arg_x) (len arg_y) (result arg_z)) + (let ((idx imm0) + (one imm1) + (x imm2) + (oidx imm3) + (ptr imm4)) + (li idx ppc32::misc-data-offset) + (li oidx 0) + (macptr-ptr ptr result) + (li one '1) + ; initialize carry 1 + (li x -1) + (addic x x 1) + @loop + ;(addi count count '1) + ;(cmpw count len) + (subf. len one len) + (lwzx x big idx) + (not x x) + (adde x x rzero) + (stwx x ptr oidx) + (addi idx idx '1) + (addi oidx oidx 4) + (bgt @loop) + ; return carry + (li x 0) + (adde x x rzero) + (box-fixnum arg_z x) + (blr))) + +;; she do tolerate len = jidx +(defppclapfunction bignum-shift-left-loop ((nbits 4)(result 0) (bignum arg_x) (len arg_y) (jidx arg_z)) + (let ((y imm0) + (idx imm1) + (bits imm2) + (rbits imm3) + (x imm4) + (iidx temp0) + (resptr temp1)) + (li iidx 0) + (lwz bits nbits vsp) + (lwz resptr result vsp) + (unbox-fixnum bits bits) + (subfic rbits bits 32) + ;(dbg) + (lwz imm4 ppc32::misc-data-offset bignum) + (slw imm4 imm4 bits) + (la y (+ ppc32::misc-data-offset -4) jidx) + (stwx imm4 y resptr) + + (cmpw len jidx) + (beq @done) + @loop + (addi idx iidx ppc32::misc-data-offset) + (lwzx x bignum idx) + (srw x x rbits) + (addi idx idx '1) + (lwzx y bignum idx) + (slw y y bits) + (or x x y) + (addi idx jidx ppc32::misc-data-offset) + (stwx x resptr idx) + (addi jidx jidx '1) + (cmpw jidx len) + (addi iidx iidx '1) + (blt @loop) + @done + ; do first - lo order + + ; do last - hi order + (addi idx iidx ppc32::misc-data-offset) + ;(dbg t) + (lwzx y bignum idx) + (sraw y y rbits) + (addi idx len ppc32::misc-data-offset) + (stwx y resptr idx) + (la vsp 8 vsp) + (blr))) + + + +(defppclapfunction bignum-shift-right-loop-1 ((nbits 4)(result 0) (bignum arg_x) (len arg_y) (iidx arg_z)) + (let ((y imm0) + (idx imm1) + (bits imm2) + (rbits imm3) + (x imm4) + (jidx temp0) + (resptr temp1)) + (li jidx 0) + (lwz bits nbits vsp) + (lwz resptr result vsp) + (unbox-fixnum bits bits) + (cmpw jidx len) + (subfic rbits bits 32) + (bge @done) + @loop + (addi idx iidx ppc32::misc-data-offset) + (lwzx x bignum idx) + (srw x x bits) + (addi idx idx '1) + (lwzx y bignum idx) + (slw y y rbits) + (or x x y) + (addi idx jidx ppc32::misc-data-offset) + (stwx x resptr idx) + (addi jidx jidx '1) + (cmpw jidx len) + (addi iidx iidx '1) + (blt @loop) + @done + (addi idx iidx ppc32::misc-data-offset) + (lwzx x bignum idx) + (sraw x x bits) + (addi idx jidx ppc32::misc-data-offset) + (stwx x resptr idx) + (la vsp 8 vsp) + (blr))) + + +(defppclapfunction %compare-digits ((a arg_x) (b arg_y) (idx arg_z)) + (la imm0 ppc32::misc-data-offset idx) + (lwzx imm1 a imm0) + (lwzx imm0 b imm0) + (cmplw imm1 imm0) + (li arg_z '0) + (beqlr) + (li arg_z '1) + (bgtlr) + (li arg_z '-1) + (blr)) + + + +;; returns number of bits in digit-hi,digit-lo that are sign bits +;; 32 - digits-sign-bits is integer-length + +(defppclapfunction %digits-sign-bits ((hi arg_y) (lo arg_z)) + (rlwinm. imm1 hi (- 16 ppc32::fixnumshift) 0 15) + (rlwimi imm1 lo (- 32 ppc32::fixnumshift) 16 31) + (not imm1 imm1) + (blt @wasneg) + (not imm1 imm1) + @wasneg + (cntlzw imm1 imm1) + (box-fixnum arg_z imm1) + (blr)) + +(defppclapfunction bignum-logtest-loop ((count arg_x) (s1 arg_y) (s2 arg_z)) + (addi imm1 rzero ppc32::misc-data-offset) + @loop + (lwzx imm2 s1 imm1) + (lwzx imm3 s2 imm1) + (and. imm2 imm3 imm2) + (addi imm1 imm1 4) + (bne @true) + (subic. count count 4) + (bgt @loop) + (li arg_z ppc32::nil-value) + (blr) + @true + (li arg_z (+ ppc32::nil-value ppc32::t-offset)) + (blr)) + +;;; dest[idx] <- (lognot src[idx]) +(defppclapfunction %bignum-lognot ((idx arg_x) (src arg_y) (dest arg_z)) + (la imm1 ppc32::misc-data-offset idx) + (lwzx imm0 src imm1) + (not imm0 imm0) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logand x[idx] y[idx]) +(defppclapfunction %bignum-logand ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (and imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logandc2 x[idx] y[idx]) +(defppclapfunction %bignum-logandc2 ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (andc imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logandc1 x[idx] y[idx]) +(defppclapfunction %bignum-logandc1 ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (andc imm0 imm2 imm0) + (stwx imm0 dest imm1) + (blr)) + + + +(defppclapfunction digit-lognot-move ((index arg_x) (source arg_y) (dest arg_z)) + (let ((scaled-index imm1)) + (vref32 imm0 source index scaled-index) ; imm1 has c(index) + data-offset + (not imm0 imm0) + (stwx imm0 dest scaled-index) + (blr))) + +; if dest not nil store unboxed result in dest(0), else return boxed result +(defppclapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (unbox-fixnum w1 fix) + (lwz w2 ppc32::misc-data-offset big) + (cmpwi dest ppc32::nil-value) + (not w2 w2) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (stw w1 ppc32::misc-data-offset dest) + (blr))) + + + +(defppclapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (unbox-fixnum w1 fix) + (lwz w2 ppc32::misc-data-offset big) + (cmpwi dest ppc32::nil-value) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (stw w1 ppc32::misc-data-offset dest) + (blr))) + + + +(defppclapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (unbox-fixnum w1 fix) + (lwz w2 ppc32::misc-data-offset big) + (cmpwi dest ppc32::nil-value) + (not w1 w1) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (stw w1 ppc32::misc-data-offset dest) + (blr))) + +;;; dest[idx] <- (logior x[idx] y[idx]) +(defppclapfunction %bignum-logior ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (or imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logxor x[idx] y[idx]) +(defppclapfunction %bignum-logxor ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (xor imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + + + +(defppclapfunction bignum-xor-loop ((count 0) (s1 arg_x) (s2 arg_y) (dest arg_z)) + (lwz imm0 count vsp) + (addi imm1 rzero ppc32::misc-data-offset) + @loop + (lwzx imm2 s1 imm1) + (lwzx imm3 s2 imm1) + (xor imm2 imm3 imm2) + (subic. imm0 imm0 4) + (stwx imm2 dest imm1) + (addi imm1 imm1 4) + (bgt @loop) + @out + (la vsp 4 vsp) + (blr)) + +#+nomore +(defppclapfunction try-guess-loop-1 ((guess-h 8)(guess-l 4)(len-y 0) + (xidx arg_x) (xptr arg_y) (yptr arg_z)) + (let ((guess imm0) + (carry imm1) + (y imm2) + (x imm2) + (prod-l imm3) + (prod-h imm4) + (tem imm4) + (yidx temp0) + (end-y temp1) + (carry-bit temp2)) + (lwz x guess-h vsp) + (lwz tem guess-l vsp) + (compose-digit guess x tem) + (lwz end-y len-y vsp) + (li yidx 0) + (li carry 0) + (li carry-bit '1) + @loop + ; multiply guess by ydigit, add carry to lo, hi is new carry + ; then get an xdigit subtract prod-lo from it and store result in x (remember carry) + (addi tem yidx ppc32::misc-data-offset) ; get yidx + (lwzx y yptr tem) + (mullw prod-l guess y) + (mulhwu prod-h guess y) + (addc prod-l prod-l carry) + (adde carry prod-h rzero) + ; get back saved carry + (li tem '-1) + (addc tem carry-bit tem) + (addi tem xidx ppc32::misc-data-offset) + (lwzx x xptr tem) + (subfe x prod-l x) + (stwx x xptr tem) + ; save carry + (adde prod-l rzero rzero) + (box-fixnum carry-bit prod-l) + (addi yidx yidx '1) + (cmpw yidx end-y) + (addi xidx xidx '1) + (blt @loop) + ; finally subtract carry from last x digit + @done + (li prod-l '-1) ; get back saved carry again - box clobbered it? + (addc prod-l carry-bit prod-l) + (addi tem xidx ppc32::misc-data-offset) ; maybe still there - nope + (lwzx x xptr tem) + (subfe x carry x) + (stwx x xptr tem) + (la vsp 12 vsp) + (blr))) + +;; x0 is at index, x1 at index-1, x2 at index-2 +;; y1 is at index, y2 at index-1 +;; this doesnt help much +(defppclapfunction truncate-guess-loop ((guess-h 8)(guess-l 4)(x 0) + (xidx arg_x)(yptr arg_y) (yidx arg_z)) + (let ((guess imm0) + (y1 imm1) + (y2 imm1) + (gy1-lo imm2) ; look out below + (gy1-hi imm2) + (gy2-lo imm2) + (gy2-hi imm2) + (xptr temp0) + (m imm3) + (tem imm4) + (y1-idx 28) + (y2-idx 24) + (x0-idx 20) + (x1-idx 16) + (x2-idx 12)) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (lwz y1 guess-h vsp) + (lwz tem guess-l vsp) + (compose-digit guess y1 tem) + (addi tem yidx ppc32::misc-data-offset) + (lwzx y1 yptr tem) + (stw y1 y1-idx tsp) + (subi tem tem 4) + (lwzx y2 yptr tem) + (stw y2 y2-idx tsp) + (lwz xptr x vsp) + (addi tem xidx ppc32::misc-data-offset) + (lwzx y1 xptr tem) ; its x0 + (stw y1 x0-idx tsp) + (subi tem tem 4) + (lwzx y1 xptr tem) + (stw y1 x1-idx tsp) + (subi tem tem 4) + (lwzx y1 xptr tem) + (stw y1 x2-idx tsp) + @loop + (lwz y1 y1-idx tsp) ; get y1 + (mullw gy1-lo guess y1) + (lwz m x1-idx tsp) ; get x1 + (subc m m gy1-lo) ; x1 - gy1-lo => m + (mulhwu gy1-hi guess y1) + (lwz tem x0-idx tsp) ; get x0 + (subfe. tem gy1-hi tem) ; - val not used just cr + (lwz y2 y2-idx tsp) ; get y2 + (mulhwu gy2-hi guess y2) ; does it pay to do this now even tho may not need? + (bne @done) + (cmpl :cr0 gy2-hi m) ; if > or = and foo then more - L means logical means unsigned + (blt @done) ; if < done + (bne @more) ; if = test lo + (mullw gy2-lo guess y2) + (lwz tem x2-idx tsp) ; get x2 + (cmpl :cr0 gy2-lo tem) + (ble @done) + @more + (subi guess guess 1) + (b @loop) + @done + (digit-h temp0 guess) + (vpush temp0) + (digit-l temp0 guess) + (vpush temp0) + (la temp0 20 vsp) + (lwz tsp 0 tsp) + (set-nargs 2) + (ba .spvalues))) + +(defppclapfunction normalize-bignum-loop ((sign arg_x)(res arg_y)(len arg_z)) + (let ((idx imm0) + (usign imm1) + (val imm2)) + (unbox-fixnum usign sign) + (cmpwi len 0) + (addi idx len (- ppc32::misc-data-offset 4)) + (beqlr) ; huh - can this ever happen? + @loop + (lwzx val res idx) + (cmpw val usign) + (subi idx idx '1) + (bne @neq) + (subic. len len '1) + (bgt @loop) + ; fall through - its all sign - return 1 + (li arg_z '1) + (blr) + @neq + (rlwinm usign usign 0 0 0) ; hi bit + (rlwinm val val 0 0 0) + (cmpw usign val) ; is hi bit = sign, if so then done + (beqlr) + (addi len len '1) ; if not, need 1 more + (blr))) + +(defppclapfunction %normalize-bignum-2 ((fixp arg_y)(res arg_z)) + (let ((idx imm0) + (usign imm1) + (val imm2) + (len arg_x) + (oldlen temp0)) + (lwz imm4 (- ppc32::fulltag-misc) res) + (header-length len imm4) + (cmpwi len 0) + (mr oldlen len) + (addi idx len (- ppc32::misc-data-offset 4)) + (beqlr) ; huh - can this ever happen? + (lwzx val res idx) ; high order word + (srawi usign val 31) ; get sign + @loop + (lwzx val res idx) + (cmpw val usign) + (subi idx idx '1) + (bne @neq) + (subic. len len '1) + (bgt @loop) + ; fall through - its all sign - return 1 + (li len '1) + (rlwinm usign usign 0 0 0) ; hi bit + (b @more) + @neq + (rlwinm usign usign 0 0 0) ; hi bit + (rlwinm val val 0 0 0) + (cmpw usign val) ; is hi bit = sign, if so then done + (beq @more) + (addi len len '1) ; if not, need 1 more + (b @big) + @more + (cmpwi :cr1 fixp ppc32::nil-value) + (cmpwi len '1) + (beq :cr1 @big) ; dont return fixnum + (bgt @big) + ;; stuff for maybe fixnum + ;(dbg t) + (lwz val ppc32::misc-data-offset res) + (rlwinm imm4 val 0 0 2) ; hi 3 bits same? - we assume fixnumshift is 2 + (srawi usign usign 2) + (cmpw usign imm4) + (bne @big) + (box-fixnum arg_z val) + (blr) + @big + (cmpw oldlen len) + (beqlr) ; same length - done + (li imm4 ppc32::subtag-bignum) ; set new length + (rlwimi imm4 len (- ppc32::num-subtag-bits ppc32::fixnumshift) 0 (- 31 ppc32::num-subtag-bits)) + (stw imm4 ppc32::misc-header-offset res) + ; 0 to tail if negative + (cmpwi usign 0) + (beqlr) + ; zero from len inclusive to oldlen exclusive + ;(dbg t) + (addi idx len ppc32::misc-data-offset) + @loop2 + (stwx rzero idx res) + (addi len len '1) + (cmpw len oldlen) + (addi idx idx '1) + (blt @loop2) + (blr))) + +(defppclapfunction %count-digit-leading-zeros ((high arg_y) (low arg_z)) + (compose-digit imm0 high low) + (cntlzw imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %count-digit-trailing-zeros ((high arg_y) (low arg_z)) + (compose-digit imm0 high low) + (neg imm1 imm0) + (and imm0 imm0 imm1) + (cntlzw imm0 imm0) + (subfic imm0 imm0 31) + (box-fixnum arg_z imm0) + (blr)) + + +(defppclapfunction %bignum-count-trailing-zero-bits ((bignum arg_z)) + (let ((ndigits arg_x) + (nbits arg_y) + (digit imm0) + (ptr imm1)) + (li ptr ppc32::misc-data-offset) + (li ndigits '-32) + @next + (lwzx digit bignum ptr) + (cmpwi digit 0) + (la ptr 4 ptr) + (addi ndigits ndigits '32) + (beq @next) + (neg ptr digit) + (and digit digit ptr) + (cntlzw digit digit) + (subfic digit digit 31) + (box-fixnum nbits digit) + (add arg_z nbits ndigits) + (blr))) + + +(defppclapfunction %bignum-trim-leading-zeros ((bignum arg_x) + (start arg_y) + (len arg_z)) + (add imm1 start len) + (la imm1 (- ppc32::misc-data-offset 4) imm1) + @loop + (cmpwi cr0 len '1) + (lwzx imm0 bignum imm1) + (cmpwi cr1 imm0 0) + (la imm1 -4 imm1) + (bnelr cr1) + (la len '-1 len) + (bne @loop) + (blr)) + +;;; Set length of bignum to new-len (zeroing out any trailing words between +;;; the old length and the new. +(defppclapfunction %shrink-bignum ((new-len arg_y) (bignum arg_z)) + (let ((old-len temp0) + (old-idx imm0) + (new-idx imm2) + (header imm1)) + (getvheader header bignum) + (header-length old-len header) + (cmpw old-len new-len) + (la old-idx ppc32::misc-data-offset old-len) + (la new-idx ppc32::misc-data-offset new-len) + (beqlr) + @loop + (subi old-idx old-idx 4) + (cmpw old-idx new-idx) + (stwx ppc32::rzero bignum old-idx) + (bne @loop) + (slwi header new-len (- ppc32::num-subtag-bits ppc32::fixnumshift)) + (ori header header ppc32::subtag-bignum) + (stw header ppc32::misc-header-offset bignum) + (blr))) + +;;; Especially when large operands are involved, the GNU Multiple Precision +;;; library's algorithm's are often faster than OpenMCL's. GMP's MPN +;;; library defines operations on "limb vectors", which are basically +;;; just sequences of 32-bit digits (least-significant digit first), which +;;; is just about exactly the same way that OpenMCL stores bignums. +;;; We might want to (eventually) link some or all of GMP into OpenMCL; +;;; in the meantime, it seems that we get some performance benefit from +;;; using GMP representation and algorithms in some mixture of LAP and Lisp. +;;; To approximate the "limb vector" representation, we copy operands to +;;; (and results from) stack-allocated macptrs. Since those macptrs are +;;; word-aligned, we can use fixnums to represent word-aligned pointers. +;;; Obviously, it costs a little to copy back and forth like this; we +;;; only win when operands are fairly large, and when we can replace an +;;; N^2 algorithm with something cheaper. + +;;; Macptr MUST be word-aligned (low 2 bits must be 0). Extract +;;; such an address, return it as a fixnum. +(defppclapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr arg_z ptr) + (blr)) + +;;; Copy the limb SRC points to to where DEST points. +(defppclapfunction copy-limb ((src arg_y) (dest arg_z)) + (lwz imm0 0 src) + (stw imm0 0 dest) + (blr)) + +;;; Return T iff LIMB contains 0. +(defppclapfunction limb-zerop ((limb arg_z)) + (lwz imm0 0 limb) + (cntlzw imm0 imm0) + (srwi imm0 imm0 5) + (bit0->boolean arg_z imm0 imm0) + (blr)) + +;;; Return -1,0,1 according to whether the contents of Y are +;;; <,=,> the contents of Z. +(defppclapfunction compare-limbs ((y arg_y) (z arg_z)) + (lwz imm1 0 z) + (lwz imm0 0 y) + (cmplw imm0 imm1) + (li arg_z 0) + (beqlr) + (li arg_z '1) + (bgtlr) + (li arg_z '-1) + (blr)) + +;;; Add a fixnum to the limb LIMB points to. Ignore overflow. +(defppclapfunction add-fixnum-to-limb ((fixnum arg_y) (limb arg_z)) + (unbox-fixnum imm0 fixnum) + (lwz imm1 0 limb) + (add imm1 imm1 imm0) + (stw imm1 0 limb) + (blr)) + +;;; Store a fixnum value where LIMB points. +(defppclapfunction copy-fixnum-to-limb ((fixnum arg_y) (limb arg_z)) + (unbox-fixnum imm0 fixnum) + (stwu imm0 0 limb) + (blr)) + +;;; Increment a "LIMB VECTOR" (bignum) by a small amount. The caller +;;; knows that carries will only propagate for a word or two. +(defppclapfunction mpn-incr-u ((limb arg_y) (fixby arg_z)) + (let ((by imm0) + (sum imm1)) + (unbox-fixnum by fixby) + @loop + (lwz sum 0 limb) + (add sum sum by) + (cmplw sum by) + (stw sum 0 limb) + (li by 1) + (la limb 4 limb) + (blt @loop) + (blr))) + +;;; Store XP-YP at WP; return carry (0 or 1). +;;; wp, xp, yp: word-aligned, unboxed ptrs (fixnums) +;;; size: boxed fixnum +;;; returns boxed carry +(defppclapfunction mpn-sub-n ((wp 0) (xp arg_x) (yp arg_y) (size arg_z)) + (vpop imm0) + (subi size size '1) + (cmpwi size 0) + (lwz imm3 0 xp) + (lwz imm4 0 yp) + (sub imm1 xp imm0) ; imm1 = xp-wp + (sub imm2 yp imm0) ; imm2 = yp-wp + (addi imm1 imm1 4) ; imm1 = xp-wp+4 + (addi imm2 imm2 4) ; imm2 = yp-wp+4 + (subfc imm3 imm4 imm3) + (stw imm3 0 imm0) ; wp[0] + (beq @done) + @top + (subi size size '1) + (cmpwi size 0) + (lwzx imm3 imm1 imm0) ; imm3 = xp[i] + (lwzx imm4 imm2 imm0) ; imm4 = xp[i] + (subfe imm3 imm4 imm3) + (stwu imm3 4 imm0) + (bne @top) + @done + (subfe imm0 rzero rzero) + (subfic imm0 imm0 0) + (box-fixnum arg_z imm0) + (blr)) + +;;; Store XP+YP at WP; return carry (0 or 1). +;;; wp, xp, yp = word-aligned, unboxed macptrs (fixnums). +;;; size = boxed fixnum +;;; result = boxed carry +(defppclapfunction mpn-add-n ((wp 0) (xp arg_x) (yp arg_y) (size arg_z)) + (vpop imm0) + (subi size size '1) + (cmpwi size 0) + (lwz imm3 0 xp) + (lwz imm4 0 yp) + (sub imm1 xp imm0) ; imm1 = xp-wp + (sub imm2 yp imm0) ; imm2 = yp-wp + (addi imm1 imm1 4) ; imm1 = xp-wp+4 + (addi imm2 imm2 4) ; imm2 = yp-wp+4 + (addc imm3 imm3 imm4) + (stw imm3 0 imm0) ; wp[0] + (beq @done) + @top + (subi size size '1) + (cmpwi size 0) + (lwzx imm3 imm1 imm0) ; imm3 = xp[i] + (lwzx imm4 imm2 imm0) ; imm4 = xp[i] + (adde imm3 imm4 imm3) + (stwu imm3 4 imm0) + (bne @top) + @done + (addze imm0 rzero) + (box-fixnum arg_z imm0) + (blr)) + +;;; Add the single limb LIMB to S1P (propagating carry.) Store the +;;; result at RP. RP and S1P may be the same place, so check for +;;; that and do nothing after carry stops propagating. Return carry. +(defppclapfunction mpn-add-1 ((rp-offset 0) (s1p arg_x) (size arg_y) (limb arg_z)) + (let ((rp temp0)) + (vpop rp) + (subi size size '1) + (cmpwi cr2 size 0) + (cmpw cr1 rp s1p) ;a common case + (subi rp rp 4) + (subi s1p s1p 4) + (lwz imm0 0 limb) + (lwzu imm1 4 s1p) + (addc imm1 imm1 imm0) + (addze. imm0 rzero) + (stwu imm1 4 rp) + (beq cr2 @done) + @top + (beq cr0 @finish) ; branch if no more carry + (subi size size '1) + (cmpwi cr2 size 0) + (lwzu imm1 4 s1p) + (addc imm1 imm1 imm0) + (addze. imm0 rzero) + (stwu imm1 4 rp) + (bne cr2 @top) + (box-fixnum arg_z imm0) + (blr) + @finish + (beq cr1 @done) + @loop + (subi size size '1) + (cmpwi cr2 size 0) + (lwzu imm1 4 s1p) + (stwu imm1 4 rp) + (bne cr2 @loop) + @done + (box-fixnum arg_z imm0) + (blr))) +;;; Multiply the limb vector S1 by the single limb at LIMBPTR, storing +;;; the result at RES. Store the "carry out" (high word of last 64-bit +;;; partial product) at the limb RESULT. +;;; res, s1, limbptr, result: +;;; unboxed, word-aligned ptrs (fixnums). size: boxed fixnum +;;; It'd be hard to transliterate the GMP code here; the GMP version +;;; uses lots more immediate registers than we can easily use in LAP +;;; (and is much more aggressively pipelined). +(defppclapfunction mpn-mul-1 ((res-offset 4) + (s1-offset 0) + (size arg_x) + (limbptr arg_y) + (result arg_z)) + (let ((limb imm0) + (resptr temp0) + (s1 temp1) + (src imm1) + (prod-low imm2) + (prod-high imm3) + (carry imm4)) + (lwz resptr res-offset vsp) + (lwz s1 s1-offset vsp) + (la vsp 8 vsp) + (la resptr -4 resptr) ; pre-decrement + (la s1 -4 s1) + (addic carry carry 0) + (li carry 0) + (lwz limb 0 limbptr) + @loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze carry prod-high) + (stwu prod-low 4 resptr) + (bne @loop) + (stw carry 0 result) + (blr))) + +;;; multiply s1*limb and add result to res +;;; res, s1, limbptr, result: +;;; unboxed, word-aligned ptrs (fixnums). +;;; size: boxed fixnum +;;; limbptr: source "limb". +;;; result: carry out (high word of product). +(defppclapfunction mpn-addmul-1 ((res-offset 4) + (s1-offset 0) + (size arg_x) + (limbptr arg_y) + (result arg_z)) + (let ((limb imm0) + (resptr temp0) + (s1 temp1) + (src imm1) + (prod-low imm2) + (prod-high imm3) + (carry imm4) + (prev imm4)) + (lwz resptr res-offset vsp) + (lwz s1 s1-offset vsp) + (la vsp 8 vsp) + (la resptr -4 resptr) ; pre-decrement + (la s1 -4 s1) + (addic carry carry 0) + (li carry 0) + (lwz limb 0 limbptr) + @loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze prod-high prod-high) + (lwz prev 4 resptr) + (addc prev prev prod-low) + (stwu prev 4 resptr) + (addze carry prod-high) + (bne @loop) + (stw carry 0 result) + (blr))) + +;;; Multiply the UN-word limb vector at UP and the VN-word limb vector +;;; at VP, store the result at RP. +(defppclapfunction mpn-mul-basecase ((rp-offset 4) + (up-offset 0) + (un arg_x) + (vp arg_y) + (vn arg_z)) + (let ((resptr temp0) + (s1 temp1) + (up temp2) + (rp temp3) + (size nargs) + (limb imm0) + (src imm1) + (prod-low imm2) + (prod-high imm3) + (prev imm4) + (carry imm4)) + (lwz resptr rp-offset vsp) + (la rp -4 resptr) + (lwz up up-offset vsp) + (la s1 -4 up) + (la vsp 8 vsp) + (mr size un) + (lwz limb 0 vp) + (subi vn vn '1) + (cmpwi cr2 vn 0) + (li carry 0) + @mul-1-loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze carry prod-high) + (stwu prod-low 4 rp) + (bne @mul-1-loop) + (stw carry 4 rp) + @again + (beq cr2 @done) + (subi vn vn '1) + (cmpwi cr2 vn 0) + (mr rp resptr) + (la resptr 4 resptr) + (la s1 -4 up) + (lwzu limb 4 vp) + (mr size un) + (addic carry carry 0) + (li carry 0) + @addmul-1-loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze prod-high prod-high) + (lwz prev 4 rp) + (addc prev prev prod-low) + (stwu prev 4 rp) + (addze carry prod-high) + (bne @addmul-1-loop) + (stw carry 4 rp) + (b @again) + @done + (li arg_z ppc32::nil-value) + (blr))) + +;;; left-shift src by 1 bit, storing result at res. Return +;;; the bit that was shifted out. +(defppclapfunction mpn-lshift-1 ((resptr arg_x) (s1ptr arg_y) (size-arg arg_z)) + (let ((size temp0) + (last-bit imm0) + (prev imm1) + (curr imm2) + (sleft imm3) + (sright imm4)) + (subi size size-arg '1) + (cmpwi size 0) + (add resptr resptr size-arg) + (add s1ptr s1ptr size-arg) + (lwzu prev -4 s1ptr) + (srwi last-bit prev 31) + (box-fixnum arg_z last-bit) + (beq @end1) + @loop + (subi size size '1) + (cmpwi size 0) + (lwzu curr -4 s1ptr) + (slwi sleft prev 1) + (srwi sright curr 31) + (or sright sright sleft) + (stwu sright -4 resptr) + (beq @end2) + (subi size size '1) + (cmpwi size 0) + (lwzu prev -4 s1ptr) + (slwi sleft curr 1) + (srwi sright prev 31) + (or sright sright sleft) + (stwu sright -4 resptr) + (bne @loop) + @end1 + (slwi sleft prev 1) + (stwu sleft -4 resptr) + (blr) + @end2 + (slwi sleft curr 1) + (stwu sleft -4 resptr) + (blr))) + +;;; Do a 32x32=64 unsigned multiply of the words at X and Y. Store +;;; result (low word first) at RESULT. +(defppclapfunction umulppm ((x arg_x) (y arg_y) (result arg_z)) + (lwz imm0 0 x) + (lwz imm1 0 y) + (mullw imm2 imm0 imm1) + (mulhwu imm3 imm0 imm1) + (stw imm2 0 result) + (stw imm3 4 result) + (blr)) + + +;;; for truncate-by-fixnum etal +;;; doesnt store quotient - just returns rem in 2 halves +(defppclapfunction %floor-loop-no-quo ((q arg_x)(yhi arg_y)(ylo arg_z)) + (let ((a imm1) + (b imm2) + (y imm3) + (quo imm0) + (qidx temp0) + (qlen temp1)) + (lwz imm4 (- ppc32::fulltag-misc) q) + (header-length qlen imm4) + (subi qidx qlen 4) + (mr b rzero) + (compose-digit y yhi ylo) + @loop + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) ; q contents + (rlwimi b imm4 16 16 31) ; hi 16 to lo b + ;(dbg) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (stfd fp0 24 tsp) + (lwz quo (+ 24 4) tsp) ; 16 quo bits above stuff used by 48x32 + ; now mul quo by y + (mullw imm4 y quo) + ; and subtract from a,b + (subfc b imm4 b) + ; new a and b are low 2 digits of this (b) and last digit in array + ; and do it again on low 3 digits + ;(dbg) + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) + (rlwimi b imm4 0 16 31) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stfd fp0 16 tsp) ; quo lo + (subi qidx qidx 4) + (cmpwi :cr1 qidx 0) + (lwz quo (+ 16 4) tsp) + (lwz tsp 0 tsp) + (mullw imm4 y quo) + (subfc b imm4 b) ; b is remainder + (bge :cr1 @loop) + (digit-h temp0 b) + (vpush temp0) + (digit-l temp0 b) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + + +; store result in dest, return rem in 2 halves +(defppclapfunction %floor-loop-quo ((q-stk 0)(dest arg_x)(yhi arg_y)(ylo arg_z)) + (let ((a imm1) + (b imm2) + (y imm3) + (quo imm0) + (qidx temp0) + (qlen temp1) + (q temp2)) + (vpop q) + (lwz imm4 (- ppc32::fulltag-misc) q) + (header-length qlen imm4) + (subi qidx qlen 4) + (mr b rzero) + (compose-digit y yhi ylo) + @loop + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) ; q contents + (rlwimi b imm4 16 16 31) ; hi 16 to lo b + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (stfd fp0 24 tsp) + (lwz quo (+ 24 4) tsp) ; 16 quo bits above stuff used by 48x32 + ; now mul quo by y + (mullw imm4 y quo) + ; and subtract from a,b + (subfc b imm4 b) + ; new a and b are low 2 digits of this (b) and last digit in array + ; and do it again on low 3 digits + ;(dbg) + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) + (rlwimi b imm4 0 16 31) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stfd fp0 16 tsp) ; quo lo + (lwz quo (+ 16 4) tsp) + (mullw imm4 y quo) + (subfc b imm4 b) ; b is remainder + (lwz quo (+ 24 4) tsp) ; quo-hi + (rlwinm quo quo 16 0 15) + (lwz imm4 (+ 16 4) tsp) ; quo lo + (lwz tsp 0 tsp) + (rlwimi quo imm4 0 16 31) + (la imm4 ppc32::misc-data-offset dest) + (stwx quo qidx imm4) + (subic. qidx qidx 4) + (bge @loop) + (digit-h temp0 b) + (vpush temp0) + (digit-l temp0 b) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + +;;; get xidx thing from x, yidx thing from y if same return #xffff +;;; #xffff otherwise get another thing from x and 1- xidx and do as +;;; %floor of xthing otherx ything +;;; Huh? +(defppclapfunction %floor-99 ((x-stk 0)(xidx arg_x)(yptr arg_y)(yidx arg_z)) + (let ((xptr temp0) + (a imm1) + (b imm2) + (y imm3) + (quo imm0)) + (vpop xptr) + (la imm4 ppc32::misc-data-offset XIDX) + (lwzx a xptr imm4) + (la imm4 ppc32::misc-data-offset YIDX) + (lwzx y yptr imm4) + (cmpw a y) + (bne @more) + (li imm4 #xffff) + (rlwinm imm4 imm4 ppc32::fixnumshift (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnum-shift)) + (vpush imm4) + (vpush imm4) + (la temp0 8 vsp) + (set-nargs 2) + (ba .spvalues) + @MORE + ; a has 16 bits from ahi, bhi gets alo blo gets bhi + (la imm4 (- ppc32::misc-data-offset 4) xidx) + (lwzx b xptr imm4) + (rlwinm b b 16 16 31) ; bhi to blo + (rlwimi b a 16 0 15) ; alo to bhi + (rlwinm a a 16 16 31) ; a gets alo + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (stfd fp0 24 tsp) + (lwz quo (+ 24 4) tsp) ; 16 quo bits above stuff used by 48x32 + ; now mul quo by y + (mullw imm4 y quo) + ; and subtract from a,b + (subfc b imm4 b) + ; AND AGAIN + (rlwinm a b -16 16 31) ; a gets b hi + (rlwinm b b 16 0 15) ; b lo to b hi + (la imm4 (- ppc32::misc-data-offset 4) xidx) + (lwzx imm4 imm4 xptr) + (rlwimi b imm4 0 16 31) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stfd fp0 16 tsp) ; quo lo + (lwz quo (+ 24 4) tsp) ; quo-hi + (box-fixnum temp0 quo) + (vpush temp0) + (lwz quo (+ 16 4) tsp) ; quo lo + (lwz tsp 0 tsp) + (box-fixnum temp0 quo) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + +; End of ppc32-bignum.lisp Index: /branches/experimentation/later/source/level-0/PPC/PPC64/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-0/PPC/PPC64/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/PPC64/.cvsignore (revision 8058) @@ -0,0 +1,6 @@ +*.pfsl +*.p64fsl +*.dfsl +*.d64fsl + +*~.* Index: /branches/experimentation/later/source/level-0/PPC/PPC64/ppc64-bignum.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/PPC64/ppc64-bignum.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/PPC64/ppc64-bignum.lisp (revision 8058) @@ -0,0 +1,264 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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. +(defppclapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (unbox-fixnum imm0 fixnum) + (srdi imm1 imm0 32) + (srawi imm2 imm0 31) + (cmpw imm2 imm1) + (stw imm0 ppc64::misc-data-offset bignum) + (li imm2 ppc64::one-digit-bignum-header) + (beq @chop) + (stw imm1 (+ ppc64::misc-data-offset 4) bignum) + (blr) + @chop + (std imm2 ppc64::misc-header-offset bignum) + (blr)) + + + +;;; 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). +(defppclapfunction %multiply-and-add4 ((x 0) (y arg_x) (prev arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-prev imm2) + (unboxed-carry-in imm3) + (result64 imm4) + (high arg_y) + (low arg_z)) + (ld temp0 x vsp) + (unbox-fixnum unboxed-x temp0) + (unbox-fixnum unboxed-y y) + (unbox-fixnum unboxed-prev prev) + (unbox-fixnum unboxed-carry-in carry-in) + (mulld result64 unboxed-x unboxed-y) + (add result64 result64 unboxed-prev) + (add result64 result64 unboxed-carry-in) + (clrlsldi low result64 32 ppc64::fixnumshift) + (clrrdi high result64 32) + (srdi high high (- 32 ppc64::fixnumshift)) + (std high 0 vsp) + (set-nargs 2) + (vpush low) + (la temp0 '2 vsp) + (ba .SPvalues))) + +(defppclapfunction %multiply-and-add3 ((x arg_x) (y arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-carry-in imm2) + (result64 imm3) + (high arg_y) + (low arg_z)) + (unbox-fixnum unboxed-x arg_x) + (unbox-fixnum unboxed-y y) + (unbox-fixnum unboxed-carry-in carry-in) + (mulld result64 unboxed-x unboxed-y) + (add result64 result64 unboxed-carry-in) + (clrlsldi low result64 32 ppc64::fixnumshift) + (clrrdi high result64 32) + (srdi high high (- 32 ppc64::fixnumshift)) + (vpush high) + (set-nargs 2) + (vpush low) + (la temp0 '2 vsp) + (ba .SPvalues))) + +;;; Return the (possibly truncated) 32-bit quotient and remainder +;;; resulting from dividing hi:low by divisor. +(defppclapfunction %floor ((num-high arg_x) (num-low arg_y) (divisor arg_z)) + (let ((unboxed-num imm0) + (unboxed-low imm1) + (unboxed-divisor imm2) + (unboxed-quo imm3) + (unboxed-rem imm4)) + (sldi unboxed-num num-high (- 32 ppc64::fixnumshift)) + (unbox-fixnum unboxed-low num-low) + (unbox-fixnum unboxed-divisor divisor) + (or unboxed-num unboxed-low unboxed-num) + (divdu unboxed-quo unboxed-num unboxed-divisor) + (mulld unboxed-rem unboxed-quo unboxed-divisor) + (sub unboxed-rem unboxed-num unboxed-rem) + (clrlsldi arg_y unboxed-quo 32 ppc64::fixnumshift) + (clrlsldi arg_z unboxed-rem 32 ppc64::fixnumshift) + (mr temp0 vsp) + (vpush arg_y) + (vpush arg_z) + (set-nargs 2) + (ba .SPvalues))) + +;;; Multiply two (UNSIGNED-BYTE 32) arguments, return the high and +;;; low halves of the 64-bit result +(defppclapfunction %multiply ((x arg_y) (y arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-high imm2) + (unboxed-low imm3)) + (unbox-fixnum unboxed-x x) + (unbox-fixnum unboxed-y y) + (mulld imm2 unboxed-x unboxed-y) + (clrlsldi arg_y imm2 32 ppc64::fixnumshift) ; arg_y = low32 + (srdi imm2 imm2 32) + (box-fixnum arg_z imm2) ; arg_z = high32 + (mr temp0 vsp) + (vpush arg_z) + (set-nargs 2) + (vpush arg_y) + (ba .SPvalues))) + +;;; Any words in the "tail" of the bignum should have been +;;; zeroed by the caller. +(defppclapfunction %set-bignum-length ((newlen arg_y) (bignum arg_z)) + (sldi imm0 newlen (- ppc64::num-subtag-bits ppc64::fixnumshift)) + (ori imm0 imm0 ppc64::subtag-bignum) + (std imm0 ppc64::misc-header-offset bignum) + (blr)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defppclapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-size imm0 bignum imm0) + (sldi imm0 imm0 2) + (la imm0 (- ppc64::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (cmpwi imm0 0) + (not imm0 imm0) + (blt @wasneg) + (not imm0 imm0) + @wasneg + (cntlzw imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %signed-bignum-ref ((bignum arg_y) (index arg_z)) + (srdi imm0 index 1) + (la imm0 ppc64::misc-data-offset imm0) + (lwax imm0 bignum imm0) + (box-fixnum arg_z imm0) + (blr)) + + +;;; 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. +(defppclapfunction %maybe-fixnum-from-one-or-two-digit-bignum ((bignum arg_z)) + (ld imm1 ppc64::misc-header-offset bignum) + (cmpdi cr1 imm1 ppc64::one-digit-bignum-header) + (cmpdi cr2 imm1 ppc64::two-digit-bignum-header) + (beq cr1 @one) + (bne cr2 @no) + (ld imm0 ppc64::misc-data-offset bignum) + (rotldi imm0 imm0 32) + (box-fixnum arg_z imm0) + (unbox-fixnum imm1 arg_z) + (cmpd imm0 imm1) + (beqlr) + @no + (li arg_z nil) + (blr) + @one + (lwa imm0 ppc64::misc-data-offset bignum) + (box-fixnum arg_z imm0) + (blr)) + + +(defppclapfunction %digit-logical-shift-right ((digit arg_y) (count arg_z)) + (unbox-fixnum imm0 digit) + (unbox-fixnum imm1 count) + (srw imm0 imm0 imm1) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %ashr ((digit arg_y) (count arg_z)) + (unbox-fixnum imm0 digit) + (unbox-fixnum imm1 count) + (sraw imm0 imm0 imm1) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %ashl ((digit arg_y) (count arg_z)) + (unbox-fixnum imm0 digit) + (unbox-fixnum imm1 count) + (slw imm0 imm0 imm1) + (clrlsldi arg_z imm0 32 ppc64::fixnumshift) + (blr)) + +(defppclapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr imm0 ptr) + (andi. imm1 imm0 7) + (li arg_z nil) + (bne @done) + (mr arg_z imm0) + @done + (blr)) + +(defppclapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (ld w2 ppc64::misc-data-offset big) + (unbox-fixnum w1 fix) + (rotldi w2 w2 32) + (cmpdi dest nil) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (rotldi w1 w1 32) + (std w1 ppc64::misc-data-offset dest) + (blr))) + + + +(defppclapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) + (cmpdi dest nil) + (ld imm1 ppc64::misc-data-offset big) + (unbox-fixnum imm0 fix) + (rotldi imm1 imm1 32) + (andc imm1 imm0 imm1) + (bne @store) + (box-fixnum arg_z imm1) + (blr) + @store + (rotldi imm1 imm1 32) + (std imm1 ppc64::misc-data-offset dest) + (blr)) + +(defppclapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) + (cmpdi dest nil) + (ld imm1 ppc64::misc-data-offset big) + (unbox-fixnum imm0 fix) + (rotldi imm1 imm1 32) + (andc imm1 imm1 imm0) + (bne @store) + (box-fixnum arg_z imm1) + (blr) + @store + (rotldi imm1 imm1 32) + (std imm1 ppc64::misc-data-offset dest) + (blr)) + + Index: /branches/experimentation/later/source/level-0/PPC/ppc-array.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-array.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-array.lisp (revision 8058) @@ -0,0 +1,847 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + #+ppc32-target + (require "PPC32-ARCH") + #+ppc64-target + (require "PPC64-ARCH") + (require "PPC-LAPMACROS")) + + +;;; Users of this shouldn't make assumptions about return value. + + +#+ppc32-target +(eval-when (:compile-toplevel :execute) +;;; Assumptions made by %init-misc + (assert (and (< ppc32::max-32-bit-ivector-subtag + ppc32::max-8-bit-ivector-subtag + ppc32::max-16-bit-ivector-subtag) + (eql ppc32::max-32-bit-ivector-subtag ppc32::subtag-simple-base-string) + (eql ppc32::max-16-bit-ivector-subtag ppc32::subtag-s16-vector) + (eql ppc32::max-8-bit-ivector-subtag 223)))) + +#+ppc32-target +(defppclapfunction %init-misc ((val arg_y) + (miscobj arg_z)) + (getvheader imm0 miscobj) + (header-size imm3 imm0) + (cmpwi cr3 imm3 0) + (extract-fulltag imm1 imm0) + (cmpwi cr0 imm1 ppc32::fulltag-nodeheader) + (extract-lowbyte imm2 imm0) + (beqlr cr3) ; Silly 0-length case + (li imm4 ppc32::misc-data-offset) + (bne cr0 @imm) + ; Node vector. Don't need to memoize, since initial value is + ; older than vector. + @node-loop + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (stwx val miscobj imm4) + (la imm4 4 imm4) + (bne cr0 @node-loop) + (blr) + @imm + (cmpwi cr0 imm2 ppc32::subtag-double-float-vector) + (cmpwi cr1 imm2 ppc32::max-32-bit-ivector-subtag) + (cmpwi cr2 imm2 ppc32::max-8-bit-ivector-subtag) + (cmpwi cr3 imm2 ppc32::max-16-bit-ivector-subtag) + (extract-typecode imm0 val :CR6) ; don't clobber CR0 + (cmpwi cr7 imm0 ppc32::tag-fixnum) + (beq cr0 @dfloat) + (ble cr1 @32) + (ble cr2 @8) + (ble cr3 @16) + ; Bit vector. + (cmplwi cr0 val '1) + (la imm3 31 imm3) + (srwi imm3 imm3 5) + (unbox-fixnum imm0 val) + (neg imm0 imm0) + (ble+ cr0 @set-32) + @bad + (li arg_x '#.$xnotelt) + (save-lisp-context) + (set-nargs 3) + (call-symbol %err-disp) + @dfloat + (cmpwi cr0 imm0 ppc32::subtag-double-float) + (li imm4 ppc32::misc-dfloat-offset) + (bne- cr0 @bad) + (lfd fp0 ppc32::double-float.value val) + @dfloat-loop + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (stfdx fp0 miscobj imm4) + (la imm4 8 imm4) + (bne cr0 @dfloat-loop) + (blr) + @32 + (cmpwi cr4 imm2 ppc32::subtag-s32-vector) + (cmpwi cr0 imm2 ppc32::subtag-single-float-vector) + (cmpwi cr2 imm0 ppc32::subtag-bignum) + (cmpwi cr3 imm2 ppc32::subtag-fixnum-vector) + (beq cr1 @char32) ; ppc32::max-32-bit-ivector-subtag + (beq cr4 @s32) + (beq cr3 @fixnum) + (bne cr0 @u32) + ;@sfloat + (cmpwi cr0 imm0 ppc32::subtag-single-float) + (bne- cr0 @bad) + (lwz imm0 ppc32::single-float.value val) + (b @set-32) + @fixnum + (unbox-fixnum imm0 val) + (beq+ cr7 @set-32) + (b @bad) + @char32 + (unbox-base-char imm0 val cr0) + (b @set-32) + @s32 + (unbox-fixnum imm0 val) + (beq+ cr7 @set-32) + (bne- cr2 @bad) + (getvheader imm0 val) + (cmpwi cr0 imm0 (logior (ash 1 ppc32::num-subtag-bits) ppc32::subtag-bignum)) + (lwz imm0 ppc32::misc-data-offset val) + (beq+ cr0 @set-32) + (b @bad) + @u32 + (extract-unsigned-byte-bits. imm0 val 30) + (unbox-fixnum imm0 val) + (beq cr0 @set-32) + (bne- cr2 @bad) + ; a one-digit bignum is ok if that digit is positive. + ; a two-digit bignum is ok if the sign-digit is 0. + (getvheader imm0 val) + (cmpwi cr2 imm0 (logior (ash 2 ppc32::num-subtag-bits) ppc32::subtag-bignum)) + (lwz imm0 ppc32::misc-data-offset val) + (cmpwi cr3 imm0 0) + (bgt- cr2 @bad) ; more than two digits. + (beq cr2 @two-digits) + (bgt+ cr3 @set-32) + (b @bad) + @two-digits + (lwz imm1 (+ 4 ppc32::misc-data-offset) val) + (cmpwi cr0 imm1 0) + (bne- cr0 @bad) + (b @set-32) + @16 + (cmpwi cr0 imm2 ppc32::subtag-u16-vector) + (la imm3 1 imm3) + (srwi imm3 imm3 1) + (beq cr3 @s16) ; ppc32::max-16-bit-ivector-subtag + (extract-unsigned-byte-bits. imm0 val 16) + (unbox-fixnum imm0 val) + (beq+ cr0 @set-16) + (b @bad) + @s16 + (slwi imm0 val (- 32 (+ 16 ppc32::fixnumshift))) + (srawi imm0 imm0 (- 32 (+ 16 ppc32::fixnumshift))) + (cmpw cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-16) + (b @bad) + @8 + (cmpwi cr0 imm0 ppc32::subtag-s8-vector) + (la imm3 3 imm3) + (srwi imm3 imm3 2) + (beq cr2 @char8) ; ppc32::max-8-bit-ivector-subtag + (beq cr0 @s8) + (extract-unsigned-byte-bits. imm0 val 8) + (unbox-fixnum imm0 val) + (beq+ cr0 @set-8) + (b @bad) + @s8 + (slwi imm0 val (- 32 (+ 8 ppc32::fixnumshift))) + (srawi imm0 imm0 (- 32 (+ 8 ppc32::fixnumshift))) + (cmpw cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-8) + (b @bad) + @char8 + (unbox-base-char imm0 val cr0) ; this type checks val + @set-8 ; propagate low 8 bits into low 16 + (rlwimi imm0 imm0 8 (- 32 16) (- 31 8)) + @set-16 ; propagate low 16 bits into high 16 + (rlwimi imm0 imm0 16 0 (- 31 16)) + @set-32 + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (stwx imm0 miscobj imm4) + (la imm4 4 imm4) + (bne cr0 @set-32) + (blr)) + +#+ppc64-target +(defppclapfunction %init-misc ((val arg_y) + (miscobj arg_z)) + (getvheader imm0 miscobj) + ;(extract-lowtag imm2 imm0) + (clrldi imm2 imm0 (- 64 ppc64::nlowtagbits)) + (header-size imm3 imm0) + (cmpdi cr3 imm3 0) + (extract-fulltag imm1 imm0) + (cmpdi cr0 imm2 ppc64::lowtag-nodeheader) + (extract-lowbyte imm2 imm0) + (beqlr cr3) ; Silly 0-length case + (li imm4 ppc64::misc-data-offset) + (bne cr0 @imm) + ;; Node vector. Don't need to memoize, since initial value is + ;; older than vector. + @node-loop + (cmpdi cr0 imm3 1) + (subi imm3 imm3 1) + (stdx val miscobj imm4) + (la imm4 ppc64::node-size imm4) + (bne cr0 @node-loop) + (blr) + @imm + (extract-typecode imm0 val) + (cmpdi cr0 imm1 ppc64::ivector-class-64-bit) + (cmpdi cr1 imm1 ppc64::ivector-class-32-bit) + (cmpdi cr2 imm1 ppc64::ivector-class-8-bit) + (cmpwi cr7 imm0 ppc64::tag-fixnum) + (beq cr0 @64) + (beq cr1 @32) + (beq cr2 @8) + ;; u16, s16, or bit-vector. Val must be a fixnum. + (cmpdi cr0 imm2 ppc64::subtag-u16-vector) + (cmpdi cr1 imm2 ppc64::subtag-s16-vector) + (bne cr7 @bad) ; not a fixnum + (beq cr0 @u16) + (beq cr1 @s16) + ; Bit vector. + (cmpldi cr0 val '1) + (la imm3 31 imm3) + (srdi imm3 imm3 5) + (unbox-fixnum imm0 val) + (neg imm0 imm0) + (ble+ cr0 @set-32) + @bad + (li arg_x '#.$xnotelt) + (save-lisp-context) + (set-nargs 3) + (call-symbol %err-disp) + @64 + (cmpdi cr3 imm2 ppc64::subtag-fixnum-vector) + (cmpdi cr1 imm2 ppc64::subtag-double-float-vector) + (cmpdi cr2 imm2 ppc64::subtag-s64-vector) + (beq cr3 @fixnum) + (beq cr1 @dfloat) + (beq cr2 @u64) + ;; s64 + (unbox-fixnum imm0 val) + (beq cr7 @set-64) ; all fixnums are (SIGNED-BYTE 64) + (bne cr3 @bad) ; as are 2-digit bignums + (getvheader imm1 val) + (ld imm0 ppc64::misc-data-offset val) + (cmpdi imm1 ppc64::two-digit-bignum-header) + (rotldi imm0 imm0 32) + (beq @set-64) + (b @bad) +@fixnum + (unbox-fixnum imm0 val) + (beq cr7 @set-64) ; all fixnums are (SIGNED-BYTE 64) + (b @bad) ; as are 2-digit bignums + ;; u64 if fixnum and positive, 2-digit bignum and positive, or + ;; 3-digit bignum with most-significant digit 0. + @u64 + (cmpdi cr2 val 0) + (bne cr7 @u64-maybe-bignum) + (bge cr2 @set-64) + (b @bad) + @u64-maybe-bignum + (bne cr3 @bad) + (ld imm0 ppc64::misc-data-offset val) + (getvheader imm1 val) + (rotldi imm0 imm0 32) + (cmpdi cr2 imm1 ppc64::two-digit-bignum-header) + (cmpdi cr3 imm1 ppc64::three-digit-bignum-header) + (cmpdi cr0 imm0 0) + (beq cr2 @u32-two-digit) + (bne cr3 @bad) + (lwz imm1 (+ 8 ppc64::misc-data-offset) val) + (cmpwi imm0 0) + (beq @set-64) + (b @bad) + @u32-two-digit + (bgt cr0 @set-64) + (b @bad) + @dfloat + (cmpdi cr0 imm0 ppc64::subtag-double-float) + (bne- cr0 @bad) + (ld imm0 ppc64::double-float.value val) + (b @set-64) + @32 + (cmpdi cr3 imm2 ppc64::subtag-simple-base-string) + (cmpdi cr2 imm2 ppc64::subtag-s32-vector) + (cmpdi cr0 imm2 ppc64::subtag-single-float-vector) + (beq cr3 @char32) + (beq cr2 @s32) + (bne cr0 @u32) + ;@sfloat + (cmpdi cr0 imm0 ppc64::subtag-single-float) + (srdi imm0 val 32) + (bne- cr0 @bad) + (b @set-32) + @s32 + ;; Must be a fixnum (and a (SIGNED-BYTE 32)). + (bne cr7 @bad) + (unbox-fixnum imm0 val) + (sldi imm1 imm0 32) + (sradi imm1 imm1 32) + (cmpd imm1 imm0) + (bne @bad) + (b @set-32) + @char32 + (unbox-base-char imm0 val cr0) ; this type checks val + (b @set-32) + @u32 + ;; Also has to be a fixnum (and an (UNSIGNED-BYTE 32)). + (unbox-fixnum imm0 val) + (clrrdi. imm1 imm0 32) ; ~Z if any high bits set + (bne cr7 @bad) + (bne cr0 @bad) + (b @set-32) + @u16 + (unbox-fixnum imm0 val) + (clrrdi. imm1 imm0 16) + (bne cr7 @bad) + (bne cr0 @bad) + (b @set-16) + @s16 + (sldi imm0 val (- 64 (+ 16 ppc64::fixnumshift))) + (srawi imm0 imm0 (- 64 (+ 16 ppc64::fixnumshift))) + (cmpw cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-16) + (b @bad) + @8 + (cmpdi cr0 imm2 ppc64::subtag-s8-vector) + (beq cr0 @s8) + (extract-unsigned-byte-bits. imm0 val 8) + (unbox-fixnum imm0 val) + (beq+ cr0 @set-8) + (b @bad) + @s8 + (sldi imm0 val (- 64 (+ 8 ppc64::fixnumshift))) + (sradi imm0 imm0 (- 64 (+ 8 ppc64::fixnumshift))) + (cmpd cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-8) + (b @bad) + @char8 + (unbox-base-char imm0 val cr0) ; this type checks val + @set-8 ; propagate low 8 bits into low 16 + (la imm3 1 imm3) + (rlwimi imm0 imm0 8 (- 32 16) (- 31 8)) + (srdi imm3 imm3 1) + @set-16 ; propagate low 16 bits into high 16 + (la imm3 1 imm3) + (rlwimi imm0 imm0 16 0 (- 31 16)) + (srdi imm3 imm3 1) + @set-32 ; propagate low 32 bits into high 32 + (la imm3 1 imm3) + (rldimi imm0 imm0 32 0) + (srdi imm3 imm3 1) + @set-64 + (cmpdi cr0 imm3 1) + (subi imm3 imm3 1) + (stdx imm0 miscobj imm4) + (la imm4 8 imm4) + (bne cr0 @set-64) + (blr)) + +;;; 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. +#+ppc32-target +(defppclapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z)) + (let ((oldv save0) + (oldsize save1) + (oldsubtag save2) + (start-offset save3)) + (save-lisp-context) + (:regsave save3 0) + (vpush save0) + (vpush save1) + (vpush save2) + (vpush save3) + (mr oldv oldv-arg) + (mr start-offset start-arg) + (getvheader imm0 oldv) + (header-length oldsize imm0) + (header-subtag[fixnum] oldsubtag imm0) + (mr arg_y newsize) + (mr arg_z oldsubtag) + (bla .SPmisc-alloc) + (extrwi imm0 oldsubtag ppc32::ntagbits (- 32 (+ ppc32::fixnumshift ppc32::ntagbits))) + (cmpwi cr0 oldsize 0) + (cmpwi cr1 imm0 ppc32::fulltag-nodeheader) + (cmpwi cr2 oldsubtag '#.ppc32::max-32-bit-ivector-subtag) + (la imm1 ppc32::misc-data-offset start-offset) + (li imm3 ppc32::misc-data-offset) + (beq cr0 @done) + (bne cr1 @imm) + ;; copy nodes. New vector is "new", so no memoization required. + @node-loop + (cmpwi cr0 oldsize '1) + (lwzx temp0 oldv imm1) + (addi imm1 imm1 4) + (subi oldsize oldsize '1) + (stwx temp0 arg_z imm3) + (addi imm3 imm3 4) + (bne cr0 @node-loop) + ;;Restore registers. New vector's been in arg_z all this time. + @done + (lwz save3 0 vsp) + (lwz save2 4 vsp) + (lwz save1 8 vsp) + (lwz save0 12 vsp) + (restore-full-lisp-context) + (blr) + @imm + (unbox-fixnum imm2 oldsize) + (unbox-fixnum imm3 start-offset) + (li imm1 ppc32::misc-data-offset) + (la imm4 ppc32::misc-data-offset start-offset) + (cmpwi cr1 oldsubtag '#.ppc32::max-8-bit-ivector-subtag) + (cmpwi cr0 oldsubtag '#.ppc32::max-16-bit-ivector-subtag) + (ble cr2 @fullword-loop) + (cmpwi cr2 oldsubtag '#.ppc32::subtag-bit-vector) + (ble cr1 @8-bit) + (ble cr0 @16-bit) + (beq cr2 @1-bit) + ;; 64-bit (double-float) vectors. There's a different + ;; initial offset, but we're always word-aligned, so that + ;; part's easy. + (li imm1 ppc32::misc-dfloat-offset) ; scaled destination pointer + (slwi imm2 imm2 1) ; twice as many fullwords + (slwi imm3 imm3 3) ; convert dword count to byte offset + (la imm4 ppc32::misc-dfloat-offset imm3) ; scaled source pointer + (b @fullword-loop) + ;; The bitvector case is hard if START-OFFSET isn't on an 8-bit boundary, + ;; and can be turned into the 8-bit case otherwise. + ;; The 8-bit case is hard if START-OFFSET isn't on a 16-bit boundary, + ;; and can be turned into the 16-bit case otherwise. + ;; The 16-bit case is hard if START-OFFSET isn't on a 32-bit boundary, + ;; and can be turned into the 32-bit case otherwise. + ;; Hmm. + @1-bit + (clrlwi. imm0 imm3 (- 32 3)) + (bne- cr0 @hard-1-bit) + (srwi imm3 imm3 3) ; bit offset to byte offset + (addi imm2 imm2 7) + (srwi imm2 imm2 3) ; bit count to byte count + @8-bit + ; If the byte offset's even, copy half as many halfwords + (clrlwi. imm0 imm3 (- 32 1)) + (bne- cr0 @hard-8-bit) + (addi imm2 imm2 1) + (srwi imm2 imm2 1) ; byte count to halfword count + (srwi imm3 imm3 1) ; byte offset to halfword offset + @16-bit + ; If the halfword offset's even, copy half as many fullwords + (clrlwi. imm0 imm3 (- 32 1)) + (bne- cr0 @hard-16-bit) + (addi imm2 imm2 1) + (srwi imm2 imm2 1) ; halfword count to fullword count + (li imm1 ppc32::misc-data-offset) + @fullword-loop + (cmpwi cr0 imm2 1) + (lwzx imm0 oldv imm4) + (addi imm4 imm4 4) + (subi imm2 imm2 1) + (stwx imm0 arg_z imm1) + (addi imm1 imm1 4) + (bne cr0 @fullword-loop) + (b @done) + ;;; This can just do a uvref/uvset loop. Cases that can + ;;; cons (x32, double-float) have already been dealt with. + @hard-1-bit + @hard-8-bit + @hard-16-bit + (let ((newv save4) + (outi save5) + (oldlen save6)) + (vpush save4) + (vpush save5) + (vpush save6) + (mr newv arg_z) + (sub oldlen oldsize start-offset) + (li outi 0) + @hard-loop + (mr arg_y oldv) + (mr arg_z start-offset) + (bla .SPmisc-ref) + (mr arg_x newv) + (mr arg_y outi) + (bla .SPmisc-set) + (la outi '1 outi) + (cmpw cr0 outi oldlen) + (la start-offset '1 start-offset) + (bne @hard-loop) + (mr arg_z newv) + (vpop save6) + (vpop save5) + (vpop save4) + (b @done)))) + +#+ppc64-target +(defppclapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z)) + (let ((oldv save0) + (oldsize save1) + (oldsubtag save2) + (start-offset save3)) + (save-lisp-context) + (:regsave save3 0) + (vpush save0) + (vpush save1) + (vpush save2) + (vpush save3) + (mr oldv oldv-arg) + (mr start-offset start-arg) + (getvheader imm0 oldv) + (header-length oldsize imm0) + (header-subtag[fixnum] oldsubtag imm0) + (mr arg_y newsize) + (mr arg_z oldsubtag) + (bla .SPmisc-alloc) + (unbox-fixnum imm0 oldsubtag) + (extract-lowtag imm1 imm0) + (extract-fulltag imm2 imm0) + (cmpdi cr0 oldsize 0) + (cmpdi cr1 imm1 ppc64::lowtag-nodeheader) + (cmpdi cr2 imm2 ppc64::ivector-class-8-bit) + (cmpdi cr3 imm2 ppc64::ivector-class-32-bit) + (cmpdi cr4 imm2 ppc64::ivector-class-64-bit) + (cmpdi cr5 imm0 ppc64::subtag-bit-vector) + (li imm3 ppc64::misc-data-offset) + (beq cr0 @done) + (bne cr1 @imm) + (la imm1 ppc64::misc-data-offset start-offset) + ;; copy nodes. New vector is "new", so no memoization required. + @node-loop + (cmpdi cr0 oldsize '1) + (ldx temp0 oldv imm1) + (addi imm1 imm1 8) + (subi oldsize oldsize '1) + (stdx temp0 arg_z imm3) + (addi imm3 imm3 8) + (bne cr0 @node-loop) + ;;Restore registers. New vector's been in arg_z all this time. + @done + (ld save3 0 vsp) + (ld save2 8 vsp) + (ld save1 16 vsp) + (ld save0 24 vsp) + (restore-full-lisp-context) + (blr) + @imm + (beq cr2 @8-bit) + (beq cr3 @32-bit) + (beq cr4 @64-bit) + (beq cr5 @1-bit) + (srdi imm1 start-offset 2) + (la imm1 ppc64::misc-data-offset imm1) + @16-loop + (cmpdi cr0 oldsize '1) + (lhzx imm4 oldv imm1) + (addi imm1 imm1 2) + (subi oldsize oldsize '1) + (sthx imm4 arg_z imm3) + (addi imm3 imm3 2) + (bne cr0 @16-loop) + (b @done) + @8-bit + (srdi imm1 start-offset 3) + (la imm1 ppc64::misc-data-offset imm1) + @8-loop + (cmpdi cr0 oldsize '1) + (lbzx imm4 oldv imm1) + (addi imm1 imm1 1) + (subi oldsize oldsize '1) + (stbx imm4 arg_z imm3) + (addi imm3 imm3 1) + (bne cr0 @8-loop) + (b @done) + @32-bit + (srdi imm1 start-offset 1) + (la imm1 ppc64::misc-data-offset imm1) + @32-loop + (cmpdi cr0 oldsize '1) + (lwzx imm4 oldv imm1) + (addi imm1 imm1 4) + (subi oldsize oldsize '1) + (stwx imm4 arg_z imm3) + (addi imm3 imm3 4) + (bne cr0 @32-loop) + (b @done) + @64-bit + (la imm1 ppc64::misc-data-offset start-offset) + @64-loop + (cmpdi cr0 oldsize '1) + (ldx imm4 oldv imm1) + (addi imm1 imm1 8) + (subi oldsize oldsize '1) + (stdx imm4 arg_z imm3) + (addi imm3 imm3 8) + (bne cr0 @64-loop) + (b @done) + @1-bit + (let ((newv save4) + (outi save5) + (oldlen save6)) + (vpush save4) + (vpush save5) + (vpush save6) + (mr newv arg_z) + (sub oldlen oldsize start-offset) + (li outi 0) + @hard-loop + (mr arg_y oldv) + (mr arg_z start-offset) + (bla .SPmisc-ref) + (mr arg_x newv) + (mr arg_y outi) + (bla .SPmisc-set) + (la outi '1 outi) + (cmpd cr0 outi oldlen) + (la start-offset '1 start-offset) + (bne @hard-loop) + (mr arg_z newv) + (vpop save6) + (vpop save5) + (vpop save4) + (b @done)))) + + +;;; argument is a vector header or an array header. Or else. +(defppclapfunction %array-header-data-and-offset ((a arg_z)) + (let ((offset arg_y) + (disp arg_x) + (temp temp0)) + (li offset 0) + (mr temp a) + @loop + (ldr a target::arrayH.data-vector temp) + (lbz imm0 target::misc-subtag-offset a) + (cmpri cr0 imm0 target::subtag-vectorH) + (ldr disp target::arrayH.displacement temp) + (mr temp a) + (add offset offset disp) + (ble cr0 @loop) + (vpush a) + (vpush offset) + (set-nargs 2) + (la temp0 (* 2 (ash 1 target::word-shift)) vsp) + (ba .SPvalues))) + + +;;; If the bit-arrays are all simple-bit-vectorp, we can do the operations +;;; 32 bits at a time. (other case have to worry about alignment/displacement.) +#+ppc32-target +(defppclapfunction %simple-bit-boole ((op 0) (b1 arg_x) (b2 arg_y) (result arg_z)) + (la imm0 4 vsp) + (save-lisp-context imm0) + (vector-size imm4 result imm4) + (srwi. imm3 imm4 5) + (clrlwi imm4 imm4 27) + (bl @get-dispatch) + (cmpwi cr1 imm4 0) + (mflr loc-pc) + (lwz temp0 op vsp) + (add loc-pc loc-pc temp0) + (add loc-pc loc-pc temp0) + (mtctr loc-pc) + (li imm0 ppc32::misc-data-offset) + (b @testw) + @nextw + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (lwzx imm1 b1 imm0) + (lwzx imm2 b2 imm0) + (bctrl) + (stwx imm1 result imm0) + (addi imm0 imm0 4) + @testw + (bne cr0 @nextw) + (beq cr1 @done) + ;; Not sure if we need to make this much fuss about the partial word + ;; in this simple case, but what the hell. + (lwzx imm1 b1 imm0) + (lwzx imm2 b2 imm0) + (bctrl) + (lwzx imm2 result imm0) + (slw imm2 imm2 imm4) + (srw imm2 imm2 imm4) + (subfic imm4 imm4 32) + (srw imm1 imm1 imm4) + (slw imm1 imm1 imm4) + (or imm1 imm1 imm2) + (stwx imm1 result imm0) + @done + (restore-full-lisp-context) + (blr) + + @get-dispatch + (blrl) + @disptach + (li imm1 0) ; boole-clr + (blr) + (li imm1 -1) ; boole-set + (blr) + (blr) ; boole-1 + (blr) + (mr imm1 imm2) ; boole-2 + (blr) + (not imm1 imm1) ; boole-c1 + (blr) + (not imm1 imm2) ; boole-c2 + (blr) + (and imm1 imm1 imm2) ; boole-and + (blr) + (or imm1 imm1 imm2) ; boole-ior + (blr) + (xor imm1 imm1 imm2) ; boole-xor + (blr) + (eqv imm1 imm1 imm2) ; boole-eqv + (blr) + (nand imm1 imm1 imm2) ; boole-nand + (blr) + (nor imm1 imm1 imm2) ; boole-nor + (blr) + (andc imm1 imm2 imm1) ; boole-andc1 + (blr) + (andc imm1 imm1 imm2) ; boole-andc2 + (blr) + (orc imm1 imm2 imm1) ; boole-orc1 + (blr) + (orc imm1 imm1 imm2) ; boole-orc2 + (blr)) + +#+ppc64-target +(defppclapfunction %simple-bit-boole ((op 0) (b1 arg_x) (b2 arg_y) (result arg_z)) + (la imm0 8 vsp) + (save-lisp-context imm0) + (vector-size imm4 result imm4) + (srdi. imm3 imm4 6) + (clrldi imm4 imm4 (- 64 6)) + (bl @get-dispatch) + (cmpdi cr1 imm4 0) ; at most low 6 bits set in imm4 + (mflr loc-pc) + (ld temp0 op vsp) + (add loc-pc loc-pc temp0) + (mtctr loc-pc) + (li imm0 ppc64::misc-data-offset) + (b @testd) + @nextd + (cmpdi cr0 imm3 1) + (subi imm3 imm3 1) + (ldx imm1 b1 imm0) + (ldx imm2 b2 imm0) + (bctrl) + (stdx imm1 result imm0) + (addi imm0 imm0 8) + @testd + (bne cr0 @nextd) + (beq cr1 @done) + ;; Not sure if we need to make this much fuss about the partial word + ;; in this simple case, but what the hell. + (ldx imm1 b1 imm0) + (ldx imm2 b2 imm0) + (bctrl) + (ldx imm2 result imm0) + (sld imm2 imm2 imm4) + (srd imm2 imm2 imm4) + (subfic imm4 imm4 64) + (srd imm1 imm1 imm4) + (sld imm1 imm1 imm4) + (or imm1 imm1 imm2) + (stdx imm1 result imm0) + @done + (restore-full-lisp-context) + (blr) + + @get-dispatch + (blrl) + @disptach + (li imm1 0) ; boole-clr + (blr) + (li imm1 -1) ; boole-set + (blr) + (blr) ; boole-1 + (blr) + (mr imm1 imm2) ; boole-2 + (blr) + (not imm1 imm1) ; boole-c1 + (blr) + (not imm1 imm2) ; boole-c2 + (blr) + (and imm1 imm1 imm2) ; boole-and + (blr) + (or imm1 imm1 imm2) ; boole-ior + (blr) + (xor imm1 imm1 imm2) ; boole-xor + (blr) + (eqv imm1 imm1 imm2) ; boole-eqv + (blr) + (nand imm1 imm1 imm2) ; boole-nand + (blr) + (nor imm1 imm1 imm2) ; boole-nor + (blr) + (andc imm1 imm2 imm1) ; boole-andc1 + (blr) + (andc imm1 imm1 imm2) ; boole-andc2 + (blr) + (orc imm1 imm2 imm1) ; boole-orc1 + (blr) + (orc imm1 imm1 imm2) ; boole-orc2 + (blr)) + + +(defppclapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z)) + (check-nargs 3) + (ba .SParef2)) + +(defppclapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z)) + (check-nargs 4) + (vpop temp0) + (ba .SParef3)) + + +(defppclapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z)) + (check-nargs 4) + (vpop temp0) + (ba .SPaset2)) + +(defppclapfunction %aset3 ((array #.target::node-size) (i 0) (j arg_x) (k arg_y) (newval arg_z)) + (check-nargs 5) + (vpop temp0) + (vpop temp1) + (ba .SPaset3)) + + Index: /branches/experimentation/later/source/level-0/PPC/ppc-clos.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-clos.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-clos.lisp (revision 8058) @@ -0,0 +1,329 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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'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 less than 255 slots in the class. +(defppclapfunction %small-map-slot-id-lookup ((slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (header-length imm3 imm0) + (ldr temp0 'table nfn) + (cmplr arg_x imm3) + (srri imm0 arg_x target::word-shift) + (la imm0 target::misc-data-offset imm0) + (li imm1 target::misc-data-offset) + (bge @have-scaled-table-index) + (lbzx imm1 temp1 imm0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + @have-scaled-table-index + (ldrx arg_z temp0 imm1) + (blr)) + +;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). +(defppclapfunction %large-map-slot-id-lookup ((slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (header-length imm3 imm0) + (ldr temp0 'table nfn) + (cmplr arg_x imm3) + #+ppc64-target + (progn + (srdi imm0 imm0 1) + (la imm0 target::misc-data-offset imm0)) + #+pp32-target + (progn + (la imm0 target::misc-data-offset arg_x)) + (li imm1 target::misc-data-offset) + (bge @have-scaled-table-index) + (lwzx imm1 temp1 imm0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + @have-scaled-table-index + (ldrx arg_z temp0 imm1) + (blr)) + +(defppclapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm3 imm0) + (cmplr arg_x imm3) + (srri imm0 arg_x target::word-shift) + (la imm0 target::misc-data-offset imm0) + (bge @missing) + (lbzx imm1 temp1 imm0) + (cmpri imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + (ldrx arg_z temp0 imm1) + (ldr arg_x 'class nfn) + (ldr nfn '%maybe-std-slot-value nfn) + (ldr temp0 target::misc-data-offset nfn) + (set-nargs 3) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-ref-missing instance id) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 2) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defppclapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm3 imm0) + (cmplr arg_x imm3) + #+ppc64-target + (progn + (srdi imm0 arg_x 1) + (la imm0 target::misc-data-offset imm0)) + #+ppc32-target + (progn + (la imm0 target::misc-data-offset arg_x)) + (bge @missing) + (lwzx imm1 temp1 imm0) + (cmpri imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr arg_x 'class nfn) + (ldr nfn '%maybe-std-slot-value-using-class nfn) + (ldrx arg_z temp0 imm1) + (ldr temp0 target::misc-data-offset nfn) + (set-nargs 3) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-ref-missing instance id) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 2) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defppclapfunction %small-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (ldr temp1 'map nfn) + (svref imm3 slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm5 imm0) + (cmplr imm3 imm5) + (srri imm0 imm3 target::word-shift) + (la imm0 target::misc-data-offset imm0) + (bge @missing) + (lbzx imm1 temp1 imm0) + (cmpwi imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr temp1 'class nfn) + (ldrx arg_y temp0 imm1) + (ldr nfn '%maybe-std-setf-slot-value-using-class nfn) + (set-nargs 4) + (ldr temp0 target::misc-data-offset nfn) + (vpush temp1) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-set-missing instance id new-value) + (ldr nfn '%slot-id-set-missing nfn) + (set-nargs 3) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defppclapfunction %large-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (ldr temp1 'map nfn) + (svref imm3 slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm5 imm0) + (cmplw imm3 imm5) + #+ppc64-target (srdi imm3 imm3 1) + (la imm0 target::misc-data-offset imm3) + (bge @missing) + (lwzx imm1 temp1 imm0) + (cmpwi imm1 0) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr temp1 'class nfn) + (ldrx arg_y temp0 imm1) + (ldr nfn '%maybe-std-setf-slot-value-using-class nfn) + (set-nargs 4) + (svref temp0 0 nfn) + (vpush temp1) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-set-missing instance id new-value) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 3) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +#-dont-use-lexprs +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (ppc-lap-function + gag + () + (mflr loc-pc) + (vpush-argregs) + (vpush nargs) + (add imm0 vsp nargs) + (la imm0 (ash 1 target::word-shift) imm0) ; caller's vsp + (bla .SPlexpr-entry) + (mtlr loc-pc) ; return to kernel + (mr arg_z vsp) ; lexpr + (svref arg_y gf.dispatch-table nfn) ; dispatch table + (set-nargs 2) + (svref nfn gf.dcode nfn) ; dcode function + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr))))) + +#+dont-use-lexprs +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &rest args) + (ppc-lap-function + gag + () + ;;(bkpt) + (mflr loc-pc) + (bla .SPstack-rest-arg) + (vpop arg_z) + (stru sp (- target::lisp-frame.size) sp) + (str fn target::lisp-frame.savefn sp) + (str loc-pc target::lisp-frame.savelr sp) + (str vsp target::lisp-frame.savevsp sp) + (mr fn nfn) + ;; If we were called for multiple values, call the dcode + ;; for multiple values. + (ref-global imm0 ret1valaddr) + (cmpr imm0 loc-pc) + (svref arg_y gf.dispatch-table fn) ; dispatch table + (set-nargs 2) + (svref nfn gf.dcode fn) ; dcode function + (beq @multiple) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctrl) + (ldr tsp 0 tsp) + (restore-full-lisp-context) + (blr) + @multiple + (bl @getback) + (mflr loc-pc) + (stru sp (- target::lisp-frame.size) sp) + (str fn target::lisp-frame.savefn sp) + (str loc-pc target::lisp-frame.savelr sp) + (str vsp target::lisp-frame.savevsp sp) + (mtlr imm0) + (li fn 0) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr) + @getback + (blrl) + @back + (ldr tsp 0 tsp) + (ba .SPnvalret))))) + + + +(defppclapfunction funcallable-trampoline () + (svref nfn gf.dcode nfn) + (svref temp0 0 nfn) + (mtctr temp0) + (bctr)) + +;;; This can't reference any of the function's constants. +(defppclapfunction unset-fin-trampoline () + (mflr loc-pc) + (bla .SPheap-rest-arg) ; cons up an &rest arg, vpush it + (vpop arg_z) ; whoops, didn't really want to + (bla .SPsavecontextvsp) + (li arg_x '#.$XNOFINFUNCTION) + (mr arg_y nfn) + (set-nargs 3) + (bla .SPksignalerr) + (li arg_z nil) + (ba .SPpopj)) + +;;; is a winner - saves ~15% +(defppclapfunction gag-one-arg ((arg arg_z)) + (check-nargs 1) + (svref arg_y gf.dispatch-table nfn) ; mention dt first + (set-nargs 2) + (svref nfn gf.dcode nfn) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + +(defppclapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z)) + (check-nargs 2) + (svref arg_x gf.dispatch-table nfn) ; mention dt first + (set-nargs 3) + (svref nfn gf.dcode nfn) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defparameter *cm-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (ppc-lap-function + gag + () + (mflr loc-pc) + (vpush-argregs) + (vpush nargs) + (add imm0 vsp nargs) + (la imm0 target::node-size imm0) ; caller's vsp + (bla .SPlexpr-entry) + (mtlr loc-pc) ; return to kernel + (mr arg_z vsp) ; lexpr + (svref arg_y combined-method.thing nfn) ; thing + (set-nargs 2) + (svref nfn combined-method.dcode nfn) ; dcode function + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr))))) Index: /branches/experimentation/later/source/level-0/PPC/ppc-def.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-def.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-def.lisp (revision 8058) @@ -0,0 +1,1278 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushed. +;;; If the GC moves this function while we're trying to flush the cache, +;;; it'll flush the cache: no harm done in that case. +(defppclapfunction %make-code-executable ((codev arg_z)) + (let ((len imm2) + (word-offset imm0)) + (save-lisp-context) + (getvheader word-offset codev) + (header-size len word-offset) + ;; The idea is that if we GC here, no harm is done (since the GC + ;; will do any necessary cache-flushing.) The idea may be + ;; incorrect: if we pass an address that's not mapped anymore, + ;; could we fault ? + (stru sp (- (+ #+eabi-target ppc32::eabi-c-frame.minsize + #+poweropen-target target::c-frame.minsize target::lisp-frame.size)) sp) ; make an FFI frame. + (la imm0 target::misc-data-offset codev) + (slri len len 2) + (str imm0 #+eabi-target ppc32::eabi-c-frame.param0 #+poweropen-target target::c-frame.param0 sp) + (str len #+eabi-target ppc32::eabi-c-frame.param1 #+poweropen-target target::c-frame.param1 sp) + (ref-global imm3 kernel-imports) + (ldr arg_z target::kernel-import-MakeDataExecutable imm3) + (bla #+eabi-target .SPeabi-ff-call #+poweropen-target .SPpoweropen-ffcall) + (li arg_z nil) + (restore-full-lisp-context) + (blr))) + +(defppclapfunction %get-kernel-global-from-offset ((offset arg_z)) + (check-nargs 1) + (unbox-fixnum imm0 offset) + (addi imm0 imm0 target::nil-value) + (ldr arg_z 0 imm0) + (blr)) + +(defppclapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z)) + (check-nargs 2) + (unbox-fixnum imm0 offset) + (addi imm0 imm0 target::nil-value) + (str new-value 0 imm0) + (blr)) + + + +(defppclapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) + (ptr arg_z)) + (check-nargs 2) + (unbox-fixnum imm0 offset) + (addi imm0 imm0 target::nil-value) + (ldr imm0 0 imm0) + (str imm0 target::macptr.address ptr) + (blr)) + + + + +(defppclapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) + (cmpri cr0 nargs '1) + (check-nargs 1 2) + (bne cr0 @2-args) + (mr fixnum offset) + (li offset 0) + @2-args + (unbox-fixnum imm0 offset) + (ldrx arg_z imm0 fixnum) + (blr)) + + +#+ppc32-target +(defppclapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (cmpri cr0 nargs '1) + (check-nargs 1 2) + (bne cr0 @2-args) + (mr fixnum offset) + (li offset 0) + @2-args + (unbox-fixnum imm0 offset) + (lwzx imm0 imm0 fixnum) + (ba .SPmakeu32)) + +#+ppc64-target +(defppclapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (cmpdi cr0 nargs '1) + (check-nargs 1 2) + (bne cr0 @2-args) + (mr fixnum offset) + (li offset 0) + @2-args + (unbox-fixnum imm0 offset) + (ldx imm0 imm0 fixnum) + (ba .SPmakeu64)) + +(defppclapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (cmpi cr0 nargs '2) + (check-nargs 2 3) + (bne cr0 @3-args) + (mr fixnum offset) + (li offset 0) + @3-args + (unbox-fixnum imm0 offset) + (strx new-value imm0 fixnum) + (mr arg_z new-value) + (blr)) + +#+ppc32-target +(defppclapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (cmpwi cr0 nargs '2) + (check-nargs 2 3) + (bne cr0 @3-args) + (mr fixnum offset) + (li offset 0) + @3-args + (unbox-fixnum imm0 offset) + (extract-typecode imm1 new-value) + (cmpwi cr0 imm1 ppc32::tag-fixnum) + (cmpwi cr1 imm1 ppc32::subtag-bignum) + (srwi imm2 new-value ppc32::fixnumshift) + (beq cr0 @store) + (beq cr1 @bignum) + @notu32 + (uuo_interr arch::error-object-not-unsigned-byte-32 new-value) + @bignum + (getvheader imm0 new-value) + (cmpwi cr1 imm0 ppc32::one-digit-bignum-header) + (cmpwi cr2 imm0 ppc32::two-digit-bignum-header) + (lwz imm2 ppc32::misc-data-offset new-value) + (cmpwi cr0 imm2 0) + (beq cr1 @one) + (bne cr2 @notu32) + (lwz imm1 (+ 4 ppc32::misc-data-offset) new-value) + (cmpwi cr1 imm1 0) + (bgt cr0 @notu32) + (beq cr1 @store) + (b @notu32) + @one + (blt cr0 @notu32) + @store + (stwx imm2 imm0 fixnum) + (mr arg_z new-value) + (blr)) + +#+ppc64-target +(defppclapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (cmpdi cr0 nargs '2) + (check-nargs 2 3) + (bne cr0 @3-args) + (mr fixnum offset) + (li offset 0) + @3-args + (unbox-fixnum imm0 offset) + (extract-typecode imm1 new-value) + (cmpdi cr0 imm1 ppc64::tag-fixnum) + (cmpdi cr1 imm1 ppc64::subtag-bignum) + (srdi imm2 new-value ppc64::fixnumshift) + (beq cr0 @store) + (beq cr1 @bignum) + @notu64 + (uuo_interr arch::error-object-not-unsigned-byte-64 new-value) + @bignum + (ld imm2 ppc64::misc-data-offset new-value) + (getvheader imm0 new-value) + (cmpdi cr1 imm0 ppc64::two-digit-bignum-header) + (rotldi imm2 imm2 32) + (cmpdi cr2 imm0 ppc64::three-digit-bignum-header) + (cmpdi cr0 imm2 0) + (beq cr1 @two) + (bne cr2 @notu64) + (lwz imm1 (+ 8 ppc64::misc-data-offset) new-value) + (cmpwi cr1 imm1 0) + (bgt cr0 @notu64) + (beq cr1 @store) + (b @notu64) + @two + (blt cr0 @notu64) + @store + (stdx imm2 imm0 fixnum) + (mr arg_z new-value) + (blr)) + + +(defppclapfunction %current-frame-ptr () + (check-nargs 0) + (mr arg_z sp) + (blr)) + +(defppclapfunction %current-vsp () + (check-nargs 0) + (mr arg_z vsp) + (blr)) + + + + +(defppclapfunction %set-current-vsp ((new-vsp arg_z)) + (check-nargs 1) + (mr vsp new-vsp) + (blr)) + +(defppclapfunction %current-tsp () + (check-nargs 0) + (mr arg_z tsp) + (blr)) + + + +(defppclapfunction %set-current-tsp ((new-tsp arg_z)) + (check-nargs 1) + (mr tsp new-tsp) + (blr)) + +(defppclapfunction %%frame-backlink ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.backlink arg_z) + (blr)) + + + + + +(defppclapfunction %%frame-savefn ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.savefn arg_z) + (blr)) + +(defppclapfunction %cfp-lfun ((p arg_z)) + (ldr arg_y target::lisp-frame.savefn p) + (extract-typecode imm0 arg_y) + (cmpri imm0 target::subtag-function) + (ldr loc-pc target::lisp-frame.savelr p) + (bne @no) + (ldr arg_x target::misc-data-offset arg_y) + (sub imm1 loc-pc arg_x) + (la imm1 (- target::misc-data-offset) imm1) + (getvheader imm0 arg_x) + (header-length imm0 imm0) + (cmplr imm1 imm0) + (box-fixnum imm1 imm1) + (bge @no) + (vpush arg_y) + (vpush imm1) + @go + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues) + @no + (li imm0 nil) + (vpush imm0) + (vpush imm0) + (b @go)) + + + + +(defppclapfunction %%frame-savevsp ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.savevsp arg_z) + (blr)) + + + + + +#+ppc32-target +(eval-when (:compile-toplevel :execute) + (assert (eql ppc32::t-offset #x11))) + +(defppclapfunction %uvector-data-fixnum ((uv arg_z)) + (check-nargs 1) + (trap-unless-fulltag= arg_z target::fulltag-misc) + (la arg_z target::misc-data-offset arg_z) + (blr)) + +(defppclapfunction %catch-top ((tcr arg_z)) + (check-nargs 1) + (ldr arg_z target::tcr.catch-top tcr) + (cmpri cr0 arg_z 0) + (bne @ret) + (li arg_z nil) + @ret + (blr)) + +(defppclapfunction %catch-tsp ((catch arg_z)) + (check-nargs 1) + (la arg_z (- (+ target::fulltag-misc + (ash 1 (1+ target::word-shift)))) arg_z) + (blr)) + + + +;;; Same as %address-of, but doesn't cons any bignums +;;; It also left shift fixnums just like everything else. +(defppclapfunction %fixnum-address-of ((x arg_z)) + (check-nargs 1) + (box-fixnum arg_z x) + (blr)) + + + +(defppclapfunction %save-standard-binding-list ((bindings arg_z)) + (ldr imm0 target::tcr.vs-area target::rcontext) + (ldr imm1 target::area.high imm0) + (push bindings imm1) + (blr)) + +(defppclapfunction %saved-bindings-address () + (ldr imm0 target::tcr.vs-area target::rcontext) + (ldr imm1 target::area.high imm0) + (la arg_z (- target::node-size) imm1) + (blr)) + +(defppclapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z)) + (macptr-ptr imm0 pcptr) + (ldr loc-pc 0 imm0) + (sub imm0 loc-pc code-vector) + (subi imm0 imm0 target::misc-data-offset) + (getvheader imm1 code-vector) + (header-size imm1 imm1) + (slri imm1 imm1 2) + (cmplr imm0 imm1) + (li arg_z nil) + (bgelr) + (box-fixnum arg_z imm0) + (blr)) + +;;; FF-call, in LAP. +#+eabi-target +(progn + (defppclapfunction %%ff-call ((fploads 8) + (single-offset 4) + (double-offset 0) + (framesize arg_x) ;always even, negative, includes frame overhead + (buf arg_y) + (entry arg_z)) + (check-nargs 6) + (la imm0 12 vsp) + (save-lisp-context imm0) + (stwux sp sp framesize) + (stw sp 4 sp) + (macptr-ptr imm2 buf) + (mr imm1 imm2) + (la imm3 ppc32::eabi-c-frame.param0 sp) + (li imm0 0) + (lwz temp1 single-offset vsp) + (lwz temp2 double-offset vsp) + @copy + (addi imm0 imm0 8) + (cmpw imm0 temp1) + (lfd fp0 0 imm2) + (la imm2 8 imm2) + (stfd fp0 0 imm3) + (la imm3 8 imm3) + (blt @copy) + ;; We've copied the gpr-save area and the "other" arg words. + ;; Sadly, we may still need to load up to 8 FPRs, and we have + ;; to use some pretty ugly code to do so. + (add temp1 temp1 imm1) + (add temp2 temp2 imm1) + (lwz temp0 fploads vsp) + @load-fp1 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp1-double) + (lfs fp1 0 temp1) + (la temp1 4 temp1) + (b @load-fp2) + @load-fp1-double + (lfd fp1 0 temp2) + (la temp2 8 temp2) + @load-fp2 + (lbz imm0 (+ ppc32::misc-data-offset 1) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp2-double) + (lfs fp2 0 temp1) + (la temp1 4 temp1) + (b @load-fp3) + @load-fp2-double + (lfd fp2 0 temp2) + (la temp2 8 temp2) + @load-fp3 + (lbz imm0 (+ ppc32::misc-data-offset 2) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp3-double) + (lfs fp3 0 temp1) + (la temp1 4 temp1) + (b @load-fp4) + @load-fp3-double + (lfd fp3 0 temp2) + (la temp2 8 temp2) + @load-fp4 + (lbz imm0 (+ ppc32::misc-data-offset 3) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp4-double) + (lfs fp4 0 temp1) + (la temp1 4 temp1) + (b @load-fp5) + @load-fp4-double + (lfd fp4 0 temp2) + (la temp2 8 temp2) + @load-fp5 + (lbz imm0 (+ ppc32::misc-data-offset 4) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp5-double) + (lfs fp5 0 temp1) + (la temp1 4 temp1) + (b @load-fp6) + @load-fp5-double + (lfd fp5 0 temp2) + (la temp2 8 temp2) + @load-fp6 + (lbz imm0 (+ ppc32::misc-data-offset 5) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp6-double) + (lfs fp6 0 temp1) + (la temp1 4 temp1) + (b @load-fp7) + @load-fp6-double + (lfd fp6 0 temp2) + (la temp2 8 temp2) + @load-fp7 + (lbz imm0 (+ ppc32::misc-data-offset 6) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp7-double) + (lfs fp7 0 temp1) + (la temp1 4 temp1) + (b @load-fp8) + @load-fp7-double + (lfd fp7 0 temp2) + (la temp2 8 temp2) + @load-fp8 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp8-double) + (lfs fp8 0 temp1) + (b @loaded) + @load-fp8-double + (lfd fp8 0 temp2) + @loaded + (vpush buf) + (bla .SPeabi-ff-call) + (vpop buf) + (macptr-ptr imm2 buf) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (stfs fp1 8 imm2) + (stfd fp1 16 imm2) + (restore-full-lisp-context) + (li arg_z ppc32::nil-value) + (blr)) + + (defun %ff-call (entry &rest specs-and-vals) + "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-keyword. Returns the foreign function result (coerced to a Lisp +object of type indicated by result-type-keyword), or NIL if +result-type-keyword is :VOID or NIL" + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (other-offset 8) + (single-float-offset 8) + (double-float-offset 0) + (nsingle-floats 0) + (ndouble-floats 0) + (nother-words 0) + (nfpr-args 0) + (ngpr-args 0)) + (declare (fixnum len other-offset single-float-offset double-float-offset + nsingle-floats ndouble-floats nother-words nfpr-args ngpr-args)) + (unless (oddp len) + (error "Length of ~s is even. Missing result ?" specs-and-vals)) + + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (fpr-reloads (make-array 8 :element-type '(unsigned-byte 8)))) + (declare (fixnum nargs) (dynamic-extent fpr-reloads)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (ecase spec + (:double-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf ndouble-floats) + (progn + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2)))) + (:single-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf nsingle-floats) + (incf nother-words))) + ((:signed-doubleword :unsigned-doubleword) + (if (oddp ngpr-args) + (incf ngpr-args)) + (incf ngpr-args 2) + (when (> ngpr-args 8) + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2))) + ((:signed-byte :unsigned-byte :signed-halfword :unsigned-halfword + :signed-fullword :unsigned-fullword :address) + (incf ngpr-args) + (if (> ngpr-args 8) + (incf nother-words))))) + (let* ((single-words (+ 8 nother-words nsingle-floats)) + (total-words (if (zerop ndouble-floats) + single-words + (+ (the fixnum (+ ndouble-floats ndouble-floats)) + (the fixnum (logand (lognot 1) + (the fixnum (1+ single-words)))))))) + (declare (fixnum total-words single-words)) + (%stack-block + ((buf (ash total-words 2))) + (setq single-float-offset (+ other-offset nother-words)) + (setq double-float-offset + (logand (lognot 1) + (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats)))))) + ;;; Make another pass through the arg/value pairs, evaluating each arg into + ;;; the buffer. + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs)) + (ngpr 0) + (nfpr 0) + (gpr-byte-offset 0) + (other-byte-offset (ash other-offset 2)) + (single-byte-offset (ash single-float-offset 2)) + (double-byte-offset (ash double-float-offset 2))) + ((= i nargs)) + (declare (fixnum i gpr-byte-offset single-byte-offset double-byte-offset + ngpr nfpr)) + (case spec + (:double-float + (cond ((< nfpr 8) + (setf (uvref fpr-reloads nfpr) 2 + (%get-double-float buf double-byte-offset) val + double-byte-offset (+ double-byte-offset 8))) + (t + (setq other-byte-offset (logand (lognot 7) + (the fixnum (+ other-byte-offset 4)))) + (setf (%get-double-float buf other-byte-offset) val) + (setq other-byte-offset (+ other-byte-offset 8)))) + (incf nfpr)) + (:single-float + (cond ((< nfpr 8) + (setf (uvref fpr-reloads nfpr) 1 + (%get-single-float buf single-byte-offset) val + single-byte-offset (+ single-byte-offset 4))) + + (t + (setf (%get-single-float buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf nfpr)) + (:address + (cond ((< ngpr 8) + (setf (%get-ptr buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-ptr buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)) + ((:signed-doubleword :unsigned-doubleword) + (when (oddp ngpr) + (incf ngpr) + (incf gpr-byte-offset 4)) + (cond ((< ngpr 8) + (if (eq spec :signed-doubleword) + (setf (%get-signed-long-long buf gpr-byte-offset) val) + (setf (%get-unsigned-long-long buf gpr-byte-offset) val)) + (incf gpr-byte-offset 8)) + (t + (when (logtest other-byte-offset 7) + (incf other-byte-offset 4)) + (if (eq spec :signed-doubleword) + (setf (%get-signed-long-long buf other-byte-offset) val) + (setf (%get-unsigned-long-long buf other-byte-offset) val)) + (incf other-byte-offset 8))) + (incf ngpr 2)) + (t + (cond ((< ngpr 8) + (setf (%get-long buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-long buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)))) + (%%ff-call fpr-reloads + single-float-offset + double-float-offset + (the fixnum (- + (ash (the fixnum + (+ 6 + (the fixnum (logand + (lognot 1) + (the fixnum (1+ total-words)))))) + 2))) + buf + entry) + (ecase result-spec + (:void nil) + (:single-float (%get-single-float buf 8)) + (:double-float (%get-double-float buf 16)) + (:address (%get-ptr buf)) + (:signed-doubleword (%get-signed-long-long buf 0)) + (:unsigned-doubleword (%get-unsigned-long-long buf 0)) + (:signed-fullword (%get-signed-long buf)) + (:unsigned-fullword (%get-unsigned-long buf)) + (:signed-halfword (%get-signed-word buf 2)) + (:unsigned-halfword (%get-unsigned-word buf 2)) + (:signed-byte (%get-signed-byte buf 3)) + (:unsigned-byte (%get-unsigned-byte buf 3)))))))) + ) + + + + + +;;; In the PowerOpen ABI, all arguments are passed in a contiguous +;;; block. The first 13 (!) FP args are passed in FP regs; doubleword +;;; arguments are aligned on word boundaries. +#+poweropen-target +(progn + #+ppc32-target + (progn + (defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0) + (monitor (eq (car specs-and-vals) :monitor-exception-ports))) + (declare (fixnum len total-words)) + (when monitor + (decf len) + (setq specs-and-vals (cdr specs-and-vals))) + (unless (oddp len) + (error "Length of ~s is even. Missing result ?" specs-and-vals)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (fpr-reload-sizes (make-array 13 :element-type '(unsigned-byte 8))) + (fpr-reload-offsets (make-array 13 :element-type '(unsigned-byte 16)))) + (declare (fixnum nargs) (dynamic-extent fpr-reload-sizes fpr-reload-offsets)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + ((:double-float :signed-doubleword :unsigned-doubleword) + (incf total-words 2)) + ((:single-float :signed-byte :unsigned-byte :signed-halfword + :unsigned-halfword :signed-fullword + :unsigned-fullword :address) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "Invalid argument spec ~s" spec))))) + (%stack-block ((buf (ash (logand (lognot 1) (1+ (max 6 total-words))) 2))) + (do* ((i 0 (1+ i)) + (fpr 0) + (offset 0 (+ offset 4)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i offset fpr)) + (case spec + (:double-float + (when (< fpr 13) + (setf (uvref fpr-reload-sizes fpr) 2 + (uvref fpr-reload-offsets fpr) offset)) + (incf fpr) + (setf (%get-double-float buf offset) val) + (incf offset 4)) + (:single-float + (when (< fpr 13) + (setf (uvref fpr-reload-sizes fpr) 1 + (uvref fpr-reload-offsets fpr) offset)) + (incf fpr) + (setf (%get-single-float buf offset) val)) + (:signed-doubleword + (setf (%get-signed-long-long buf offset) val) + (incf offset 4)) + (:unsigned-doubleword + (setf (%get-unsigned-long-long buf offset) val) + (incf offset 4)) + (:address + (setf (%get-ptr buf offset) val)) + (t + (if (typep spec 'unsigned-byte) + (dotimes (i spec (decf offset 4)) + (setf (%get-ptr buf offset) + (%get-ptr val (* i 4))) + (incf offset 4)) + (setf (%get-long buf offset) val))))) + (let* ((frame-size (if (<= total-words 8) + (ash + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + -2) + (+ + (ash + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + -2) + (logand (lognot 1) + (1+ (- total-words 8))))))) + + (%%ff-call + monitor + fpr-reload-sizes + fpr-reload-offsets + (- (logandc2 (+ frame-size 3) 3)) + total-words + buf + entry)) + (ecase result-spec + (:void nil) + (:single-float (%get-single-float buf 8)) + (:double-float (%get-double-float buf 16)) + (:address (%get-ptr buf)) + (:signed-doubleword (%get-signed-long-long buf 0)) + (:unsigned-doubleword (%get-unsigned-long-long buf 0)) + (:signed-fullword (%get-signed-long buf)) + (:unsigned-fullword (%get-unsigned-long buf)) + (:signed-halfword (%get-signed-word buf 2)) + (:unsigned-halfword (%get-unsigned-word buf 2)) + (:signed-byte (%get-signed-byte buf 3)) + (:unsigned-byte (%get-unsigned-byte buf 3))))))) + + + (defppclapfunction %%ff-call ((monitor-exception-ports 12) + (reload-sizes 8) + (reload-offsets 4) + (frame-size 0) + (total-words arg_x) + (buf arg_y) + (entry arg_z)) + (check-nargs 7) + (la imm0 16 vsp) + (save-lisp-context imm0) + (lwz imm0 frame-size vsp) + (stwux sp sp imm0) + (stw sp ppc32::c-frame.savelr sp) + (lwz imm2 monitor-exception-ports vsp) + (cmpwi cr1 imm2 nil) + (macptr-ptr imm2 buf) + (mr imm1 imm2) + (la imm3 ppc32::c-frame.param0 sp) + (li temp1 0) + @copy + (addi temp1 temp1 '1) + (cmpw temp1 total-words) + (lwz imm0 0 imm2) + (la imm2 4 imm2) + (stw imm0 0 imm3) + (la imm3 4 imm3) + (blt @copy) + (lwz temp0 reload-sizes vsp) + (lwz temp1 reload-offsets vsp) + @load-fp1 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 0) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp1 imm1 imm2) + (b @load-fp2) + @load-fp1-double + (lfdx fp1 imm1 imm2) + + @load-fp2 + (lbz imm0 (+ ppc32::misc-data-offset 1) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 2) temp1) + (blt @loaded) + (bne @load-fp2-double) + (lfsx fp2 imm1 imm2) + (b @load-fp3) + @load-fp2-double + (lfdx fp2 imm1 imm2) + + @load-fp3 + (lbz imm0 (+ ppc32::misc-data-offset 2) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 4) temp1) + (blt @loaded) + (bne @load-fp3-double) + (lfsx fp3 imm1 imm2) + (b @load-fp4) + @load-fp3-double + (lfdx fp3 imm1 imm2) + + @load-fp4 + (lbz imm0 (+ ppc32::misc-data-offset 3) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 6) temp1) + (blt @loaded) + (bne @load-fp4-double) + (lfsx fp4 imm1 imm2) + (b @load-fp5) + @load-fp4-double + (lfdx fp4 imm1 imm2) + + @load-fp5 + (lbz imm0 (+ ppc32::misc-data-offset 4) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 8) temp1) + (blt @loaded) + (bne @load-fp5-double) + (lfsx fp5 imm1 imm2) + (b @load-fp6) + @load-fp5-double + (lfdx fp5 imm1 imm2) + + @load-fp6 + (lbz imm0 (+ ppc32::misc-data-offset 5) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 10) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp6 imm1 imm2) + (b @load-fp7) + @load-fp6-double + (lfdx fp6 imm1 imm2) + + @load-fp7 + (lbz imm0 (+ ppc32::misc-data-offset 6) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 12) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp7 imm1 imm2) + (b @load-fp8) + @load-fp7-double + (lfdx fp7 imm1 imm2) + + @load-fp8 + (lbz imm0 (+ ppc32::misc-data-offset 7) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 14) temp1) + (blt @loaded) + (bne @load-fp8-double) + (lfsx fp8 imm1 imm2) + (b @load-fp9) + @load-fp8-double + (lfdx fp8 imm1 imm2) + + @load-fp9 + (lbz imm0 (+ ppc32::misc-data-offset 8) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 16) temp1) + (blt @loaded) + (bne @load-fp9-double) + (lfsx fp9 imm1 imm2) + (b @load-fp10) + @load-fp9-double + (lfdx fp9 imm1 imm2) + + @load-fp10 + (lbz imm0 (+ ppc32::misc-data-offset 9) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 18) temp1) + (blt @loaded) + (bne @load-fp10-double) + (lfsx fp10 imm1 imm2) + (b @load-fp11) + @load-fp10-double + (lfdx fp10 imm1 imm2) + + @load-fp11 + (lbz imm0 (+ ppc32::misc-data-offset 10) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 20) temp1) + (blt @loaded) + (bne @load-fp11-double) + (lfsx fp11 imm1 imm2) + (b @load-fp12) + @load-fp11-double + (lfdx fp11 imm1 imm2) + + @load-fp12 + (lbz imm0 (+ ppc32::misc-data-offset 11) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 22) temp1) + (blt @loaded) + (bne @load-fp12-double) + (lfsx fp12 imm1 imm2) + (b @load-fp13) + @load-fp12-double + (lfdx fp12 imm1 imm2) + + @load-fp13 + (lbz imm0 (+ ppc32::misc-data-offset 12) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 24) temp1) + (blt @loaded) + (bne @load-fp13-double) + (lfsx fp13 imm1 imm2) + (b @loaded) + @load-fp13-double + (lfdx fp13 imm1 imm2) + @loaded + (vpush buf) + (bne cr1 @callX) + (bla .SPpoweropen-ffcall) + (b @called) + @callX + (bla .SPpoweropen-ffcallX) + @called + (vpop buf) + (macptr-ptr imm2 buf) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (stfs fp1 8 imm2) + (stfd fp1 16 imm2) + (restore-full-lisp-context) + (li arg_z ppc32::nil-value) + (blr)) + ) + + #+ppc64-target + (progn + ;;; There are a few funky, non-obvious things going on here. + ;;; The main %FF-CALL function uses WITH-VARIABLE-C-FRAME; + ;;; the compiler will generate code to pop that frame off + ;;; of the C/control stack, but the subprim that implements + ;;; %ff-call has already popped it off. To put things back + ;;; in balance, the LAP function %%FF-RESULT pushes an + ;;; extra frame on the cstack. + ;;; %FF-CALL calls %%FF-RESULT to box the result, which may + ;;; be in r3/imm0 or in fp1. It's critical that the call + ;;; to %%FF-RESULT not be compiled as "multiple-value returning", + ;;; since the MV machinery may clobber IMM0. + (defppclapfunction %%ff-result ((spec arg_z)) + (stdu sp -160 sp) + (ld arg_y ':void nfn) + (cmpd cr0 spec arg_y) + (ld arg_x ':address nfn) + (cmpd cr1 spec arg_x) + (ld temp3 ':single-float nfn) + (cmpd cr2 spec temp3) + (ld arg_y ':double-float nfn) + (cmpd cr3 spec arg_y) + (ld arg_x ':unsigned-doubleword nfn) + (cmpd cr4 spec arg_x) + (ld temp3 ':signed-doubleword nfn) + (cmpd cr5 spec temp3) + (beq cr0 @void) + (beq cr1 @address) + (beq cr2 @single-float) + (beq cr3 @double-float) + (beq cr4 @unsigned-doubleword) + (beq cr5 @signed-doubleword) + (box-fixnum arg_z imm0) + (blr) + @void + (li arg_z nil) + (blr) + @address + (li imm1 ppc64::macptr-header) + (subi allocptr allocptr (- ppc64::macptr.size ppc64::fulltag-misc)) + (tdlt allocptr allocbase) + (std imm1 ppc64::misc-header-offset allocptr) + (mr arg_z allocptr) + (clrrdi allocptr allocptr 4) + (std imm0 ppc64::macptr.address arg_z) + (blr) + @single-float + (put-single-float fp1 arg_z) + (blr) + @double-float + (li imm1 ppc64::double-float-header) + (subi allocptr allocptr (- ppc64::double-float.size ppc64::fulltag-misc)) + (tdlt allocptr allocbase) + (std imm1 ppc64::misc-header-offset allocptr) + (mr arg_z allocptr) + (clrrdi allocptr allocptr 4) + (stfd fp1 ppc64::macptr.address arg_z) + (blr) + @unsigned-doubleword + (ba .SPmakeu64) + @signed-doubleword + (ba .SPmakes64)) + + ;;; This is just here so that we can jump to a subprim from lisp. + (defppclapfunction %do-ff-call ((monitor arg_x) (regbuf arg_y) (entry arg_z)) + (cmpdi cr0 regbuf nil) + (cmpdi cr1 monitor nil) + (bnea cr0 .SPpoweropen-ffcall-return-registers) + (beqa cr1 .SPpoweropen-ffcall) + (ba .SPpoweropen-ffcallx)) + + (defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0) + (monitor (eq (car specs-and-vals) :monitor-exception-ports)) + (registers nil)) + (declare (fixnum len total-words)) + (when monitor + (decf len) + (setq specs-and-vals (cdr specs-and-vals))) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1))) + (declare (fixnum nargs)) + (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 + (:registers nil) + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :hybrid-int-float :hybrid-float-float + :hybrid-float-int) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "unknown arg spec ~s" spec))))) + (%stack-block ((fp-args (* 13 8))) + (with-variable-c-frame + total-words frame + (with-macptrs ((argptr)) + (%setf-macptr-to-object argptr frame) + (let* ((offset ppc64::c-frame.param0) + (n-fp-args 0)) + (declare (fixnum offset n-fp-args)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:registers (setq registers val)) + (:address (setf (%get-ptr argptr offset) val) + (incf offset 8)) + ((:signed-doubleword :signed-fullword :signed-halfword + :signed-byte) + + (setf (%%get-signed-longlong argptr offset) val) + (incf offset 8)) + ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword + :unsigned-byte) + (setf (%%get-unsigned-longlong argptr offset) val) + (incf offset 8)) + (:hybrid-int-float + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr (+ offset 4))))) + (incf n-fp-args) + (incf offset 8)) + (:hybrid-float-int + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr offset)))) + (incf n-fp-args) + (incf offset 8)) + (:hybrid-float-float + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr offset)))) + (incf n-fp-args) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr (+ offset 4))))) + (incf n-fp-args) + (incf offset 8)) + (:double-float + (setf (%get-double-float argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) val)) + (incf n-fp-args) + (incf offset 8)) + (:single-float + (setf (%get-single-float argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float val))) + (incf n-fp-args) + (incf offset 8)) + (t + (let* ((p 0)) + (declare (fixnum p)) + (dotimes (i (the fixnum spec)) + (setf (%get-ptr argptr offset) (%get-ptr val p)) + (incf p 8) + (incf offset 8)))))) + (%load-fp-arg-regs n-fp-args fp-args) + (%do-ff-call monitor registers entry) + (values (%%ff-result result-spec))))))))))) + + ) + ) + + + +(defppclapfunction %get-object ((macptr arg_y) (offset arg_z)) + (check-nargs 2) + (trap-unless-typecode= arg_y target::subtag-macptr) + (macptr-ptr imm0 arg_y) + (trap-unless-lisptag= arg_z target::tag-fixnum imm1) + (unbox-fixnum imm1 arg_z) + (ldrx arg_z imm0 imm1) + (blr)) + + +(defppclapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z)) + (check-nargs 3) + (trap-unless-typecode= arg_x target::subtag-macptr) + (macptr-ptr imm0 arg_x) + (trap-unless-lisptag= arg_y target::tag-fixnum imm1) + (unbox-fixnum imm1 arg_y) + (strx arg_z imm0 imm1) + (blr)) + + +(defppclapfunction %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 ppc::next-method-context (= ppc::temp1). + ;; Put function in ppc::nfn (= ppc::temp2). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves ppc::nfn/ppc::next-method-context. + ;; Jump to the function in ppc::nfn. + (mr ppc::next-method-context magic) + (mr ppc::nfn function) + (set-nargs 0) + (mflr loc-pc) + (bla .SPspread-lexpr-z) + (mtlr loc-pc) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + +(defppclapfunction %apply-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in ppc::next-method-context (= ppc::temp1). + ;; Put function in ppc::nfn (= ppc::temp2). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves ppc::nfn/ppc::next-method-context. + ;; Jump to the function in ppc::nfn. + (mr ppc::next-method-context magic) + (mr ppc::nfn function) + (set-nargs 0) + (mflr loc-pc) + (bla .SPspreadargZ) + (mtlr loc-pc) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + + + +(defppclapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) + ;; This assumes + ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism + ;; b) That the LR on entry to this function points to the lexpr-cleanup + ;; code that .SPlexpr-entry set up + ;; c) That there weren't any required args to the lexpr, e.g. that + ;; (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf. + ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr) + ;; or (lisp-global lexpr-return1v). In the former case, discard a frame + ;; from the cstack (multiple-value tossing). Restore FN and LR from + ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+ + ;; args node-size), pop the argregs, and jump to the function. + (mflr loc-pc) + (ref-global imm0 ret1valaddr) + (cmpr cr2 loc-pc imm0) + (ldr nargs 0 args) + (mr imm5 nargs) + (cmpri cr0 nargs 0) + (cmpri cr1 nargs '2) + (mr nfn method) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (if (:cr2 :eq) + (la sp target::lisp-frame.size sp)) + (ldr loc-pc target::lisp-frame.savelr sp) + (ldr fn target::lisp-frame.savefn sp) + (ldr imm0 target::lisp-frame.savevsp sp) + (sub vsp imm0 nargs) + (mtlr loc-pc) + (la sp target::lisp-frame.size sp) + (beqctr) + (vpop arg_z) + (bltctr cr1) + (vpop arg_y) + (beqctr cr1) + (vpop arg_x) + (bctr)) + + +(defun replace-function-code (target-fn proto-fn) + (if (typep target-fn 'function) + (if (typep proto-fn 'function) + (setf (uvref target-fn 0) + (uvref proto-fn 0)) + (report-bad-arg proto-fn 'function)) + (report-bad-arg target-fn 'function))) + +(defun closure-function (fun) + (while (and (functionp fun) (not (compiled-function-p fun))) + (setq fun (%svref fun 1)) + (when (vectorp fun) + (setq fun (svref fun 0)))) + fun) + + +;;; For use by (setf (apply ...) ...) +;;; (apply+ f butlast last) = (apply f (append butlast (list last))) +#+ppc-target +(defun apply+ (&lap function arg1 arg2 &rest other-args) + (ppc-lap-function apply+ () + (check-nargs 3 nil) + (vpush arg_x) + (mr temp0 arg_z) ; last + (mr arg_z arg_y) ; butlast + (subi nargs nargs '2) ; remove count for butlast & last + (mflr loc-pc) + (bla .SPspreadargz) + (cmpri cr0 nargs '3) + (mtlr loc-pc) + (addi nargs nargs '1) ; count for last + (blt cr0 @nopush) + (vpush arg_x) +@nopush + (mr arg_x arg_y) + (mr arg_y arg_z) + (mr arg_z temp0) + (ldr temp0 'funcall nfn) + (ba .SPfuncall))) + +(lfun-bits #'apply+ (logior $lfbits-rest-bit + (dpb 3 $lfbits-numreq 0))) + +;;; end of ppc-def.lisp Index: /branches/experimentation/later/source/level-0/PPC/ppc-float.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-float.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-float.lisp (revision 8058) @@ -0,0 +1,727 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + + +;;; 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 + +#+ppc32-target +(defppclapfunction %make-float-from-fixnums ((float 4)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z)) + (rlwinm imm0 sign 0 0 0) ; just leave sign bit + (rlwimi imm0 exp (- 20 ppc32::fixnumshift) 1 11) ; exp left 20 right 2 keep 11 bits + (lwz imm1 hi vsp) + (srawi imm1 imm1 ppc32::fixnumshift) ; fold into below? nah keep for later + (rlwimi imm0 imm1 (- 32 4) 12 31) ; right 4 - keep 20 - stuff into hi result + (rlwinm imm1 imm1 28 0 3) ; hi goes left 28 - keep 4 hi bits + (rlwimi imm1 lo (- 32 ppc32::fixnumshift) 4 31) ; stuff in 28 bits of lo + (lwz temp0 float vsp) ; the float + (stw imm0 ppc32::double-float.value temp0) + (stw imm1 ppc32::double-float.val-low temp0) + (la vsp 8 vsp) + (blr)) + +#+ppc64-target +(defppclapfunction %make-float-from-fixnums ((float 8)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z)) + (rlwinm imm0 sign 0 0 0) ; just leave sign bit + (rlwimi imm0 exp (- 20 ppc64::fixnumshift) 1 11) ; exp left 20 right 2 keep 11 bits + (ld imm1 hi vsp) + (srawi imm1 imm1 ppc64::fixnumshift) ; fold into below? nah keep for later + (rlwimi imm0 imm1 (- 32 4) 12 31) ; right 4 - keep 20 - stuff into hi result + (rlwinm imm1 imm1 28 0 3) ; hi goes left 28 - keep 4 hi bits + (rlwimi imm1 lo (- 32 ppc64::fixnumshift) 4 31) ; stuff in 28 bits of lo + (ld temp0 float vsp) ; the float + (stw imm0 ppc64::double-float.value temp0) + (stw imm1 ppc64::double-float.val-low temp0) + (la vsp '2 vsp) + (blr)) + +#+ppc32-target +(defppclapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z)) + (unbox-fixnum imm0 sig) + (rlwimi imm0 exp (- 29 8) 1 8) + (inslwi imm0 sign 1 0) + (vpop arg_z) + (stw imm0 ppc32::single-float.value arg_z) + (blr)) + + +(defppclapfunction %%double-float-abs! ((n arg_y)(val arg_z)) + (get-double-float fp1 n) + (fabs fp1 fp1) + (put-double-float fp1 val) + (blr)) + +#+ppc32-target +(defppclapfunction %%short-float-abs! ((n arg_y) (val arg_z)) + (get-single-float fp1 n) + (fabs fp0 fp1) + (put-single-float fp0 val) + (blr)) + +#+ppc64-target +(defppclapfunction %short-float-abs ((n arg_z)) + (get-single-float fp1 n) + (fabs fp0 fp1) + (put-single-float fp0 arg_z) + (blr)) + +(defppclapfunction %double-float-negate! ((src arg_y) (res arg_z)) + (get-double-float fp0 src) + (fneg fp1 fp0) + (put-double-float fp1 res) + (blr)) + +#+ppc32-target +(defppclapfunction %short-float-negate! ((src arg_y) (res arg_z)) + (get-single-float fp0 src) + (fneg fp1 fp0) + (put-single-float fp1 res) + (blr)) + +#+ppc64-target +;;; Non-destructive. +(defppclapfunction %short-float-negate ((src arg_z)) + (get-single-float fp0 src) + (fneg fp1 fp0) + (put-single-float fp1 arg_z) + (blr)) + + +;;; rets hi (25 bits) lo (28 bits) exp sign +#+ppc32-target +(defppclapfunction %integer-decode-double-float ((n arg_z)) + (lwz imm0 ppc32::double-float.value n) + (rlwinm imm1 imm0 (+ 1 ppc32::fixnumshift) (- 32 ppc32::fixnumshift 1) ; sign boxed + (- 32 ppc32::fixnumshift 1)) + (add imm1 imm1 imm1) ; imm1 = (fixnum 2) (neg) or 0 (pos) + (subfic temp0 imm1 '1) ; sign boxed + (rlwinm. imm2 imm0 (- 32 20) 21 31) ; right 20, keep 11 bits exp - test for 0 + ;(subi imm2 imm2 (+ 53 1022)) ; unbias and scale + (slwi imm2 imm2 ppc32::fixnumshift) ; box + (mr temp1 imm2) ; boxed unbiased exponent + (rlwinm imm0 imm0 12 0 19) ; 20 bits of hi float left 12 + (beq @denorm) ; cr set way back + (addi imm0 imm0 1) ; add implied 1 + @denorm + (rlwinm imm0 imm0 (+ (- 32 12) 4 ppc32::fixnumshift) 0 31) + (lwz imm1 ppc32::double-float.val-low n) ; + (rlwimi imm0 imm1 (+ 4 ppc32::fixnumshift) + (1+ (- 31 4 ppc32::fixnumshift)) + (- 31 ppc32::fixnumshift)) ; high 4 bits in fixnum pos + (rlwinm imm1 imm1 (- 4 ppc32::fixnumshift) + (- 4 ppc32::fixnumshift) + (- 31 ppc32::fixnum-shift)) ; 28 bits thats 2 2 29 + (vpush imm0) ; hi 25 bits of mantissa (includes implied 1) + (vpush imm1) ; lo 28 bits of mantissa + (vpush temp1) ; exp + (vpush temp0) ; sign + (set-nargs 4) + (la temp0 '4 vsp) + (ba .SPvalues)) + + +;;; hi is 25 bits lo is 28 bits +;;; big is 32 lo, 21 hi right justified +#+ppc32-target +(defppclapfunction make-big-53 ((hi arg_x)(lo arg_y)(big arg_z)) + (rlwinm imm0 lo (- 32 ppc32::fixnumshift) 4 31) + (rlwimi imm0 hi (- 32 4 ppc32::fixnumshift) 0 3) + (stw imm0 (+ ppc32::misc-data-offset 0) big) ; low goes in 1st wd + (rlwinm imm0 hi (- 32 (+ ppc32::fixnumshift 4)) 11 31) ; high in second + (stw imm0 (+ ppc32::misc-data-offset 4) big) + (blr)) + + + +(defppclapfunction dfloat-significand-zeros ((dfloat arg_z)) + (lwz imm1 target::double-float.value dfloat) + (rlwinm. imm1 imm1 12 0 19) + (cntlzw imm1 imm1) + (beq @golo) + (box-fixnum arg_z imm1) + (blr) + @golo + (lwz imm1 target::double-float.val-low dfloat) + (cntlzw imm1 imm1) + (addi imm1 imm1 20) + (box-fixnum arg_z imm1) + (blr)) + +(defppclapfunction sfloat-significand-zeros ((sfloat arg_z)) + #+ppc32-target (lwz imm1 ppc32::single-float.value sfloat) + #+ppc64-target (srdi imm1 sfloat 32) + (rlwinm imm1 imm1 9 0 22) + (cntlzw imm1 imm1) + (box-fixnum arg_z imm1) + (blr)) + + + +#+ppc32-target +(defppclapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) + (let ((fl.h 8) + (fl.l 12) + (sc.h 16) + (sc.l 20)) + (clear-fpu-exceptions) + (lwz imm0 ppc32::double-float.value float) + (lwz imm1 ppc32::double-float.val-low float) + (stwu tsp -24 tsp) + (stw tsp 4 tsp) + (stw imm0 fl.h tsp) + (stw imm1 fl.l tsp) + (unbox-fixnum imm0 int) + ;(addi imm0 imm0 1022) ; bias exponent - we assume no ovf + (slwi imm0 imm0 20) ; more important - get it in right place + (stw imm0 sc.h tsp) + (stw rzero sc.l tsp) + (lfd fp0 fl.h tsp) + (lfd fp1 sc.h tsp) + (lwz tsp 0 tsp) + (fmul fp2 fp0 fp1) + (stfd fp2 ppc32::double-float.value result) + (blr))) + +#+ppc64-target +(defppclapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) + (let ((fl.h 16) + (fl.l 20) + (sc.h 24) + (sc.l 28)) + (clear-fpu-exceptions) + (lwz imm0 ppc64::double-float.value float) + (lwz imm1 ppc64::double-float.val-low float) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stw imm0 fl.h tsp) + (stw imm1 fl.l tsp) + (unbox-fixnum imm0 int) + ;(addi imm0 imm0 1022) ; bias exponent - we assume no ovf + (slwi imm0 imm0 20) ; more important - get it in right place + (stw imm0 sc.h tsp) + (stw rzero sc.l tsp) + (lfd fp0 fl.h tsp) + (lfd fp1 sc.h tsp) + (la tsp 32 tsp) + (fmul fp2 fp0 fp1) + (stfd fp2 ppc64::double-float.value result) + (blr))) + +#+ppc32-target +(defppclapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z)) + (let ((sc.h 12)) + (clear-fpu-exceptions) + (lfs fp0 ppc32::single-float.value float) + (unbox-fixnum imm0 int) + (slwi imm0 imm0 IEEE-single-float-exponent-offset) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stw imm0 sc.h tsp) + (lfs fp1 sc.h tsp) + (lwz tsp 0 tsp) + (fmuls fp2 fp0 fp1) + (stfs fp2 ppc32::single-float.value result) + (blr))) + + +#+ppc64-target +(defppclapfunction %%scale-sfloat! ((float arg_y)(int arg_z)) + (let ((sc.h 16)) + (clear-fpu-exceptions) + (get-single-float fp0 float) + (unbox-fixnum imm0 int) + (slwi imm0 imm0 IEEE-single-float-exponent-offset) + (stwu tsp -32 tsp) + (stw tsp 8 tsp) + (stw imm0 sc.h tsp) + (lfs fp1 sc.h tsp) + (la tsp 32 tsp) + (fmuls fp2 fp0 fp1) + (put-single-float fp2 arg_z) + (blr))) + +(defppclapfunction %copy-double-float ((f1 arg_y) (f2 arg_z)) + (lfd fp0 target::double-float.value f1) + (stfd fp0 target::double-float.value f2) + (blr)) + + +#+ppc32-target +(defppclapfunction %copy-short-float ((f1 arg_y) (f2 arg_z)) + (lfs fp0 ppc32::single-float.value f1) + (stfs fp0 ppc32::single-float.value f2) + (blr)) + +#+ppc32-target +(defppclapfunction %double-float-exp ((n arg_z)) + (lwz imm1 target::double-float.value n) + (rlwinm arg_z imm1 (- 32 (- 20 target::fixnumshift)) 19 29) ; right 20 left 2 = right 18 = left 14 + (blr)) + + + +#+ppc32-target +(defppclapfunction set-%double-float-exp ((float arg_y) (exp arg_z)) + (lwz imm1 target::double-float.value float) + (rlwimi imm1 exp (- 20 target::fixnumshift) 1 11) + (stw imm1 target::double-float.value float) ; hdr - tag = 8 - 2 + (blr)) + + + +#+ppc32-target +(defppclapfunction %short-float-exp ((n arg_z)) + (lwz imm1 ppc32::single-float.value n) + (rlwinm arg_z imm1 (- 32 (- 23 ppc32::fixnumshift)) 22 29) + (blr)) + + + +#+ppc32-target +(defppclapfunction set-%short-float-exp ((float arg_y) (exp arg_z)) + (lwz imm1 ppc32::single-float.value float) + (rlwimi imm1 exp (- 23 ppc32::fixnumshift) 1 8) + (stw imm1 ppc32::single-float.value float) + (blr)) + + +(defppclapfunction %short-float->double-float ((src arg_y) (result arg_z)) + (get-single-float fp0 src) + (put-double-float fp0 result) + (blr)) + +#+ppc32-target +(defppclapfunction %double-float->short-float ((src arg_y) (result arg_z)) + ;(clear-fpu-exceptions) + (get-double-float fp0 src) + (frsp fp1 fp0) + (put-single-float fp1 result) + (blr)) + +#+ppc64-target +(defppclapfunction %double-float->short-float ((src arg_z)) + ;(clear-fpu-exceptions) + (get-double-float fp0 src) + (frsp fp1 fp0) + (put-single-float fp1 arg_z) + (blr)) + + + +#+ppc32-target +(defppclapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z)) + (int-to-freg int fp0 imm0) + (stfs fp0 ppc32::single-float.value sfloat) + (blr)) + +#+ppc64-target +(defppclapfunction %int-to-sfloat ((int arg_z)) + (int-to-freg int fp0 imm0) + (stfs fp0 ppc64::tcr.single-float-convert ppc64::rcontext) + (ld arg_z ppc64::tcr.single-float-convert ppc64::rcontext) + (blr)) + + +(defppclapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z)) + (int-to-freg int fp0 imm0) + (stfd fp0 target::double-float.value dfloat) + (blr)) + + + + +; Manipulating the FPSCR. +; This returns the bottom 8 bits of the FPSCR +(defppclapfunction %get-fpscr-control () + (mffs fp0) + (stfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (lbz imm0 (+ target::tcr.lisp-fpscr-high 7) target::rcontext) + (box-fixnum arg_z imm0) + (blr)) + +; Returns the high 24 bits of the FPSCR +(defppclapfunction %get-fpscr-status () + (mffs fp0) + (stfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (lwz imm0 target::tcr.lisp-fpscr-low tsp) + (clrrwi imm0 imm0 8) + (srwi arg_z imm0 (- 8 target::fixnumshift)) + (blr)) + +; Set the high 24 bits of the FPSCR; leave the low 8 unchanged +(defppclapfunction %set-fpscr-status ((new arg_z)) + (slwi imm0 new (- 8 target::fixnumshift)) + (stw imm0 target::tcr.lisp-fpscr-low target::rcontext) + (lfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (mtfsf #xfc fp0) ; set status fields [0-5] + (blr)) + +; Set the low 8 bits of the FPSCR. Zero the upper 24 bits +(defppclapfunction %set-fpscr-control ((new arg_z)) + (unbox-fixnum imm0 new) + (clrlwi imm0 imm0 24) ; ensure that "status" fields are clear + (stw imm0 target::tcr.lisp-fpscr-low target::rcontext) + (lfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (mtfsf #xff fp0) ; set all fields [0-7] + (blr)) + +(defppclapfunction %ffi-exception-status () + (lwz imm0 ppc32::tcr.ffi-exception target::rcontext) + (mtcrf #xfc imm0) + (mcrfs :cr6 :cr6) + (mcrfs :cr7 :cr7) + (crand ppc::fpscr-fex-bit ppc::fpscr-oe-bit ppc::fpscr-ox-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-ve-bit ppc::fpscr-vx-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-ue-bit ppc::fpscr-ux-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-ze-bit ppc::fpscr-zx-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-xe-bit ppc::fpscr-xx-bit) + (bf ppc::fpscr-fex-bit @ret) + @set + (oris imm0 imm0 #xc000) + @ret + (srwi arg_z imm0 (- 8 target::fixnumshift)) + (blr)) + + +; See if the binary double-float operation OP set any enabled +; exception bits in the fpscr +(defun %df-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 24) fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + 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 24) fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + #+ppc32-target + (%copy-short-float op0 (%make-sfloat)) + #+ppc64-target op0 + #+ppc32-target + (%copy-short-float op1 (%make-sfloat)) + #+ppc64-target op1))) + +(defun %df-check-exception-1 (operation op0 fp-status) + (declare (fixnum fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + (%copy-double-float op0 (%make-dfloat))))) + +(defun %sf-check-exception-1 (operation op0 fp-status) + (declare (type (unsigned-byte 24) fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + #+ppc32-target + (%copy-short-float op0 (%make-sfloat)) + #+ppc64-target op0))) + + +(defun fp-condition-from-fpscr (status-bits control-bits) + (declare (fixnum status-bits control-bits)) + (cond + ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits) + (logbitp (- 31 ppc::fpscr-ve-bit) control-bits)) + 'floating-point-invalid-operation) + ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits) + (logbitp (- 31 ppc::fpscr-oe-bit) control-bits)) + 'floating-point-overflow) + ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits) + (logbitp (- 31 ppc::fpscr-ue-bit) control-bits)) + 'floating-point-underflow) + ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits) + (logbitp (- 31 ppc::fpscr-ze-bit) control-bits)) + 'division-by-zero) + ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits) + (logbitp (- 31 ppc::fpscr-xe-bit) control-bits)) + 'floating-point-inexact))) + +;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set. +(defun %fp-error-from-status (status-bits control-bits operation &rest operands) + (declare (type (unsigned-byte 16) status-bits)) + (case operation + (sqrt (setq operands (cdr operands)))) + (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits))) + (if condition-class + (error (make-instance condition-class + :operation operation + :operands operands))))) + +(defun fp-minor-opcode-operation (minor-opcode) + (case minor-opcode + (25 '*) + (18 '/) + (20 '-) + (21 '+) + (22 'sqrt) + (t 'unknown))) + +;;; Don't we already have about 20 versions of this ? +(defppclapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z)) + (ldr imm0 target::macptr.address ptr) + (unbox-fixnum imm1 byte-offset) + (lfdx fp1 imm0 imm1) + (put-double-float fp1 dest) + (blr)) + + +(defvar *rounding-mode-alist* + '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) + +(defun get-fpu-mode (&optional (mode nil mode-p)) + (let* ((flags (%get-fpscr-control))) + (declare (type (unsigned-byte 8) flags)) + (if mode-p + (ecase mode + (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*))) + (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags)) + (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags)) + (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags)) + (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags)) + (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags))) + `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*)) + :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags) + :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags) + :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags) + :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags) + :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags))))) + +;;; 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* ((mask (logior (if rounding-p #x03 #x00) + (if invalid-p + (ash 1 (- 31 ppc::fpscr-ve-bit)) + #x00) + (if overflow-p + (ash 1 (- 31 ppc::fpscr-oe-bit)) + #x00) + (if underflow-p + (ash 1 (- 31 ppc::fpscr-ue-bit)) + #x00) + (if zero-p + (ash 1 (- 31 ppc::fpscr-ze-bit)) + #x00) + (if inexact-p + (ash 1 (- 31 ppc::fpscr-xe-bit)) + #x00))) + (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "Unknown rounding mode: ~s" rounding-mode)) + (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0) + (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0) + (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit)) 0) + (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0) + (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0)))) + (declare (type (unsigned-byte 8) new mask)) + (%set-fpscr-control (logior (logand new mask) + (logandc2 (%get-fpscr-control) mask))))) + + +;;; Copy a single float pointed at by the macptr in single +;;; to a double float pointed at by the macptr in double + +(defppclapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z)) + (check-nargs 2) + (macptr-ptr imm0 single) + (lfs fp0 0 imm0) + (macptr-ptr imm0 double) + (stfd fp0 0 imm0) + (blr)) + +;;; Copy a double float pointed at by the macptr in double +;;; to a single float pointed at by the macptr in single. +(defppclapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z)) + (check-nargs 2) + (macptr-ptr imm0 double) + (lfd fp0 0 imm0) + (macptr-ptr imm0 single) + (stfs fp0 0 imm0) + (blr)) + + +(defppclapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z)) + (check-nargs 2) + (macptr-ptr imm0 macptr) + (get-double-float fp1 src) + (stfs fp1 0 imm0) + (blr)) + +#+ppc32-target +(defun host-single-float-from-unsigned-byte-32 (u32) + (let* ((f (%make-sfloat))) + (setf (uvref f ppc32::single-float.value-cell) u32) + f)) + +#+ppc64-target +(defppclapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z)) + (sldi arg_z arg_z (- 32 ppc64::fixnumshift)) + (ori arg_z arg_z ppc64::subtag-single-float) + (blr)) + + +#+ppc32-target +(defun single-float-bits (f) + (uvref f ppc32::single-float.value-cell)) + +#+ppc64-target +(defppclapfunction single-float-bits ((f arg_z)) + (srdi arg_z f (- 32 ppc64::fixnumshift)) + (blr)) + +(defun double-float-bits (f) + (values (uvref f target::double-float.value-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.value-cell) high + (uvref f target::double-float.val-low-cell) low) + f)) + +(defppclapfunction %double-float-sign ((n arg_z)) + (lwz imm0 target::double-float.value n) + (cmpwi imm0 0) + (li arg_z nil) + (bgelr) + (li arg_z t) + (blr)) + +(defppclapfunction %short-float-sign ((n arg_z)) + #+ppc32-target (lwz imm0 ppc32::single-float.value n) + #+ppc64-target (srdi imm0 n 32) + (cmpwi imm0 0) + (li arg_z nil) + (bgelr) + (li arg_z t) + (blr)) + +#+32-bit-target +(defppclapfunction %single-float-sqrt! ((src arg_y) (dest arg_z)) + (get-single-float fp1 src) + (fsqrts fp2 fp1) + (put-single-float fp2 dest) + (blr)) + +#+64-bit-target +(defppclapfunction %single-float-sqrt ((arg arg_z)) + (get-single-float fp1 arg) + (fsqrts fp2 fp1) + (put-single-float fp2 arg_z) + (blr)) + +(defppclapfunction %double-float-sqrt! ((src arg_y) (dest arg_z)) + (get-double-float fp1 src) + (fsqrt fp2 fp1) + (put-double-float fp2 dest) + (blr)) + +#+poweropen-target +(defppclapfunction %get-fp-arg-regs ((ptr arg_z)) + (macptr-ptr imm0 ptr) + (stfd fp1 0 imm0) + (stfd fp2 8 imm0) + (stfd fp3 16 imm0) + (stfd fp4 24 imm0) + (stfd fp5 32 imm0) + (stfd fp6 40 imm0) + (stfd fp7 48 imm0) + (stfd fp8 56 imm0) + (stfd fp9 64 imm0) + (stfd fp10 72 imm0) + (stfd fp11 80 imm0) + (stfd fp12 88 imm0) + (stfd fp13 96 imm0) + (blr)) + +#+poweropen-target +(defppclapfunction %load-fp-arg-regs ((n arg_y) (ptr arg_z)) + (cmpdi cr0 n '0) + (cmpdi cr1 n '1) + (cmpdi cr2 n '2) + (cmpdi cr3 n '3) + (cmpdi cr4 n '4) + (cmpdi cr5 n '5) + (cmpdi cr6 n '6) + (cmpdi cr7 n '7) + (beqlr cr0) + (macptr-ptr imm0 ptr) + (cmpdi cr0 n '8) + (lfd fp1 0 imm0) + (beqlr cr1) + (cmpdi cr1 n '9) + (lfd fp2 8 imm0) + (beqlr cr2) + (cmpdi cr2 n '10) + (lfd fp3 16 imm0) + (beqlr cr3) + (cmpdi cr3 n '11) + (lfd fp4 24 imm0) + (beqlr cr4) + (cmpdi cr4 n '12) + (lfd fp5 32 imm0) + (beqlr cr5) + (lfd fp6 40 imm0) + (beqlr cr6) + (lfd fp7 48 imm0) + (beqlr cr7) + (lfd fp8 56 imm0) + (beqlr cr0) + (lfd fp9 64 imm0) + (beqlr cr1) + (lfd fp10 72 imm0) + (beqlr cr2) + (lfd fp11 80 imm0) + (beqlr cr3) + (lfd fp12 88 imm0) + (beqlr cr4) + (lfd fp13 96 imm0) + (blr)) Index: /branches/experimentation/later/source/level-0/PPC/ppc-hash.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-hash.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-hash.lisp (revision 8058) @@ -0,0 +1,147 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + +(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 +#+ppc32-target +(defppclapfunction fast-mod ((number arg_y) (divisor arg_z)) + (divwu imm0 number divisor) + (mullw arg_z imm0 divisor) + (subf arg_z arg_z number) + (blr)) + +#+ppc64-target +(defppclapfunction fast-mod ((number arg_y) (divisor arg_z)) + (divdu imm0 number divisor) + (mulld arg_z imm0 divisor) + (subf arg_z arg_z number) + (blr)) + +#+ppc32-target +(defppclapfunction %dfloat-hash ((key arg_z)) + (lwz imm0 ppc32::double-float.value key) + (lwz imm1 ppc32::double-float.val-low key) + (add imm0 imm0 imm1) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %dfloat-hash ((key arg_z)) + (ld imm0 ppc64::double-float.value key) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %sfloat-hash ((key arg_z)) + (lwz imm0 ppc32::single-float.value key) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %sfloat-hash ((key arg_z)) + (lis imm0 #x8000) + (srdi imm1 key 32) + (cmpw imm0 imm1) + (srdi arg_z key (- 32 ppc64::fixnumshift)) + (bnelr) + (li arg_z 0) + (blr)) + +(defppclapfunction %macptr-hash ((key arg_z)) + (ldr imm0 target::macptr.address key) + (slri imm1 imm0 24) + (add imm0 imm0 imm1) + (clrrri arg_z imm0 target::fixnumshift) + (blr)) + +#+ppc32-target +(defppclapfunction %bignum-hash ((key arg_z)) + (let ((header imm3) + (offset imm2) + (ndigits imm1) + (immhash imm0)) + (li immhash 0) + (li offset ppc32::misc-data-offset) + (getvheader header key) + (header-size ndigits header) + (let ((next header)) + @loop + (cmpwi cr0 ndigits 1) + (subi ndigits ndigits 1) + (lwzx next key offset) + (addi offset offset 4) + (rotlwi immhash immhash 13) + (add immhash immhash next) + (bne cr0 @loop)) + (clrrwi arg_z immhash ppc32::fixnumshift) + (blr))) + +#+ppc64-target +(defppclapfunction %bignum-hash ((key arg_z)) + (let ((header imm3) + (offset imm2) + (ndigits imm1) + (immhash imm0)) + (li immhash 0) + (li offset ppc64::misc-data-offset) + (getvheader header key) + (header-size ndigits header) + (let ((next header)) + @loop + (cmpdi cr0 ndigits 1) + (subi ndigits ndigits 1) + (lwzx next key offset) + (rotldi immhash immhash 13) + (addi offset offset 4) + (add immhash immhash next) + (bne cr0 @loop)) + (clrrdi arg_z immhash ppc64::fixnumshift) + (blr))) + + +(defppclapfunction %get-fwdnum () + (ref-global arg_z target::fwdnum) + (blr)) + + +(defppclapfunction %get-gc-count () + (ref-global arg_z target::gc-count) + (blr)) + + +;;; Setting a key in a hash-table vector needs to +;;; ensure that the vector header gets memoized as well +(defppclapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y) (value arg_z)) + (ba .SPset-hash-key)) + +;;; Strip the tag bits to turn x into a fixnum +(defppclapfunction strip-tag-to-fixnum ((x arg_z)) + (unbox-fixnum imm0 x) + (box-fixnum arg_z imm0) + (blr)) + +;;; end of ppc-hash.lisp Index: /branches/experimentation/later/source/level-0/PPC/ppc-io.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-io.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-io.lisp (revision 8058) @@ -0,0 +1,31 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + +(defppclapfunction %get-errno () + (ldr imm1 target::tcr.errno-loc target::rcontext) + (lwz imm0 0 imm1) + (stw rzero 0 imm1) + (neg imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +; end Index: /branches/experimentation/later/source/level-0/PPC/ppc-misc.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-misc.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-misc.lisp (revision 8058) @@ -0,0 +1,984 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + +;;; 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. + +(defppclapfunction %copy-ptr-to-ivector ((src (* 1 target::node-size) ) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((src-reg imm0) + (src-byteptr imm1) + (src-node-reg temp0) + (dest-byteptr imm2) + (val imm3) + (node-temp temp1)) + (cmpri cr0 nbytes 0) + (ldr src-node-reg src vsp) + (macptr-ptr src-reg src-node-reg) + (ldr src-byteptr src-byte-offset vsp) + (unbox-fixnum src-byteptr src-byteptr) + (unbox-fixnum dest-byteptr dest-byte-offset) + (la dest-byteptr target::misc-data-offset dest-byteptr) + (b @test) + @loop + (subi nbytes nbytes '1) + (cmpri cr0 nbytes '0) + (lbzx val src-reg src-byteptr) + (la src-byteptr 1 src-byteptr) + (stbx val dest dest-byteptr) + (la dest-byteptr 1 dest-byteptr) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp '2 vsp) + (blr))) + +(defppclapfunction %copy-ivector-to-ptr ((src (* 1 target::node-size)) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (ldr temp0 src vsp) + (cmpri cr0 nbytes 0) + (ldr imm0 src-byte-offset vsp) + (unbox-fixnum imm0 imm0) + (la imm0 target::misc-data-offset imm0) + (unbox-fixnum imm2 dest-byte-offset) + (ldr imm1 target::macptr.address dest) + (b @test) + @loop + (subi nbytes nbytes '1) + (cmpri cr0 nbytes 0) + (lbzx imm3 temp0 imm0) + (addi imm0 imm0 1) + (stbx imm3 imm1 imm2) + (addi imm2 imm2 1) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp '2 vsp) + (blr)) + +#+ppc32-target +(defppclapfunction %copy-ivector-to-ivector ((src 4) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (lwz temp0 src vsp) + (cmpwi cr0 nbytes 0) + (cmpw cr2 temp0 dest) ; source and dest same? + (rlwinm imm3 nbytes 0 (- 30 target::fixnum-shift) 31) + (lwz imm0 src-byte-offset vsp) + (rlwinm imm1 imm0 0 (- 30 target::fixnum-shift) 31) + (or imm3 imm3 imm1) + (unbox-fixnum imm0 imm0) + (la imm0 target::misc-data-offset imm0) + (unbox-fixnum imm2 dest-byte-offset) + (rlwimi imm1 imm2 0 30 31) + (or imm3 imm3 imm1) + (cmpwi cr1 imm3 0) ; is everybody multiple of 4? + (la imm2 target::misc-data-offset imm2) + (beq cr2 @SisD) ; source and dest same + @fwd + (beq :cr1 @wtest) + (b @test) + + @loop + (subi nbytes nbytes '1) + (cmpwi cr0 nbytes 0) + (lbzx imm3 temp0 imm0) + (addi imm0 imm0 1) + (stbx imm3 dest imm2) + (addi imm2 imm2 1) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp 8 vsp) + (blr) + + @words ; source and dest different - words + (subi nbytes nbytes '4) + (cmpwi cr0 nbytes 0) + (lwzx imm3 temp0 imm0) + (addi imm0 imm0 4) + (stwx imm3 dest imm2) + (addi imm2 imm2 4) + @wtest + (bgt cr0 @words) + @done + (mr arg_z dest) + (la vsp 8 vsp) + (blr) + + @SisD + (cmpw cr2 imm0 imm2) ; cmp src and dest + (bgt cr2 @fwd) + ;(B @bwd) + + + ; Copy backwards when src & dest are the same and we're sliding down + @bwd ; ok + (unbox-fixnum imm3 nbytes) + (add imm0 imm0 imm3) + (add imm2 imm2 imm3) + (b @test2) + @loop2 + (subi nbytes nbytes '1) + (cmpwi cr0 nbytes 0) + (subi imm0 imm0 1) + (lbzx imm3 temp0 imm0) + (subi imm2 imm2 1) + (stbx imm3 dest imm2) + @test2 + (bne cr0 @loop2) + (b @done)) + +#+ppc64-target +(defppclapfunction %copy-ivector-to-ivector ((src-offset 8) + (src-byte-offset-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((src temp0) + (src-byte-offset imm0)) + (subi nbytes nbytes '1) + (ld src-byte-offset src-byte-offset-offset vsp) + (cmpdi nbytes 0 ) + (ld src src-offset vsp) + (la vsp '2 vsp) + (cmpd cr1 src dest) + (cmpdi cr2 src-byte-offset dest-byte-offset) + (unbox-fixnum src-byte-offset src-byte-offset) + (unbox-fixnum imm1 dest-byte-offset) + (la imm0 target::misc-data-offset src-byte-offset) + (la imm1 target::misc-data-offset imm1) + (bne cr1 @test) + ;; Maybe overlap, or maybe nothing to do. + (beq cr2 @done) ; same vectors, same offsets + (blt cr2 @back) ; copy backwards, avoid overlap + (b @test) + @loop + (subi nbytes nbytes '1) + (lbzx imm3 src imm0) + (cmpdi nbytes 0) + (addi imm0 imm0 1) + (stbx imm3 dest imm1) + (addi imm1 imm1 1) + @test + (bge @loop) + @done + (mr arg_z dest) + (blr) + @back + ;; nbytes was predecremented above + (unbox-fixnum imm2 nbytes) + (add imm0 imm2 imm0) + (add imm1 imm2 imm1) + (b @back-test) + @back-loop + (subi nbytes nbytes '1) + (lbzx imm3 src imm0) + (cmpdi nbytes 0) + (subi imm0 imm0 1) + (stbx imm3 dest imm1) + (subi imm1 imm1 1) + @back-test + (bge @back-loop) + (mr arg_z dest) + (blr))) + + +(defppclapfunction %copy-gvector-to-gvector ((src (* 1 target::node-size)) + (src-element 0) + (dest arg_x) + (dest-element arg_y) + (nelements arg_z)) + (subi nelements nelements '1) + (cmpri nelements 0) + (ldr imm0 src-element vsp) + (ldr temp0 src vsp) + (la vsp '2 vsp) + (cmpr cr1 temp0 dest) + (cmpri cr2 src-element dest-element) + (la imm0 target::misc-data-offset imm0) + (la imm1 target::misc-data-offset dest-element) + (bne cr1 @test) + ;; Maybe overlap, or maybe nothing to do. + (beq cr2 @done) ; same vectors, same offsets + (blt cr2 @back) ; copy backwards, avoid overlap + (b @test) + @loop + (subi nelements nelements '1) + (cmpri nelements 0) + (ldrx temp1 temp0 imm0) + (addi imm0 imm0 '1) + (strx temp1 dest imm1) + (addi imm1 imm1 '1) + @test + (bge @loop) + @done + (mr arg_z dest) + (blr) + @back + ;; We decremented NELEMENTS by 1 above. + (add imm1 nelements imm1) + (add imm0 nelements imm0) + (b @back-test) + @back-loop + (subi nelements nelements '1) + (cmpri nelements 0) + (ldrx temp1 temp0 imm0) + (subi imm0 imm0 '1) + (strx temp1 dest imm1) + (subi imm1 imm1 '1) + @back-test + (bge @back-loop) + (mr arg_z dest) + (blr)) + + + + + +#+ppc32-target +(defppclapfunction %heap-bytes-allocated () + (lwz imm2 target::tcr.last-allocptr ppc32::rcontext) + (cmpwi cr1 imm2 0) + (cmpwi allocptr -8) ;void_allocptr + (lwz imm0 target::tcr.total-bytes-allocated-high ppc32::rcontext) + (lwz imm1 target::tcr.total-bytes-allocated-low ppc32::rcontext) + (sub imm2 imm2 allocptr) + (beq cr1 @go) + (beq @go) + (addc imm1 imm1 imm2) + (addze imm0 imm0) + @go + (ba .SPmakeu64)) + +#+ppc64-target +(defppclapfunction %heap-bytes-allocated () + (ld imm2 target::tcr.last-allocptr ppc64::rcontext) + (cmpri cr1 imm2 0) + (cmpri allocptr -16) ;void_allocptr + (ld imm0 target::tcr.total-bytes-allocated-high ppc64::rcontext) + (sub imm2 imm2 allocptr) + (beq cr1 @go) + (beq @go) + (add imm0 imm0 imm2) + @go + (ba .SPmakeu64)) + + +(defppclapfunction values () + (:arglist (&rest values)) + (vpush-argregs) + (add temp0 nargs vsp) + (ba .SPvalues)) + +;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) ash::fixnumshift)) +;; would do this inline. +#+ppc-target +(defppclapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z)) + (check-nargs 2) + (trap-unless-typecode= arg_y target::subtag-macptr) + (str arg_z target::macptr.address arg_y) + (blr)) + +(defppclapfunction %fixnum-from-macptr ((macptr arg_z)) + (check-nargs 1) + (trap-unless-typecode= arg_z target::subtag-macptr) + (ldr imm0 target::macptr.address arg_z) + (trap-unless-lisptag= imm0 target::tag-fixnum imm1) + (mr arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (add imm2 imm2 imm1) + (lwz imm0 0 imm2) + (lwz imm1 4 imm2) + (ba .SPmakeu64)) + +#+ppc64-target +(defppclapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (ldx imm0 imm2 imm1) + (ba .SPmakeu64)) + +#+ppc32-target +(defppclapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (add imm2 imm2 imm1) + (lwz imm0 0 imm2) + (lwz imm1 4 imm2) + (ba .SPmakes64)) + +#+ppc64-target +(defppclapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (ldx imm0 imm2 imm1) + (ba .SPmakes64)) + +#+ppc32-target +(defppclapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (bla .SPgetu64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (add imm2 imm3 imm2) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (ba .SPpopj)) + +#+ppc64-target +(defppclapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (bla .SPgetu64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (stdx imm0 imm3 imm2) + (ba .SPpopj)) + +#+ppc32-target +(defppclapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (bla .SPgets64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (add imm2 imm3 imm2) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (ba .SPpopj)) + +#+ppc64-target +(defppclapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr target::subtag-macptr) + (bla .SPgets64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (stdx imm0 imm3 imm2) + (ba .SPpopj)) + +(defppclapfunction interrupt-level () + (ldr arg_z target::tcr.tlb-pointer target::rcontext) + (ldr arg_z target::interrupt-level-binding-index arg_z) + (blr)) + + +(defppclapfunction disable-lisp-interrupts () + (li imm0 '-1) + (ldr imm1 target::tcr.tlb-pointer target::rcontext) + (ldr arg_z target::interrupt-level-binding-index imm1) + (str imm0 target::interrupt-level-binding-index imm1) + (blr)) + +(defppclapfunction set-interrupt-level ((new arg_z)) + (ldr imm1 target::tcr.tlb-pointer target::rcontext) + (trap-unless-lisptag= new target::tag-fixnum imm0) + (str new target::interrupt-level-binding-index imm1) + (blr)) + +;;; If we're restoring the interrupt level to 0 and an interrupt +;;; was pending, restore the level to 1 and zero the pending status. +(defppclapfunction restore-interrupt-level ((old arg_z)) + (cmpri :cr1 old 0) + (ldr imm0 target::tcr.interrupt-pending target::rcontext) + (ldr imm1 target::tcr.tlb-pointer target::rcontext) + (cmpri :cr0 imm0 0) + (bne :cr1 @store) + (beq :cr0 @store) + (str rzero target::tcr.interrupt-pending target::rcontext) + (li old '1) + @store + (str old target::interrupt-level-binding-index imm1) + (blr)) + + + +(defppclapfunction %current-tcr () + (mr arg_z target::rcontext) + (blr)) + +(defppclapfunction %tcr-toplevel-function ((tcr arg_z)) + (check-nargs 1) + (cmpr tcr target::rcontext) + (mr imm0 vsp) + (ldr temp0 target::tcr.vs-area tcr) + (ldr imm1 target::area.high temp0) + (beq @room) + (ldr imm0 target::area.active temp0) + @room + (cmpr imm1 imm0) + (li arg_z nil) + (beqlr) + (ldr arg_z (- target::node-size) imm1) + (blr)) + +(defppclapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z)) + (check-nargs 2) + (cmpr tcr target::rcontext) + (mr imm0 vsp) + (ldr temp0 target::tcr.vs-area tcr) + (ldr imm1 target::area.high temp0) + (beq @check-room) + (ldr imm0 target::area.active temp0) + @check-room + (cmpr imm1 imm0) + (push rzero imm1) + (bne @have-room) + (str imm1 target::area.active temp0) + (str imm1 target::tcr.save-vsp tcr) + @have-room + (str fun 0 imm1) + (blr)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defppclapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) + (ba .SPstore-node-conditional)) + +(defppclapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) + (vpop temp0) + (unbox-fixnum imm0 temp0) + (let ((current temp1)) + @again + (lrarx current object imm0) + (cmpr current old) + (bne @lose) + (strcx. new object imm0) + (bne @again) + (isync) + (li arg_z (+ target::t-offset target::nil-value)) + (blr) + @lose + (li imm0 target::reservation-discharge) + (strcx. rzero rzero imm0) + (li arg_z nil) + (blr))) + +(defppclapfunction set-%gcable-macptrs% ((ptr target::arg_z)) + (li imm0 (+ target::nil-value (target::kernel-global gcable-pointers))) + @again + (lrarx arg_y rzero imm0) + (str arg_y target::xmacptr.link ptr) + (strcx. ptr rzero imm0) + (bne @again) + (isync) + (blr)) + +;;; Atomically increment or decrement the gc-inhibit-count kernel-global +;;; (It's decremented if it's currently negative, incremented otherwise.) +(defppclapfunction %lock-gc-lock () + (li imm0 (+ target::nil-value (target::kernel-global gc-inhibit-count))) + @again + (lrarx arg_y rzero imm0) + (cmpri cr1 arg_y 0) + (addi arg_z arg_y '1) + (bge cr1 @store) + (subi arg_z arg_y '1) + @store + (strcx. arg_z rzero imm0) + (bne @again) +;; (isync) + (blr)) + +;;; 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.) +(defppclapfunction %unlock-gc-lock () +;; (sync) + (li imm0 (+ target::nil-value (target::kernel-global gc-inhibit-count))) + @again + (lrarx arg_y rzero imm0) + (cmpri cr1 arg_y -1) + (subi arg_z arg_y '1) + (bgt cr1 @store) + (addi arg_z arg_y '1) + @store + (strcx. arg_z rzero imm0) + (bne @again) + (bnelr cr1) + ;; The GC tried to run while it was inhibited. Unless something else + ;; has just inhibited it, it should be possible to GC now. + (li imm0 arch::gc-trap-function-immediate-gc) + (trlgei allocptr 0) + (blr)) + + + +(defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) + (check-nargs 3) + (unbox-fixnum imm1 disp) + @again + (lrarx arg_z node imm1) + (add arg_z arg_z by) + (strcx. arg_z node imm1) + (bne- @again) + (isync) + (blr)) + +(defppclapfunction %atomic-incf-ptr ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (addi imm0 imm0 1) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 by) + @again + (lrarx imm0 0 imm1) + (add imm0 imm0 imm2) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %atomic-decf-ptr ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (subi imm0 imm0 1) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (cmpri cr1 imm0 0) + (subi imm0 imm0 1) + (beq @done) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr) + @done + (li imm1 target::reservation-discharge) + (box-fixnum arg_z imm0) + (strcx. rzero rzero imm1) + (blr)) + +(defppclapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) + (sync) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 arg_z) + @again + (lrarx imm0 0 imm1) + (strcx. imm2 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value +;;; was equal to OLDVAL. Return the old value +(defppclapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (macptr-ptr imm0 ptr) + (unbox-fixnum imm1 expected-oldval) + (unbox-fixnum imm2 newval) + @again + (lrarx imm3 0 imm0) + (cmpr imm3 imm1) + (bne- @done) + (strcx. imm2 0 imm0) + (bne- @again) + (isync) + (box-fixnum arg_z imm3) + (blr) + @done + (li imm0 target::reservation-discharge) + (box-fixnum arg_z imm3) + (strcx. rzero 0 imm0) + (blr)) + +(defppclapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (let ((address imm0) + (actual-oldval imm1)) + (macptr-ptr address ptr) + @again + (lrarx actual-oldval 0 address) + (cmpr actual-oldval expected-oldval) + (bne- @done) + (strcx. newval 0 address) + (bne- @again) + (isync) + (mr arg_z actual-oldval) + (blr) + @done + (li address target::reservation-discharge) + (mr arg_z actual-oldval) + (strcx. rzero 0 address) + (blr))) + + + + +(defppclapfunction %macptr->dead-macptr ((macptr arg_z)) + (check-nargs 1) + (li imm0 target::subtag-dead-macptr) + (stb imm0 target::misc-subtag-offset macptr) + (blr)) + +(defppclapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0) + (parent arg_x) (function arg_y) (arglist arg_z)) + (check-nargs 7) + + ; Throw through catch-count catch frames + (lwz imm0 12 vsp) ; catch-count + (vpush parent) + (vpush function) + (vpush arglist) + (bla .SPnthrowvalues) + + ; Pop tsp-count TSP frames + (lwz tsp-count 16 vsp) + (cmpi cr0 tsp-count 0) + (b @test) +@loop + (subi tsp-count tsp-count '1) + (cmpi cr0 tsp-count 0) + (lwz tsp 0 tsp) +@test + (bne cr0 @loop) + + ; Pop dynamic bindings until we get to db-link + (lwz imm0 12 vsp) ; db-link + (lwz imm1 target::tcr.db-link target::rcontext) + (cmp cr0 imm0 imm1) + (beq cr0 @restore-regs) ; .SPunbind-to expects there to be something to do + (bla .SPunbind-to) + +@restore-regs + ; restore the saved registers from srv + (lwz srv 20 vsp) +@get0 + (svref imm0 1 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get1) + (lwz save0 0 imm0) +@get1 + (svref imm0 2 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get2) + (lwz save1 0 imm0) +@get2 + (svref imm0 3 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get3) + (lwz save2 0 imm0) +@get3 + (svref imm0 4 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get4) + (lwz save3 0 imm0) +@get4 + (svref imm0 5 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get5) + (lwz save4 0 imm0) +@get5 + (svref imm0 6 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get6) + (lwz save5 0 imm0) +@get6 + (svref imm0 7 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @get7) + (lwz save6 0 imm0) +@get7 + (svref imm0 8 srv) + (cmpwi cr0 imm0 target::nil-value) + (beq @got) + (lwz save7 0 imm0) +@got + + (vpop arg_z) ; arglist + (vpop temp0) ; function + (vpop parent) ; parent + (extract-lisptag imm0 parent) + (cmpi cr0 imm0 target::tag-fixnum) + (if (:cr0 :ne) + ; Parent is a fake-stack-frame. Make it real + (progn + (svref sp %fake-stack-frame.sp parent) + (stwu sp (- target::lisp-frame.size) sp) + (svref fn %fake-stack-frame.fn parent) + (stw fn target::lisp-frame.savefn sp) + (svref temp1 %fake-stack-frame.vsp parent) + (stw temp1 target::lisp-frame.savevsp sp) + (svref temp1 %fake-stack-frame.lr parent) + (extract-lisptag imm0 temp1) + (cmpi cr0 imm0 target::tag-fixnum) + (if (:cr0 :ne) + ;; must be a macptr encoding the actual link register + (macptr-ptr loc-pc temp1) + ;; Fixnum is offset from start of function vector + (progn + (svref temp2 0 fn) ; function vector + (unbox-fixnum temp1 temp1) + (add loc-pc temp2 temp1))) + (stw loc-pc target::lisp-frame.savelr sp)) + ;; Parent is a real stack frame + (mr sp parent)) + (set-nargs 0) + (bla .SPspreadargz) + (ba .SPtfuncallgen)) + +#+ppc32-target +;;; Easiest to do this in lap, to avoid consing bignums and/or +;;; multiple-value hair. +;;; Bang through code-vector until the end or a 0 (traceback table +;;; header) is found. Return high-half, low-half of last instruction +;;; and index where found. +(defppclapfunction %code-vector-last-instruction ((cv arg_z)) + (let ((previ imm0) + (nexti imm1) + (idx imm2) + (offset imm3) + (len imm4)) + (vector-length len cv len) + (li idx 0) + (cmpw cr0 idx len) + (li offset target::misc-data-offset) + (li nexti 0) + (b @test) + @loop + (mr previ nexti) + (lwzx nexti cv offset) + (cmpwi cr1 nexti 0) + (addi idx idx '1) + (cmpw cr0 idx len) + (addi offset offset '1) + (beq cr1 @done) + @test + (bne cr0 @loop) + (mr previ nexti) + @done + (digit-h temp0 previ) + (digit-l temp1 previ) + (subi idx idx '1) + (vpush temp0) + (vpush temp1) + (vpush idx) + (set-nargs 3) + (la temp0 '3 vsp) + (ba .SPvalues))) + +#+ppc64-target +(defun %code-vector-last-instruction (cv) + (do* ((i 1 (1+ i)) + (instr nil) + (n (uvsize cv))) + ((= i n) instr) + (declare (fixnum i n)) + (let* ((next (uvref cv i))) + (declare (type (unsigned-byte 32) next)) + (if (zerop next) + (return instr) + (setq instr next))))) + + + + +(defppclapfunction %%save-application ((flags arg_y) (fd arg_z)) + (unbox-fixnum imm0 flags) + (ori imm0 imm0 arch::gc-trap-function-save-application) + (unbox-fixnum imm1 fd) + (trlgei allocptr 0) + (blr)) + +(defppclapfunction %metering-info ((ptr arg_z)) + (ref-global imm0 metering-info) + (stw imm0 target::macptr.address ptr) + (blr)) + +(defppclapfunction %misc-address-fixnum ((misc-object arg_z)) + (check-nargs 1) + (la arg_z target::misc-data-offset misc-object) + (blr)) + + +#+ppc32-target +(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr imm1 ptr) ; address in macptr + (addi imm0 imm1 9) ; 2 for delta + 7 for alignment + (clrrwi imm0 imm0 3) ; Clear low three bits to align + (subf imm1 imm1 imm0) ; imm1 = delta + (sth imm1 -2 imm0) ; save delta halfword + (unbox-fixnum imm1 subtype) ; subtype at low end of imm1 + (rlwimi imm1 len (- target::num-subtag-bits target::fixnum-shift) 0 (- 31 target::num-subtag-bits)) + (stw imm1 0 imm0) ; store subtype & length + (addi arg_z imm0 target::fulltag-misc) ; tag it, return it + (blr)) + +#+ppc64-target +(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr imm1 ptr) ; address in macptr + (addi imm0 imm1 17) ; 2 for delta + 15 for alignment + (clrrdi imm0 imm0 4) ; Clear low four bits to align + (subf imm1 imm1 imm0) ; imm1 = delta + (sth imm1 -2 imm0) ; save delta halfword + (unbox-fixnum imm1 subtype) ; subtype at low end of imm1 + (sldi imm2 len (- target::num-subtag-bits target::fixnum-shift)) + (or imm1 imm2 imm1) + (std imm1 0 imm0) ; store subtype & length + (addi arg_z imm0 target::fulltag-misc) ; tag it, return it + (blr)) + +(defppclapfunction %%make-disposable ((ptr arg_y) (vector arg_z)) + (check-nargs 2) + (subi imm0 vector target::fulltag-misc) ; imm0 is addr = vect less tag + (lhz imm1 -2 imm0) ; get delta + (sub imm0 imm0 imm1) ; vector addr (less tag) - delta is orig addr + (str imm0 target::macptr.address ptr) + (blr)) + +#+ppc32-target +(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + ;; put address of vect data in macptr. For all vector types + ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte + ;; of data is at PPC32::MISC-DATA-OFFSET; for the double-float + ;; types, it's at PPC32::MISC-DFLOAT-OFFSET. + (extract-subtag imm0 vect) + (cmpwi cr0 imm0 ppc32::subtag-double-float-vector) + (cmpwi cr1 imm0 ppc32::subtag-double-float) + (addi temp0 vect ppc32::misc-data-offset) + (beq cr0 @dfloat) + (beq cr1 @dfloat) + (stw temp0 ppc32::macptr.address arg_z) + (blr) + @dfloat + (addi temp0 vect ppc32::misc-dfloat-offset) + (stw temp0 ppc32::macptr.address arg_z) + (blr)) + +#+ppc64-target +(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + (la imm0 ppc64::misc-data-offset vect) + (std imm0 ppc64::macptr.address ptr) + (blr)) + +(defppclapfunction get-saved-register-values () + (vpush save0) + (vpush save1) + (vpush save2) + (vpush save3) + (vpush save4) + (vpush save5) + (vpush save6) + (vpush save7) + (la temp0 (* 8 target::node-size) vsp) + (set-nargs 8) + (ba .SPvalues)) + + +(defppclapfunction %current-db-link () + (ldr arg_z target::tcr.db-link target::rcontext) + (blr)) + +(defppclapfunction %no-thread-local-binding-marker () + (li arg_z target::subtag-no-thread-local-binding) + (blr)) + + +(defppclapfunction break-event-pending-p () + (ref-global arg_z target::intflag) + (set-global rzero target::intflag) + (cmpri arg_z 0) + (li arg_z nil) + (beqlr) + (la arg_z target::t-offset arg_z) + (blr)) + + +;;; Should be called with interrupts disabled. +(defppclapfunction %safe-get-ptr ((src arg_y) (dest arg_z)) + (check-nargs 2) + (macptr-ptr imm0 src) + (str imm0 target::tcr.safe-ref-address target::rcontext) + (ldr imm0 0 imm0) ; may fault + (str imm0 target::macptr.address dest) + (blr)) + + + +;;; r13 contains thread context on Linux/Darwin PPC64. +;;; That's maintained in r2 on LinuxPPC32, and not maintained +;;; in a GPR on DarwinPPC32 +(defppclapfunction %get-os-context () + #+ppc64-target (mr arg_z 13) + #+linuxppc32-target (mr arg_z 2) + #+darinppc32-target (mr arg_z 0) + (blr)) + +(defppclapfunction %check-deferred-gc () + (ldr imm0 target::tcr.flags target::rcontext) + (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift))) + (li arg_z nil) + (bgelr) + (uuo_interr arch::error-propagate-suspend rzero) + (li arg_z t) + (blr)) + + +; end of ppc-misc.lisp Index: /branches/experimentation/later/source/level-0/PPC/ppc-numbers.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-numbers.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-numbers.lisp (revision 8058) @@ -0,0 +1,443 @@ +;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + +;(push (cons 'number-case 1) *fred-special-indent-alist*) do later + + + +(defppclapfunction %fixnum-signum ((number arg_z)) + (cmpri :cr0 number '0) + (li arg_z '0) + (beqlr :cr0) + (li arg_z '1) ; assume positive + (bgtlr :cr0) + (li arg_z '-1) + (blr)) + +; see %logcount (ppc-bignum.lisp) +(defppclapfunction %ilogcount ((number arg_z)) + (let ((arg imm0) + (shift imm1) + (temp imm2)) + (unbox-fixnum arg number) + (mr. shift arg) + (li arg_z 0) + (b @test) + @next + (la temp -1 shift) + (and. shift shift temp) + (la arg_z '1 arg_z) + @test + (bne @next) + (blr))) + +(defppclapfunction %iash ((number arg_y) (count arg_z)) + (unbox-fixnum imm1 count) + (unbox-fixnum imm0 number) + (neg. imm2 imm1) + (blt @left) + (srar imm0 imm0 imm2) + (box-fixnum arg_z imm0) + (blr) + @left + (slr arg_z number imm1) + (blr)) + +(defparameter *double-float-zero* 0.0d0) +(defparameter *short-float-zero* 0.0s0) + + +#+ppc32-target +(defppclapfunction %sfloat-hwords ((sfloat arg_z)) + (lwz imm0 ppc32::single-float.value sfloat) + (digit-h temp0 imm0) + (digit-l temp1 imm0) + (vpush temp0) + (vpush temp1) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues)) + + +; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg)))) +#+ppc32-target +(defppclapfunction %fixnum-intlen ((number arg_z)) + (unbox-fixnum imm0 arg_z) + (cntlzw. imm1 imm0) ; testing result of cntlzw? - ah no zeros if neg + (bne @nonneg) + (not imm1 imm0) + (cntlzw imm1 imm1) + @nonneg + (subfic imm1 imm1 32) + (box-fixnum arg_z imm1) + (blr)) + +#+ppc64-target +(defppclapfunction %fixnum-intlen ((number arg_z)) + (unbox-fixnum imm0 arg_z) + (cntlzd. imm1 imm0) + (bne @nonneg) + (not imm1 imm0) + (cntlzd imm1 imm1) + @nonneg + (subfic imm1 imm1 64) + (box-fixnum arg_z imm1) + (blr)) + + + + +;;; Caller guarantees that result fits in a fixnum. +#+ppc32-target +(defppclapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctiwz fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctidz fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctiwz fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctidz fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + +;;; DOES round to even +#+ppc32-target +(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctiw fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctid fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctiw fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctid fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + + + + +;;;; maybe this could be smarter but frankly scarlett I dont give a damn +#+ppc32-target +(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (let ((unboxed-quotient imm0) + (unboxed-dividend imm1) + (unboxed-divisor imm2) + (unboxed-product imm3) + (product temp0) + (boxed-quotient temp1) + (remainder temp2)) + (unbox-fixnum unboxed-dividend dividend) + (unbox-fixnum unboxed-divisor divisor) + (divwo. unboxed-quotient unboxed-dividend unboxed-divisor) ; set OV if divisor = 0 + (box-fixnum boxed-quotient unboxed-quotient) + (mullw unboxed-product unboxed-quotient unboxed-divisor) + (bns+ @ok) + (mtxer rzero) + (save-lisp-context) + (set-nargs 3) + (load-constant arg_x truncate) + (call-symbol divide-by-zero-error) + @not-0 + @ok + (subf imm0 unboxed-product unboxed-dividend) + (vpush boxed-quotient) + (box-fixnum remainder imm0) + (vpush remainder) + (set-nargs 2) + (la temp0 8 vsp) + (ba .SPvalues))) + +#+ppc64-target +(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (let ((unboxed-quotient imm0) + (unboxed-dividend imm1) + (unboxed-divisor imm2) + (unboxed-product imm3) + (product temp0) + (boxed-quotient temp1) + (remainder temp2)) + (unbox-fixnum unboxed-dividend dividend) + (unbox-fixnum unboxed-divisor divisor) + (divdo. unboxed-quotient unboxed-dividend unboxed-divisor) ; set OV if divisor = 0 + (box-fixnum boxed-quotient unboxed-quotient) + (mulld unboxed-product unboxed-quotient unboxed-divisor) + (bns+ @ok) + (mtxer rzero) + (save-lisp-context) + (set-nargs 3) + (load-constant arg_x truncate) + (call-symbol divide-by-zero-error) + @not-0 + @ok + (subf imm0 unboxed-product unboxed-dividend) + (vpush boxed-quotient) + (box-fixnum remainder imm0) + (vpush remainder) + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues))) + + +(defppclapfunction called-for-mv-p () + (ref-global imm0 ret1valaddr) + (ldr imm1 target::lisp-frame.savelr sp) + (eq->boolean arg_z imm0 imm1 imm0) + (blr)) + + + + + + + + +#| +Date: Mon, 3 Feb 1997 10:04:08 -0500 +To: info-mcl@digitool.com, wineberg@franz.scs.carleton.ca +From: dds@flavors.com (Duncan Smith) +Subject: Re: More info on the random number generator +Sender: owner-info-mcl@digitool.com +Precedence: bulk + +The generator is a Linear Congruential Generator: + + X[n+1] = (aX[n] + c) mod m + +where: a = 16807 (Park&Miller recommend 48271) + c = 0 + m = 2^31 - 1 + +See: Knuth, Seminumerical Algorithms (Volume 2), Chapter 3. + +The period is: 2^31 - 2 (zero is excluded). + +What makes this generator so simple is that multiplication and addition mod +2^n-1 is easy. See Knuth Ch. 4.3.2 (2nd Ed. p 272). + + ab mod m = ... + +If m = 2^n-1 + u = ab mod 2^n + v = floor( ab / 2^n ) + + ab mod m = u + v : u+v < 2^n + ab mod m = ((u + v) mod 2^n) + 1 : u+v >= 2^n + +What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of +2^31. This reduces the whole generator to 5 instructions on the 680x0 or +80x86, and 8 on the 60x. + +-Duncan + +|# +; Use the two fixnums in state to generate a random fixnum >= 0 and < 65536 +; Scramble those fixnums up a bit. + +#+ppc32-target +(defppclapfunction %next-random-pair ((high arg_y) (low arg_z)) + (slwi imm0 high (- 16 ppc32::fixnumshift)) + (rlwimi imm0 low (- 32 ppc32::fixnumshift) 16 31) + (lwi imm1 48271) + (clrlwi imm0 imm0 1) + (mullw imm0 imm1 imm0) + (clrrwi arg_y imm0 16 ) + (srwi arg_y arg_y (- 16 ppc32::fixnumshift)) + (clrlslwi arg_z imm0 16 ppc32::fixnumshift) + (mr temp0 vsp) + (vpush arg_y) + (vpush arg_z) + (set-nargs 2) + (ba .SPvalues)) + + + + + + + + + +;;; n1 and n2 must be positive (esp non zero) +#+ppc32-target +(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z)) + (let ((temp imm0) + (u imm1) + (v imm2) + (ut0 imm3) + (vt0 imm4)) + (unbox-fixnum u n1) + (unbox-fixnum v n2) + (neg temp u) + (and temp temp u) + (cntlzw ut0 temp) + (subfic ut0 ut0 31) + (neg temp v) + (and temp temp v) + (cntlzw vt0 temp) + (subfic vt0 vt0 31) + (cmpw cr2 ut0 vt0) + (srw u u ut0) + (srw v v vt0) + (addi ut0 ut0 ppc32::fixnum-shift) + (addi vt0 vt0 ppc32::fixnum-shift) + @loop + (cmpw cr0 u v) + (slw arg_z u ut0) + (bgt cr0 @u>v) + (blt cr0 @uv + (sub u u v) + @shiftu + (andi. temp u (ash 1 1)) + (srwi u u 1) + (beq cr0 @shiftu) + (b @loop) + @uv) + (blt cr0 @uv + (sub u u v) + @shiftu + (andi. temp u (ash 1 1)) + (srdi u u 1) + (beq cr0 @shiftu) + (b @loop) + @usymptr ((sym arg_z)) + #+ppc32-target + (progn + (cmpwi cr0 arg_z ppc32::nil-value) + (if (:cr0 :eq) + (progn + (li arg_z (+ ppc32::nilsym-offset ppc32::nil-value)) + (blr)))) + (trap-unless-typecode= arg_z target::subtag-symbol) + (blr)) + +;;; Traps unless symptr is a symbol; on PPC32, returns NIL if symptr +;;; is NILSYM. +(defppclapfunction %symptr->symbol ((symptr arg_z)) + #+ppc32-target + (progn + (li imm1 (+ ppc32::nilsym-offset ppc32::nil-value)) + (cmpw cr0 imm1 symptr) + (if (:cr0 :eq) + (progn + (li arg_z nil) + (blr)))) + (trap-unless-typecode= symptr target::subtag-symbol imm0) + (blr)) + +(defppclapfunction %symptr-value ((symptr arg_z)) + (ba .SPspecref)) + +(defppclapfunction %set-symptr-value ((symptr arg_y) (val arg_z)) + (ba .SPspecset)) + +(defppclapfunction %symptr-binding-address ((symptr arg_z)) + (ldr imm3 target::symbol.binding-index symptr) + (ldr imm2 target::tcr.tlb-limit target::rcontext) + (ldr imm4 target::tcr.tlb-pointer target::rcontext) + (cmplr imm3 imm2) + (bge @sym) + (ldrx temp0 imm4 imm3) + (cmpdi temp0 target::subtag-no-thread-local-binding) + (slri imm3 imm3 target::fixnumshift) + (beq @sym) + (vpush imm4) + (vpush imm3) + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues) + @sym + (li arg_y '#.target::symbol.vcell) + (vpush arg_z) + (vpush arg_y) + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues)) + +(defppclapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z)) + (ldr imm3 target::symbol.binding-index sym) + (ldr imm2 target::tcr.tlb-limit tcr) + (ldr imm4 target::tcr.tlb-pointer tcr) + (li arg_z nil) + (cmplr imm3 imm2) + (bgelr) + (ldrx temp0 imm4 imm3) + (cmpri temp0 target::subtag-no-thread-local-binding) + (beqlr) + (add arg_z imm4 imm3) + (blr)) + + +(defppclapfunction %pname-hash ((str arg_y) (len arg_z)) + (let ((nextw imm1) + (accum imm0) + (offset imm2)) + (cmpwi cr0 len 0) + (li offset target::misc-data-offset) + (li accum 0) + (beqlr- cr0) + @loop + (cmpri cr1 len '1) + (subi len len '1) + (lwzx nextw str offset) + (addi offset offset 4) + (rotlwi accum accum 5) + (xor accum accum nextw) + (bne cr1 @loop) + (slri accum accum 5) + (srri arg_z accum (- 5 target::fixnumshift)) + (blr))) + +(defppclapfunction %string-hash ((start arg_x) (str arg_y) (len arg_z)) + (let ((nextw imm1) + (accum imm0) + (offset imm2)) + (cmpwi cr0 len 0) + #+32-bit-target + (la offset target::misc-data-offset start) + #+64-bit-target + (progn + (srwi offset start 1) + (la offset target::misc-data-offset offset)) + (li accum 0) + (beqlr- cr0) + @loop + (cmpri cr1 len '1) + (subi len len '1) + (lwzx nextw str offset) + (addi offset offset 4) + (rotlwi accum accum 5) + (xor accum accum nextw) + (bne cr1 @loop) + (slri accum accum 5) + (srri arg_z accum (- 5 target::fixnumshift)) + (blr))) Index: /branches/experimentation/later/source/level-0/PPC/ppc-utils.lisp =================================================================== --- /branches/experimentation/later/source/level-0/PPC/ppc-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/PPC/ppc-utils.lisp (revision 8058) @@ -0,0 +1,648 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +#+ppc32-target +(defppclapfunction %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. + (clrlwi. imm0 arg (- 32 ppc32::nlisptagbits)) + (beqlr cr0) + (mr imm0 arg_z) + ;; set cr0_eq if result fits in a fixnum + (clrrwi. imm1 imm0 (- ppc32::least-significant-bit ppc32::nfixnumtagbits)) + (box-fixnum arg_z imm0) ; assume it did + (beqlr+ cr0) ; else arg_z tagged ok, but missing bits + (ba .SPmakeu32) ; put all bits in bignum. +) + +#+ppc64-target +(defppclapfunction %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. + (clrldi. imm0 arg (- 64 ppc64::nlisptagbits)) + (beqlr cr0) + (mr imm0 arg_z) + ;; set cr0_eq if result fits in a fixnum + (clrrdi. imm1 imm0 (- ppc64::least-significant-bit ppc64::nfixnumtagbits)) + (box-fixnum arg_z imm0) ; assume it did + (beqlr+ cr0) ; else arg_z tagged ok, but missing bits + (ba .SPmakeu64) ; put all bits in bignum. +) + +;;; "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. + + + +(defppclapfunction %normalize-areas () + (let ((address imm0) + (temp imm2)) + + ; update active pointer for tsp area. + (ldr address target::tcr.ts-area target::rcontext) + (str tsp target::area.active address) + + ;; Update active pointer for vsp area. + (ldr address target::tcr.vs-area target::rcontext) + (str vsp target::area.active address) + + ; Update active pointer for SP area + (ldr arg_z target::tcr.cs-area target::rcontext) + (str sp target::area.active arg_z) + + + (ref-global arg_z all-areas) + (ldr arg_z target::area.succ arg_z) + + (blr))) + +(defppclapfunction %active-dynamic-area () + (ref-global arg_z all-areas) + (ldr arg_z target::area.succ arg_z) + (blr)) + + +(defppclapfunction %object-in-stack-area-p ((object arg_y) (area arg_z)) + (ldr imm0 target::area.active area) + (cmplr cr0 object imm0) + (ldr imm1 target::area.high area) + (cmplr cr1 object imm1) + (li arg_z nil) + (bltlr cr0) + (bgelr cr1) + (la arg_z target::t-offset arg_z) + (blr)) + +(defppclapfunction %object-in-heap-area-p ((object arg_y) (area arg_z)) + (ldr imm0 target::area.low area) + (cmplr cr0 object imm0) + (ldr imm1 target::area.active area) + (cmplr cr1 object imm1) + (li arg_z nil) + (bltlr cr0) + (bgelr cr1) + (la arg_z target::t-offset arg_z) + (blr)) + + +#+ppc32-target +(defppclapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm0)) + (save-lisp-context) + (:regsave limit 0) + (vpush fun) + (vpush obj) + (vpush limit) + (mr fun f) + (lwz limit ppc32::area.active a) + (lwz obj ppc32::area.low a) + (b @test) + @loop + (lwz header 0 obj) + (extract-fulltag tag header) + (cmpwi cr0 tag ppc32::fulltag-immheader) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la arg_z ppc32::fulltag-cons obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (la obj ppc32::cons.size obj) + (b @test) + @misc + (la arg_z ppc32::fulltag-misc obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (lwz header 0 obj) + (extract-fulltag tag header) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (clrlwi subtag header (- 32 ppc32::num-subtag-bits)) + (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag) + (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag) + (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag) + (cmpwi cr5 subtag ppc32::subtag-double-float-vector) + (header-size elements header) + (slwi bytes elements 2) + (beq cr1 @bump) + (ble cr2 @bump) + (mr bytes elements) + (ble cr3 @bump) + (slwi bytes elements 1) + (ble cr4 @bump) + (slwi bytes elements 3) + (beq cr5 @bump) + (la elements 7 elements) + (srwi bytes elements 3) + @bump + (la bytes (+ 4 7) bytes) + (clrrwi bytes bytes 3) + (add obj obj bytes) + @test + (cmplw :cr0 obj limit) + (blt cr0 @loop) + (vpop limit) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +#+ppc64-target +(defppclapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm0)) + (save-lisp-context) + (:regsave limit 0) + (vpush fun) + (vpush obj) + (vpush limit) + (mr fun f) + (ld limit ppc64::area.active a) + (ld obj ppc64::area.low a) + (b @test) + @loop + (ld header 0 obj) + (extract-lowtag tag header) + (cmpri cr0 tag ppc64::lowtag-immheader) + (cmpri cr1 tag ppc64::lowtag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la arg_z ppc64::fulltag-cons obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (la obj ppc64::cons.size obj) + (b @test) + @misc + (la arg_z ppc64::fulltag-misc obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (ldr header 0 obj) + (extract-lowtag tag header) + (extract-fulltag subtag header) + (cmpri cr1 tag ppc64::lowtag-nodeheader) + (extract-lowbyte tag header) + (cmpri cr2 subtag ppc64::ivector-class-64-bit) + (cmpri cr3 subtag ppc64::ivector-class-8-bit) + (cmpri cr4 subtag ppc64::ivector-class-32-bit) + (cmpri cr5 tag ppc64::subtag-bit-vector) + (header-size elements header) + (sldi bytes elements 3) + (beq cr1 @bump) + (beq cr2 @bump) + (mr bytes elements) + (beq cr3 @bump) + (sldi bytes elements 2) + (beq cr4 @bump) + (sldi bytes elements 1) + (bne cr5 @bump) + (la elements 7 elements) + (srdi bytes elements 3) + @bump + (la bytes (+ 8 15) bytes) + (clrrdi bytes bytes 4) + (add obj obj bytes) + @test + (cmpld :cr0 obj limit) + (blt cr0 @loop) + (vpop limit) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +;;; 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's the vague notion that we can't take an interrupt when +;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a +;;; preemptive scheduler we'd need to enforce this is unclear. We use +;;; initptr as an untagged pointer here (and set it to freeptr when we've +;;; got a tagged pointer to the current object.) +;;; 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.) + +#+ppc32-target +(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (sentinel save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm4)) + (save-lisp-context) + (:regsave sentinel 0) + (vpush fun) + (vpush obj) + (vpush sentinel) + (ref-global imm0 tenured-area) + (cmpwi cr0 imm0 0) + (li allocbase #xfff8) + (la allocptr (- ppc32::fulltag-cons ppc32::cons.size) allocptr) + (twllt allocptr allocbase) + (mr sentinel allocptr) + (clrrwi allocptr allocptr ppc32::ntagbits) + (mr fun f) + (if :ne + (mr a imm0)) + (lwz imm5 ppc32::area.low a) + @loop + (lwz header 0 imm5) + (extract-fulltag tag header) + (cmpwi cr0 tag ppc32::fulltag-immheader) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la obj ppc32::fulltag-cons imm5) + (cmpw cr0 obj sentinel) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (beq cr0 @done) + (bla .SPfuncall) + (la imm5 (- ppc32::cons.size ppc32::fulltag-cons) obj) + (b @loop) + @misc + (la obj ppc32::fulltag-misc imm5) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (getvheader header obj) + (extract-fulltag tag header) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (cmpwi cr7 tag ppc32::fulltag-immheader) + (clrlwi subtag header (- 32 ppc32::num-subtag-bits)) + (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag) + (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag) + (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag) + (cmpwi cr5 subtag ppc32::subtag-double-float-vector) + (header-size elements header) + (slwi bytes elements 2) + (beq cr1 @bump) + (if (:cr7 :ne) + (twle 0 0)) + (ble cr2 @bump) + (mr bytes elements) + (ble cr3 @bump) + (slwi bytes elements 1) + (ble cr4 @bump) + (slwi bytes elements 3) + (beq cr5 @bump) + (la elements 7 elements) + (srwi bytes elements 3) + @bump + (la bytes (+ 4 7) bytes) + (clrrwi bytes bytes 3) + (subi imm5 obj ppc32::fulltag-misc) + (add imm5 imm5 bytes) + (cmpw cr0 imm5 sentinel) + (blt cr0 @loop) + (uuo_interr 0 0) + (b @loop) + @done + (li arg_z nil) + (vpop sentinel) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +#+ppc64-target +(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (sentinel save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm4)) + (save-lisp-context) + (:regsave sentinel 0) + (vpush fun) + (vpush obj) + (vpush sentinel) + (ref-global imm0 tenured-area) + (cmpdi cr0 imm0 0) + (lwi allocbase #x8000) + (sldi allocbase allocbase 32) + (subi allocbase allocbase 16) + (la allocptr (- ppc64::fulltag-cons ppc64::cons.size) allocptr) + (tdlt allocptr allocbase) + (mr sentinel allocptr) + (clrrdi allocptr allocptr ppc64::ntagbits) + (mr fun f) + (if :ne + (mr a imm0)) + (ld imm5 ppc64::area.low a) + @loop + (ld header 0 imm5) + (extract-lowtag tag header) + (cmpdi cr0 tag ppc64::lowtag-immheader) + (cmpdi cr1 tag ppc64::lowtag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la obj ppc64::fulltag-cons imm5) + (cmpd cr0 obj sentinel) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (beq cr0 @done) + (bla .SPfuncall) + (la imm5 (- ppc64::cons.size ppc64::fulltag-cons) obj) + (b @loop) + @misc + (la obj ppc64::fulltag-misc imm5) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (getvheader header obj) + (extract-lowtag tag header) + (extract-fulltag subtag header) + (cmpdi cr1 tag ppc64::lowtag-nodeheader) + (extract-lowbyte tag header) + (cmpri cr2 subtag ppc64::ivector-class-64-bit) + (cmpri cr3 subtag ppc64::ivector-class-8-bit) + (cmpri cr4 subtag ppc64::ivector-class-32-bit) + (cmpri cr5 tag ppc64::subtag-bit-vector) + (header-size elements header) + (sldi bytes elements 3) + (beq cr1 @bump) + (beq cr2 @bump) + (mr bytes elements) + (beq cr3 @bump) + (sldi bytes elements 2) + (beq cr4 @bump) + (sldi bytes elements 1) + (bne cr5 @bump) + (la elements 7 elements) + (srdi bytes elements 3) + @bump + (la bytes (+ 8 15) bytes) + (clrrdi bytes bytes 4) + (subi imm5 obj ppc64::fulltag-misc) + (add imm5 imm5 bytes) + (b @loop) + @done + (li arg_z nil) + (vpop sentinel) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +(defun walk-dynamic-area (area func) + (with-other-threads-suspended + (%walk-dynamic-area area func))) + + + +(defppclapfunction %class-of-instance ((i arg_z)) + (svref arg_z instance.class-wrapper i) + (svref arg_z %wrapper-class arg_z) + (blr)) + +(defppclapfunction class-of ((x arg_z)) + (check-nargs 1) + (extract-fulltag imm0 x) + (cmpri imm0 target::fulltag-misc) + (beq @misc) + (extract-lowbyte imm0 x) + (b @done) + @misc + (extract-subtag imm0 x) + @done + (slri imm0 imm0 target::word-shift) + (ldr temp1 '*class-table* nfn) + (addi imm0 imm0 target::misc-data-offset) + (ldr temp1 target::symbol.vcell temp1) + (ldrx temp0 temp1 imm0) ; get entry from table + (cmpri cr0 temp0 nil) + (beq @bad) + ;; functionp? + (extract-typecode imm1 temp0) + (cmpri imm1 target::subtag-function) + (bne @ret) ; not function - return entry + ;; else jump to the fn + (mr nfn temp0) + (ldr temp0 target::misc-data-offset temp0) + (SET-NARGS 1) + (mtctr temp0) + (bctr) + @bad + (ldr fname 'no-class-error nfn) + (ba .spjmpsym) + @ret + (mr arg_z temp0) ; return frob from table + (blr)) + +(defppclapfunction full-gccount () + (ref-global arg_z tenured-area) + (cmpri cr0 arg_z 0) + (if :eq + (ref-global arg_z gc-count) + (ldr arg_z target::area.gc-count arg_z)) + (blr)) + + +(defppclapfunction gc () + (check-nargs 0) + (li imm0 arch::gc-trap-function-gc) + (trlgei allocptr 0) + (li arg_z target::nil-value) + (blr)) + + +(defppclapfunction 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) + (subi imm1 arg nil) + (li imm0 arch::gc-trap-function-egc-control) + (trlgei allocptr 0) + (blr)) + + + +(defppclapfunction %configure-egc ((e0size arg_x) + (e1size arg_y) + (e2size arg_z)) + (check-nargs 3) + (li imm0 arch::gc-trap-function-configure-egc) + (trlgei allocptr 0) + (blr)) + +(defppclapfunction purify () + (li imm0 arch::gc-trap-function-purify) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + + +(defppclapfunction impurify () + (li imm0 arch::gc-trap-function-impurify) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + +(defppclapfunction 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) + (li imm0 arch::gc-trap-function-get-lisp-heap-threshold) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + +(defppclapfunction 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) + (mflr loc-pc) + #+ppc32-target + (bla .SPgetu32) + #+ppc64-target + (bla .SPgetu64) + (mtlr loc-pc) + (mr imm1 imm0) + (li imm0 arch::gc-trap-function-set-lisp-heap-threshold) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + + +(defppclapfunction 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) + (li imm0 arch::gc-trap-function-use-lisp-heap-threshold) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + + + + + + +;;; offset is a fixnum, one of the target::kernel-import-xxx constants. +;;; Returns that kernel import, a fixnum. +(defppclapfunction %kernel-import ((offset arg_z)) + (ref-global imm0 kernel-imports) + (unbox-fixnum imm1 arg_z) + (ldrx arg_z imm0 imm1) + (blr)) + +(defppclapfunction %get-unboxed-ptr ((macptr arg_z)) + (macptr-ptr imm0 arg_z) + (ldr arg_z 0 imm0) + (blr)) + + +(defppclapfunction %revive-macptr ((p arg_z)) + (li imm0 target::subtag-macptr) + (stb imm0 target::misc-subtag-offset p) + (blr)) + +(defppclapfunction %macptr-type ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p target::subtag-macptr) + (svref imm0 target::macptr.type-cell p) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %macptr-domain ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p target::subtag-macptr) + (svref imm0 target::macptr.domain-cell p) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %set-macptr-type ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum imm1 new) + (trap-unless-typecode= p target::subtag-macptr) + (svset imm1 target::macptr.type-cell p) + (blr)) + +(defppclapfunction %set-macptr-domain ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum imm1 new) + (trap-unless-typecode= p target::subtag-macptr) + (svset imm1 target::macptr.domain-cell p) + (blr)) + +(defppclapfunction true () + (cmplri nargs '3) + (li arg_z t) + (blelr) + (subi imm0 nargs '3) + (add vsp vsp imm0) + (blr)) + +(defppclapfunction false () + (cmplri nargs '3) + (li arg_z nil) + (blelr) + (subi imm0 nargs '3) + (add vsp vsp imm0) + (blr)) + +(lfun-bits #'true #.(encode-lambda-list '(&lap &rest ignore))) +(lfun-bits #'false #.(encode-lambda-list '(&lap &rest ignore))) + +;;; end Index: /branches/experimentation/later/source/level-0/X86/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-0/X86/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/experimentation/later/source/level-0/X86/X8664/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-0/X86/X8664/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/X8664/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/experimentation/later/source/level-0/X86/X8664/x8664-bignum.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/X8664/x8664-bignum.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/X8664/x8664-bignum.lisp (revision 8058) @@ -0,0 +1,282 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 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. +;;; We only have two immediate registers, and -have- to use them +;;; to represent hi:low. Keep the unboxed divisor in the high +;;; word of a fixnum on the top of the stack. (That's probably +;;; slower than using %rbp, but clobbering %rbp confuses backtrace). +;;; For x8632, we'll probably have to mark something (%ecx ?) as +;;; being "temporarily unboxed" by mucking with some bits in the +;;; TCR. +(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)) + (unbox-fixnum divisor imm0) + (pushq ($ 0)) + (movl (%l imm0) (@ 4 (% rsp))) + (unbox-fixnum num-high unboxed-high) + (unbox-fixnum num-low unboxed-low) + (divl (@ 4 (% rsp))) + (addq ($ 8) (% rsp)) + (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))) + + + Index: /branches/experimentation/later/source/level-0/X86/x86-array.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-array.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-array.lisp (revision 8058) @@ -0,0 +1,398 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + #+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 '(unsigned-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 + (if (eql 0 val) + uvector + (let* ((v0 (case val + (1 -1) + (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))) + + + +(defx86lapfunction %boole-clr ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq ($ 0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-set ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq ($ -1) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-c1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-c2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-and ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-ior ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-xor ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) +n (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (xorq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-eqv ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (xorq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-nand ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-nor ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-andc1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (notq (% imm0)) + (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-andc2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (andq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-orc1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (notq (% imm0)) + (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-orc2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (orq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (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) + (let* ((f (svref *simple-bit-boole-functions* op))) + (dotimes (i (ash (the fixnum (+ (length result) 63)) -6) result) + (funcall f i b1 b2 result)))) + +(defx86lapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z)) + (check-nargs 3) + (jmp-subprim .SParef2)) + +(defx86lapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z)) + (check-nargs 4) + (pop (% temp0)) + (discard-reserved-frame) + (jmp-subprim .SParef3)) + +(defx86lapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z)) + (check-nargs 4) + (pop (% temp0)) + (discard-reserved-frame) + (jmp-subprim .SPaset2)) + +(defx86lapfunction %aset3 ((array 8) (i 0) (j arg_x) (k arg_y) (newval arg_z)) + (check-nargs 5) + (pop (% temp0)) + (pop (% temp1)) + (discard-reserved-frame) + (jmp-subprim .SPaset3)) + + + + + + + Index: /branches/experimentation/later/source/level-0/X86/x86-clos.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-clos.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-clos.lisp (revision 8058) @@ -0,0 +1,272 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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'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-std-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-std-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 ($ x8664::word-shift) (% 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) + (movzwl (% nargs) (%l nargs)) + (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 (@ (+ x8664::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 ($ x8664::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) + (movzwl (% nargs) (%l nargs)) + (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 (@ (+ x8664::nil-value (x8664::%kernel-global 'lexpr-return)))) + (movq (% imm0) (% ra0)) + @call + (push (% ra0)) + (movq (@ 'thing (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))))))) + + + + Index: /branches/experimentation/later/source/level-0/X86/x86-def.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-def.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-def.lisp (revision 8058) @@ -0,0 +1,686 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(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 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) + (cmpw ($ 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) + (cmpw ($ 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) + (cmpw ($ '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) + (cmpw ($ '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 ($ x8664::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 ($ x8664::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 ($ x8664::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 + (movw (% imm0.w) (% nargs)) + (leaq (@ x8664::node-size (% arg_z) (% imm0)) (% imm1)) + (subw ($ '3) (% imm0.w)) + (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 + (testw (% nargs) (% nargs)) + (je @go) + (rcmpw (% 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 + (addw (% imm0.w) (% nargs)) + (jne @pop) + @discard-and-go + (discard-reserved-frame) + (jmp @go) + @pop + (cmpw ($ '1) (% nargs)) + (pop (% arg_z)) + (je @discard-and-go) + (cmpw ($ '2) (% nargs)) + (pop (% arg_y)) + (je @discard-and-go) + (cmpw ($ '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)) + (rcmpw (% 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) + (rcmpw (% 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) + (cmpw ($ '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 + (subw ($ '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. + (addw (%w imm0) (% nargs)) + (movq (% temp0) (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (addw ($ '1) (% nargs)) + (cmpw ($ '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)) + + +(defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0)) + (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)) + (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)))) + (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))))))) + (%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 Index: /branches/experimentation/later/source/level-0/X86/x86-float.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-float.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-float.lisp (revision 8058) @@ -0,0 +1,457 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + + +;;; 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 ($ x8664::t-value) (% imm0.l)) + (movl ($ x8664::nil-value) (% arg_z.l)) + (cmovlq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %short-float-sign ((n arg_z)) + (testq (% n) (% n)) + (movl ($ x8664::t-value) (% imm0.l)) + (movl ($ x8664::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 Index: /branches/experimentation/later/source/level-0/X86/x86-hash.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-hash.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-hash.lisp (revision 8058) @@ -0,0 +1,103 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + +(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)) + + +(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)) + +;;; 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 Index: /branches/experimentation/later/source/level-0/X86/x86-io.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-io.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-io.lisp (revision 8058) @@ -0,0 +1,31 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + +(defx86lapfunction %get-errno () + (movq (@ (% :rcontext) x8664::tcr.errno-loc) (% imm1)) + (movslq (@ (% imm1)) (% imm0)) + (movss (% fp0) (@ (% imm1))) + (negq (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +; end Index: /branches/experimentation/later/source/level-0/X86/x86-misc.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-misc.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-misc.lisp (revision 8058) @@ -0,0 +1,764 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + +;;; 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))) + + + +(defx86lapfunction %copy-ivector-to-ivector ((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 (% src-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 ptr) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% ptr) (% 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 ptr) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% ptr) (% 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 ($ x8664::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 ($ x8664::t-value) (%l arg_z)) + (single-value-return 3) + @lose + (movl ($ x8664::nil-value) (%l arg_z)) + (single-value-return 3)) + +(defx86lapfunction set-%gcable-macptrs% ((ptr x8664::arg_z)) + @again + (movq (@ (+ x8664::nil-value (x8664::kernel-global gcable-pointers))) + (% rax)) + (movq (% rax) (@ x8664::xmacptr.link (% ptr))) + (lock) + (cmpxchgq (% ptr) (@ (+ x8664::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 (@ (+ x8664::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) (@ (+ x8664::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 (@ (+ x8664::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) (@ (+ x8664::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 ptr) + @again + (movq (@ (% ptr)) (% rax)) + (lea (@ 1 (% rax)) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% ptr))) + (jne @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + +(defx86lapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (macptr-ptr ptr ptr) + @again + (movq (@ (% ptr)) (% rax)) + (unbox-fixnum by imm1) + (add (% rax) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% ptr))) + (jnz @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + + +(defx86lapfunction %atomic-decf-ptr ((ptr arg_z)) + (macptr-ptr ptr ptr) + @again + (movq (@ (% ptr)) (% rax)) + (lea (@ -1 (% rax)) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% ptr))) + (jnz @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + +(defx86lapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (macptr-ptr ptr ptr) ;must be fixnum-aligned + @again + (movq (@ (% ptr)) (% rax)) + (testq (% rax) (% rax)) + (lea (@ -1 (% rax)) (% imm1)) + (jz @done) + (lock) + (cmpxchgq (% imm1) (@ (% ptr))) + (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 ptr) ; must be fixnum-aligned + @again + (movq (@ (% ptr)) (% imm0)) + (box-fixnum imm0 temp0) + (cmpq (% temp0) (% expected-oldval)) + (jne @done) + (unbox-fixnum newval imm1) + (lock) + (cmpxchgq (% imm1) (@ (% ptr))) + (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 arg_y) ; had better be aligned + (lock) ; implicit ? + (xchgl (% imm0.l) (@ (% arg_y))) + (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)) + +#+are-you-kidding +(defx86lapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0) + (parent arg_x) (function arg_y) (arglist arg_z)) + (check-nargs 7) + + ; Throw through catch-count catch frames + (lwz imm0 12 vsp) ; catch-count + (vpush parent) + (vpush function) + (vpush arglist) + (bla .SPnthrowvalues) + + ; Pop tsp-count TSP frames + (lwz tsp-count 16 vsp) + (cmpi cr0 tsp-count 0) + (b @test) +@loop + (subi tsp-count tsp-count '1) + (cmpi cr0 tsp-count 0) + (lwz tsp 0 tsp) +@test + (bne cr0 @loop) + + ; Pop dynamic bindings until we get to db-link + (lwz imm0 12 vsp) ; db-link + (lwz imm1 x8664::tcr.db-link :rcontext) + (cmp cr0 imm0 imm1) + (beq cr0 @restore-regs) ; .SPunbind-to expects there to be something to do + (bla .SPunbind-to) + +@restore-regs + ; restore the saved registers from srv + (lwz srv 20 vsp) +@get0 + (svref imm0 1 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get1) + (lwz save0 0 imm0) +@get1 + (svref imm0 2 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get2) + (lwz save1 0 imm0) +@get2 + (svref imm0 3 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get3) + (lwz save2 0 imm0) +@get3 + (svref imm0 4 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get4) + (lwz save3 0 imm0) +@get4 + (svref imm0 5 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get5) + (lwz save4 0 imm0) +@get5 + (svref imm0 6 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get6) + (lwz save5 0 imm0) +@get6 + (svref imm0 7 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @get7) + (lwz save6 0 imm0) +@get7 + (svref imm0 8 srv) + (cmpwi cr0 imm0 x8664::nil-value) + (beq @got) + (lwz save7 0 imm0) +@got + + (vpop arg_z) ; arglist + (vpop temp0) ; function + (vpop parent) ; parent + (extract-lisptag imm0 parent) + (cmpi cr0 imm0 x8664::tag-fixnum) + (if (:cr0 :ne) + ; Parent is a fake-stack-frame. Make it real + (progn + (svref sp %fake-stack-frame.sp parent) + (stwu sp (- x8664::lisp-frame.size) sp) + (svref fn %fake-stack-frame.fn parent) + (stw fn x8664::lisp-frame.savefn sp) + (svref temp1 %fake-stack-frame.vsp parent) + (stw temp1 x8664::lisp-frame.savevsp sp) + (svref temp1 %fake-stack-frame.lr parent) + (extract-lisptag imm0 temp1) + (cmpi cr0 imm0 x8664::tag-fixnum) + (if (:cr0 :ne) + ;; must be a macptr encoding the actual link register + (macptr-ptr loc-pc temp1) + ;; Fixnum is offset from start of function vector + (progn + (svref temp2 0 fn) ; function vector + (unbox-fixnum temp1 temp1) + (add loc-pc temp2 temp1))) + (stw loc-pc x8664::lisp-frame.savelr sp)) + ;; Parent is a real stack frame + (mr sp parent)) + (set-nargs 0) + (bla .SPspreadargz) + (ba .SPtfuncallgen)) + + + + +(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)) + (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 break-event-pending-p () + (xorq (% imm0) (% imm0)) + (ref-global x8664::intflag imm1) + (set-global imm0 x8664::intflag) + (testq (% imm1) (% imm1)) + (setne (%b imm0)) + (andl ($ x8664::t-offset) (%l imm0)) + (lea (@ x8664::nil-value (% imm0)) (% arg_z)) + (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 ($ x8664::nil-value) (% arg_z.l)) + (jae @done) + (ud2a) + (:byte 3) + (movl ($ x8664::t-value) (% arg_z.l)) + @done + (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)) + + +;;; end of x86-misc.lisp Index: /branches/experimentation/later/source/level-0/X86/x86-numbers.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-numbers.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-numbers.lisp (revision 8058) @@ -0,0 +1,189 @@ +;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + + + +(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)) + (unbox-fixnum divisor imm0) + (movq (% imm0) (@ -8 (% rsp))) + (unbox-fixnum dividend imm0) + (cqto) ; imm1 := sign_extend(imm0) + (idivq (@ -8 (% rsp))) + (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)) + +(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))) + + + +;;; End of x86-numbers.lisp Index: /branches/experimentation/later/source/level-0/X86/x86-pred.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-pred.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-pred.lisp (revision 8058) @@ -0,0 +1,187 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "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 ($ x8664::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)) + + + + + + + + + + Index: /branches/experimentation/later/source/level-0/X86/x86-symbol.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-symbol.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-symbol.lisp (revision 8058) @@ -0,0 +1,162 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "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 ($ (+ x8664::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 ($ (+ x8664::nil-value x8664::nilsym-offset)) (% tag)) + (cmp-reg-to-nil sym) + (cmoveq (% sym) (% tag)) + (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 ($ (+ x8664::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)) + (cmpq ($ 0) (% len)) + (jz.pn @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)) + (cmpq ($ 0) (% len)) + (jz.pn @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))) Index: /branches/experimentation/later/source/level-0/X86/x86-utils.lisp =================================================================== --- /branches/experimentation/later/source/level-0/X86/x86-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/X86/x86-utils.lisp (revision 8058) @@ -0,0 +1,520 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +(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 (@ x8664::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) + (prev save3)) + (save-simple-frame) + (push (% fun)) + (push (% obj)) + (push (% limit)) + (push (% prev)) + (xorl (%l prev) (%l prev)) + (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) (% prev)) + (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) (% prev)) + (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 (% prev)) + (pop (% limit)) + (pop (% obj)) + (pop (% fun)) + (movl ($ x8664::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) + (prev save3)) + (save-simple-frame) + (push (% fun)) + (push (% obj)) + (push (% limit)) + (push (% prev)) + (movq (% f) (% fun)) + (xorl (%l prev) (%l prev)) + (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)) + (jg @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)) + (movq (% obj) (% prev)) + (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) + (movq (% obj) (% prev)) + (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 (% prev)) + (pop (% limit)) + (pop (% obj)) + (pop (% fun)) + (movl ($ x8664::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 (@ (+ x8664::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 ($ x8664::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." + (movq ($ arch::gc-trap-function-freeze) (% imm0)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu64)) + + + + + +;;; 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 () + (movzwl (% nargs) (%l nargs)) + (subq ($ '3) (% nargs.q)) + (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0)) + (cmovaq (% imm0) (% rsp)) + (movl ($ x8664::t-value) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction false () + (movzwl (% nargs) (%l nargs)) + (subq ($ '3) (% nargs.q)) + (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0)) + (cmovaq (% imm0) (% rsp)) + (movl ($ x8664::nil) (%l arg_z)) + (single-value-return)) + + + +;;; end Index: /branches/experimentation/later/source/level-0/l0-aprims.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-aprims.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-aprims.lisp (revision 8058) @@ -0,0 +1,217 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 (&optional name) + "Create and return a lock object, which can be used for synchronization +between threads." + (gvector :lock (%make-recursive-lock-ptr) 'recursive-lock 0 name nil nil)) + +(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) + (format nil "Lock ~s 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) + (format nil "Read lock ~s 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) + (format nil "Read lock ~s 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)) + (do* ((result '() (cons initial-element result))) + ((zerop size) result) + (decf size)))) + +; end Index: /branches/experimentation/later/source/level-0/l0-array.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-array.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-array.lisp (revision 8058) @@ -0,0 +1,808 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-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." + (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))) + + +; 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)) + +#+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))) + #+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) + (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) + (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 8) (*)) 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))) + +#+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)))) + (t target::subtag-simple-vector))) + +(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/experimentation/later/source/level-0/l0-bignum32.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-bignum32.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-bignum32.lisp (revision 8058) @@ -0,0 +1,2134 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + + + +;;; 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)) + (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 len-q)) + (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 len-q)) + (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 (ignore len)) + ;(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 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 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/experimentation/later/source/level-0/l0-bignum64.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-bignum64.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-bignum64.lisp (revision 8058) @@ -0,0 +1,2111 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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. +(eval-when (:compile-toplevel :execute) + (declaim (inline bignum-ref bignum-set))) + +(defun bignum-ref (b i) + (%typed-miscref :bignum b i)) + +(defun bignum-set (b i val) + (declare (fixnum val)) + (%typed-miscset :bignum b i (logand val all-ones-digit))) + + +(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 (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)) + (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) + (multiple-value-bind (result-digit carry-out) + (%add-with-carry (bignum-ref a i) (bignum-ref b i) carry) + (setf (bignum-ref res i) result-digit + carry carry-out))) + (if (/= len-a len-b) + (finish-bignum-add res carry a sign-b len-b len-a) + (setf (bignum-ref res len-a) + (%add-with-carry (%bignum-sign a) sign-b carry))) + (%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)) + (do* ((i start (1+ i))) + ((= i end) + (setf (bignum-ref result end) + (%add-with-carry (%sign-digit a end) sign-b carry))) + (multiple-value-bind (result-digit carry-out) + (%add-with-carry (bignum-ref a i) sign-b carry) + (setf (bignum-ref result i) result-digit + carry carry-out)))) + + + +;;;; 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 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)) + (let* ((carry-digit 0) + (x (bignum-ref a i)) + (k i)) + (declare (fixnum k)) + (dotimes (j len-b) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + (bignum-ref b j) + (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* ((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)) + (with-small-bignum-buffers ((big-fix fixnum)) + (multiply-bignums bignum big-fix))) + + +;; 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)) + (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)) + (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)) + (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) + (setf (bignum-ref res i) + (logand (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (%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) + (setf (bignum-ref res i) + (logand (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (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) + (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)) + (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) + (setf (bignum-ref res i) + (logior (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (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) + (setf (bignum-ref res i) + (logior (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) #xffffffff)) + (%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) + (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) (%next-random-seed state))) + (setf (bignum-ref bignum sign-index) + (logand #x7fffffff (the (unsigned-byte 32) + (%next-random-seed 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/experimentation/later/source/level-0/l0-cfm-support.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-cfm-support.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-cfm-support.lisp (revision 8058) @@ -0,0 +1,770 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + + + + + + + + +;;; 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."))) + + + +(def-accessor-macros %svref + nil ; 'external-entry-point + eep.address + eep.name + eep.container) + +(defun %cons-external-entry-point (name &optional container) + (%istruct 'external-entry-point nil name container)) + +(defun external-entry-point-p (x) + (istruct-typep x 'external-entry-point)) + +(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 + ) + +(defun %cons-foreign-variable (name type &optional container) + (%istruct 'foreign-variable nil name type container)) + +(def-accessor-macros %svref + nil ;'shlib + shlib.soname + shlib.pathname + shlib.opened-by-lisp-kernel + shlib.map + shlib.base + shlib.opencount) + +(defun %cons-shlib (soname pathname map base) + (%istruct 'shlib soname pathname nil map base 0)) + +(defvar *rtld-next*) +(defvar *rtld-default*) +(setq *rtld-next* (%incf-ptr (%null-ptr) -1) + *rtld-default* (%int-to-ptr #+(or linux-target darwin-target) 0 + #-(or linux-target darwin-target) -2)) + +#+(or linux-target freebsd-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) +(progn + +(defun soname-ptr-from-link-map (map) + (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))) + #+freebsd-target + (%inc-ptr (pref map :link_map.l_addr) disp) + #-freebsd-target + (%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) + (dolist (l *shared-libraries*) + ;;; 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 + (%dlopen-shlib l) + (setf (shlib.opened-by-lisp-kernel l) t)))) + +(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* ((link-map + (let* ((lib (with-cstrs ((name name)) + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address name + :unsigned-fullword *dlopen-flags* + :address)))) + #+linux-target lib + #+freebsd-target (if (%null-ptr-p lib) + lib + (rlet ((p :address)) + (if (eql 0 (ff-call + (foreign-symbol-entry "dlinfo") + :address lib + :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)) + 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 +) + + +(defun ensure-open-shlib (c force) + (if (or (shlib.map c) (not force)) + *rtld-default* + (error "Shared library not open: ~s" (shlib.soname c)))) + +(defun resolve-container (c force) + (if c + (ensure-open-shlib c force) + *rtld-default* + )) + + + + +;;; 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-default*)) + "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)))) + #+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) +(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) + (%setf-macptr-to-object p entry) + (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*) + +(defun setup-lookup-calls () + (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 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-entry (entry &optional name) + (when (not name) + (error "shared library name must be non-NIL.")) + (with-macptrs (addr) + (%setf-macptr-to-object addr entry) + (shlib-containing-address addr name))) + +;; end Darwin progn +) + +#-(or linux-target darwin-target freebsd-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-default*)) + "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) +(progn +;;; 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))) + (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 (%cstrcmp soname libname) + (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.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))) + (unless map + (with-cstrs ((soname (shlib.soname lib))) + (setq map (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address soname + :unsigned-fullword *dlopen-flags* + :address)) + (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 + 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) + (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)) + (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/experimentation/later/source/level-0/l0-complex.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-complex.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-complex.lisp (revision 8058) @@ -0,0 +1,33 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-0/l0-def.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-def.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-def.lisp (revision 8058) @@ -0,0 +1,260 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 '%traced-p ;Redefined in encapsulate - used in l1-io + (qlfun bootstrapping-%traced-p (fn) + (declare (ignore fn)) + nil)) + +(%fhave '%advised-p ;Redefined in encapsulate used in l1-io + (qlfun bootstrapping-%advised-p (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/experimentation/later/source/level-0/l0-error.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-error.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-error.lisp (revision 8058) @@ -0,0 +1,140 @@ +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 . "Cant find tag ~S") + (29 . "Duplicate tag ~S") + (30 . "Cant 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/experimentation/later/source/level-0/l0-float.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-float.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-float.lisp (revision 8058) @@ -0,0 +1,1059 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) + (%copy-double-float n val) + (%%scale-dfloat! n (+ 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 2046) + (error "Can't decode NAN or infinity ~s" n) + (let ((val (%make-dfloat))) + (%copy-double-float 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))) + (%copy-short-float n val) + (%%scale-sfloat! n (+ 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 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))) + (%copy-short-float 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 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 "Ilegal 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/experimentation/later/source/level-0/l0-hash.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-hash.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-hash.lisp (revision 8058) @@ -0,0 +1,1785 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;;;;;;;;;;; +;; +;; 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 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 or deleted slots are +;; denoted by a key of $undefined. Empty slots have a value of $undefined. +;; Deleted slots have a value of NIL. +;; +;; +;; Five 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 32 bits of the fixnum at nhash.vector.flags look like: +;; +;; TK0C0000 00000000 WVF00000 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 + + + + + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv") + (require :number-case-macro) + (define-symbol-macro free-hash-key-marker (%unbound-marker)) + (define-symbol-macro deleted-hash-key-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))) + + + +(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+)) + + +(defun %cons-hash-table (rehash-function keytrans-function compare-function vector + threshold rehash-ratio rehash-size address-based find find-new owner) + (%istruct + 'HASH-TABLE ; type + rehash-function ; nhash.rehashF + keytrans-function ; nhash.keytransF + compare-function ; nhash.compareF + nil ; nhash.rehash-bits + vector ; nhash.vector + 0 ; nhash.lock + 0 ; nhash.count + owner ; nhash.owner + (get-fwdnum) ; nhash.fixnum + (gc-count) ; nhash.gc-count + threshold ; nhash.grow-threshold + rehash-ratio ; nhash.rehash-ratio + rehash-size ; nhash.rehash-size + 0 ; nhash.puthash-count + (unless owner + (make-read-write-lock)) ; nhash.exclusion-lock + nil ;;(make-lock) ; nhash.rehash-lock + nil ; nhash.iterator + address-based ; nhash.address-based + find ; nhash.find + find-new ; nhash.find-new + nil ; hhash.read-only + )) + + + +(defun nhash.vector-size (vector) + (ash (the fixnum (- (the fixnum (uvsize vector)) $nhash.vector_overhead)) -1)) + +;;; 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) + #+ppc32-target + (and (>= typecode ppc32::min-numeric-subtag) + (<= typecode ppc32::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 (hash) + (let ((flags (nhash.vector.flags (nhash.vector hash)))) + (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 (gc-count)) (the fixnum (nhash.gc-count hash)))))))) + +(defun %set-does-not-need-rehashing (hash) + (get-fwdnum hash) + (gc-count hash) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (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) + (setf (nhash.fixnum hash) (the fixnum (1- (the fixnum (get-fwdnum)))) + (nhash.gc-count hash) (the fixnum (1- (the fixnum (gc-count))))) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (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) + + +;;; 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 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 addressp + (when update-hash-flags + (let ((flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (eq :key addressp) + ;; hash code depended on key's address + (unless (logbitp $nhash_component_address_bit flags) + (when (not (logbitp $nhash_track_keys_bit flags)) + (setq flags (bitclr $nhash_key_moved_bit flags))) + (setq flags (logior $nhash-track-keys-mask flags))) + ;; hash code depended on component address + (progn + (setq flags (logand (lognot $nhash-track-keys-mask) flags)) + (setq flags (bitset $nhash_component_address_bit flags)))) + (setf (nhash.vector.flags vector) flags)))) + (let* ((length (- (the fixnum (uvsize vector)) $nhash.vector_overhead)) + (entries (ash length -1))) + (declare (fixnum length entries)) + (values primary + (fast-mod primary entries) + 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) + (let ((deleted-count (the fixnum + (+ (the fixnum (nhash.vector.deleted-count vector)) + weak-deletions-count))) + (count (the fixnum (- (the fixnum (nhash.count hash)) weak-deletions-count)))) + (setf (nhash.vector.deleted-count vector) deleted-count + (nhash.count hash) count))))) + + +(defparameter *shared-hash-table-default* t + "Be sure that you understand the implications of changing this +before doing so.") + +(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) + (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." + (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.")) + (multiple-value-bind (size total-size) + (compute-hash-size (1- size) 1 rehash-threshold) + (let* ((flags (if weak + (+ (+ + (ash 1 $nhash_weak_bit) + (ecase weak + ((t :key) 0) + (:value (ash 1 $nhash_weak_value_bit)))) + (if finalizeable (ash 1 $nhash_finalizeable_bit) 0)) + 0)) + (hash (%cons-hash-table + #'%no-rehash hash-function test + (%cons-nhash-vector total-size flags) + size rehash-threshold rehash-size address-based + find-function find-put-function + (unless shared *current-process*)))) + (setf (nhash.vector.hash (nhash.vector hash)) hash) + hash)))) + +(defun compute-hash-size (size rehash-size rehash-ratio) + (let* ((new-size size)) + (setq new-size (max 30 (if (fixnump rehash-size) + (+ size rehash-size) + (ceiling (* size rehash-size))))) + (if (<= new-size size) + (setq new-size (1+ size))) ; God save you if you make this happen + + (values new-size + (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio))))))) + +;;; 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* nil) + +(defun signal-read-only-hash-table-error (hash) + (cond (*continue-from-readonly-hashtable-lock-error* + (cerror "Make the hash-table writable. DANGEROUS! 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))))) + + +;;; 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 (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (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) (%unbound-marker)) + (incf index)) + (incf (the fixnum (nhash.grow-threshold hash)) + (the fixnum (+ (the fixnum (nhash.count hash)) + (the fixnum (nhash.vector.deleted-count vector))))) + (setf (nhash.count hash) 0 + (nhash.vector.cache-key vector) (%unbound-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 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." + (require-type hash 'hash-table) + (%normalize-hash-table-count hash) + (the fixnum (nhash.count 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." + (%i+ (the fixnum (hash-table-count hash)) + (the fixnum (nhash.grow-threshold hash)) + (the fixnum (nhash.vector.deleted-count (nhash.vector 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))) + +;; Finalization-list accessors are in "ccl:lib;hash" because SETF functions +;; don't get dumped as "simple" %defuns. +;; + + + +(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 (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (let* ((value nil) + (vector-key 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)) + ;; 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 (the fixnum (1+ vector-index))) + vector-key (%svref vector vector-index)) + (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker)) + (not (eq vector-key deleted-hash-key-marker)))) + #+no + (setf (nhash.vector.cache-key vector) vector-key + (nhash.vector.cache-value vector) value + (nhash.vector.cache-idx vector) (vector-index->index + vector-index)) + (return)) + ((%needs-rehashing-p hash) + (%lock-gc-lock) + (setq gc-locked t) + (unless readonly + (let* ((lock (nhash.exclusion-lock hash))) + (when lock (%promote-rwlock lock)))) + (when (%needs-rehashing-p hash) + (%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 (hash-table-p hash) + (setq hash (require-type hash 'hash-table))) + (let* ((foundp nil)) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (%lock-gc-lock) + (when (%needs-rehashing-p hash) + (%rehash hash)) + (let* ((vector (nhash.vector hash))) + (if (eq key (nhash.vector.cache-key vector)) + (progn + (setf (nhash.vector.cache-key vector) free-hash-key-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.count hash))) + (setq foundp t)) + (let* ((vector-index (funcall (nhash.find hash) hash key)) + (vector-key (%svref vector vector-index))) + (declare (fixnum vector-index)) + (when (setq foundp (and (not (eq vector-key free-hash-key-marker)) + (not (eq vector-key deleted-hash-key-marker)))) + ;; 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-key-marker + (nhash.vector.cache-value vector) nil) + ;; Update the count + (incf (the fixnum (nhash.vector.deleted-count vector))) + (decf (the fixnum (nhash.count hash))) + ;; Remove a cons from the free-alist if the table is finalizeable + (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector)) + (pop (the list (svref nhash.vector.free-alist vector)))) + ;; Delete the value from the table. + (setf (%svref vector vector-index) deleted-hash-key-marker + (%svref vector (the fixnum (1+ vector-index))) nil)))) + (when (and foundp + (zerop (the fixnum (nhash.count hash)))) + (do* ((i $nhash.vector_overhead (1+ i)) + (n (uvsize vector))) + ((= i n)) + (declare (fixnum i n)) + (setf (%svref vector i) free-hash-key-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)) + +(defun puthash (key hash default &optional (value default)) + (declare (optimize (speed 3) (space 0))) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (with-lock-context + (without-interrupts + (block protected + (tagbody + (write-lock-hash-table hash) + AGAIN + (%lock-gc-lock) + (when (%needs-rehashing-p hash) + (%rehash hash)) + (let ((vector (nhash.vector 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) + (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash))))) + ;; Adjust deleted-count + (when (> 0 (the fixnum + (decf (the fixnum + (nhash.vector.deleted-count vector))))) + (let ((weak-deletions (nhash.vector.weak-deletions-count vector))) + (declare (fixnum weak-deletions)) + (setf (nhash.vector.weak-deletions-count vector) 0) + (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions) + (decf (the fixnum (nhash.count hash)) weak-deletions)))) + ((eq old-value free-hash-key-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.count hash)))) + (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) + (let* ((vector (nhash.vector hash)) + (size (uvsize vector)) + (idx $nhash.vector_overhead) + (count 0)) + (loop + (when (neq (%svref vector idx) (%unbound-marker)) + (incf count)) + (when (>= (setq idx (+ idx 2)) size) + (return count))))) + + + + + + + +(defun grow-hash-table (hash) + (unless (hash-table-p hash) + (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.count hash)) + (old-total-size (nhash.vector-size old-vector)) + (flags 0) + (flags-sans-weak 0) + (weak-flags) + rehashF) + (declare (fixnum old-total-size flags flags-sans-weak weak-flags)) + ; well we knew lock was 0 when we called this - is it still 0? + (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 ((fwdnum (get-fwdnum)) + (gc-count (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) + rehashF (nhash.rehashF hash)) + (setf (nhash.lock hash) (%ilogior (nhash.lock hash) $nhash.lock-while-growing) ; dont need + (nhash.rehashF hash) #'%am-growing + (nhash.vector.flags old-vector) flags-sans-weak) ; disable GC weak stuff + (%normalize-hash-table-count 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-key-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.flags vector) + (logior 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) (%unbound-marker) + (nhash.vector.cache-value vector) nil + (nhash.fixnum hash) fwdnum + (nhash.gc-count hash) gc-count + (nhash.grow-threshold hash) (- size (nhash.count hash))) + (when (eq #'%am-growing (nhash.rehashF hash)) + ;; if not changed to %maybe-rehash then contains no address based keys + (setf (nhash.rehashf hash) #'%no-rehash)) + (setq rehashF nil) ; tell clean-up form we finished the loop + (when (neq old-size (nhash.count hash)) + (cerror "xx" "Somebody messed with count while growing") + (return-from grow-hash-table (grow-hash-table hash ))) + (when (minusp (nhash.grow-threshold hash)) + (cerror "nn" "negative grow-threshold ~S ~s ~s ~s" + (nhash.grow-threshold hash) size total-size old-size)) + ;; If the old vector's in some static heap, zero it + ;; so that less garbage is retained. + (%init-misc 0 old-vector))) + (when rehashF + (setf (nhash.rehashF hash) rehashF + (nhash.vector.flags old-vector) + (logior weak-flags (the fixnum (nhash.vector.flags old-vector))))))))))) + + + +;;; values of nhash.rehashF +;;; %no-rehash - do nothing +;;; %maybe-rehash - if doesnt need rehashing - if is rehashing 0 else nil +; if locked 0 +; else rehash, return t +;;; %am-rehashing - 0 +;;; %am-growing - calls %maybe-rehash + +;;; compute-hash-code funcalls it if addressp and maybe-rehash-p +;;; sets to maybe-rehash if addressp and update-maybe-rehash (ie from puthash) +;;; grow-hash-table sets to %am-growing when doing so, resets to original value when done +;;; rehash sets to %am-rehashing, then to original when done + +(defun %no-rehash (hash) + (declare (%noforcestk) + (optimize (speed 3) (safety 0)) + (ignore hash)) + nil) + +(defun %maybe-rehash (hash) + (declare (optimize (speed 3) (safety 0))) + (cond ((not (%needs-rehashing-p hash)) + nil) + (t (loop + (%rehash hash) + (unless (%needs-rehashing-p hash) + (return)) + ;(incf n3) + ) + t))) + +(defun %am-rehashing (hash) + (declare (optimize (speed 3) (safety 0)) + (ignore hash)) + 0) + +(defun %am-growing (hash) + (declare (optimize (speed 3) (safety 0))) + (%maybe-rehash hash)) + +(defun general-hash-find (hash key) + (%hash-probe hash key nil)) + +(defun general-hash-find-for-put (hash key) + (%hash-probe hash key t)) + +;;; 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-key-marker) + + + +(defun %hash-probe (hash key update-hash-flags) + (declare (optimize (speed 3) (space 0))) + (multiple-value-bind (hash-code index entries) + (compute-hash-code hash key update-hash-flags) + (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-key-marker) + (return-it (or first-deleted-index + vector-index))) + ((eq table-key deleted-hash-key-marker) + (when (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) + (unless first-deleted-index + (error "No deleted entries in table")) + (return-it first-deleted-index)) + (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))))))) + (length (uvsize vector)) + (count (- length $nhash.vector_overhead)) + (entries (ash count -1)) + (vector-index (index->vector-index (fast-mod hash-code entries))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code entries vector-index count length)) + (if (or (eq key table-key) + (eq table-key free-hash-key-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (if (eq table-key deleted-hash-key-marker) + vector-index))) + (declare (fixnum secondary-hash initial-index)) + (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 first-deleted-index)) + (if (eq table-key key) + (return vector-index) + (if (eq table-key free-hash-key-marker) + (return (or first-deleted-index vector-index)) + (if (and (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index))))))))) + +;;; 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) + (let* ((flags (nhash.vector.flags vector))) + (declare (fixum flags)) + (unless (logbitp $nhash_track_keys_bit flags) + (setq flags (bitclr $nhash_key_moved_bit flags))) + (setf (nhash.vector.flags vector) + (logior $nhash-track-keys-mask flags)))) + (mixup-hash-code (strip-tag-to-fixnum key)))))))) + (length (uvsize vector)) + (count (- length $nhash.vector_overhead)) + (vector-index (index->vector-index (fast-mod hash-code (ash count -1)))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code length count entries vector-index)) + (if (or (eq key table-key) + (eq table-key free-hash-key-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (if (eq table-key deleted-hash-key-marker) + vector-index))) + (declare (fixnum secondary-hash initial-index)) + (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 first-deleted-index)) + (if (eq table-key key) + (return vector-index) + (if (eq table-key free-hash-key-marker) + (return (or first-deleted-index vector-index)) + (if (and (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)) + (length (uvsize vector)) + (count (- length $nhash.vector_overhead)) + (entries (ash count -1)) + (vector-index (index->vector-index (fast-mod hash-code entries))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code length entries count vector-index)) + (if (or (eql key table-key) + (eq table-key free-hash-key-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (if (eq table-key deleted-hash-key-marker) + vector-index))) + (declare (fixnum secondary-hash initial-index)) + (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 first-deleted-index)) + (if (eql table-key key) + (return vector-index) + (if (eq table-key free-hash-key-marker) + (return (or first-deleted-index vector-index)) + (if (and (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index)))))))) + (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)) + (length (uvsize vector)) + (count (- length $nhash.vector_overhead)) + (entries (ash count -1)) + (vector-index (index->vector-index (fast-mod hash-code entries))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code length entries vector-index)) + (if (or (eql key table-key) + (eq table-key free-hash-key-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (if (eq table-key deleted-hash-key-marker) + vector-index))) + (declare (fixnum secondary-hash initial-index)) + (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 deleted entries in table")))) + (if (eql table-key key) + (return vector-index) + (if (eq table-key free-hash-key-marker) + (return (or first-deleted-index vector-index)) + (if (and (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index)))))))) + (eq-hash-find-for-put hash key))) + +;;; Rehash. Caller should have exclusive access to the hash table +;;; and have disabled interrupts. +(defun %rehash (hash) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector)) ) + (setf (nhash.vector.flags vector) + (logand flags $nhash-clear-key-bits-mask)) + (do-rehash hash))) + + +(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))) + +(defun do-rehash (hash) + (let* ((vector (nhash.vector hash)) + (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.cache-key vector) (%unbound-marker) + (nhash.vector.cache-value vector) nil) + (%set-does-not-need-rehashing hash) + (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-key-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.count hash) wdc))) + (incf (nhash.grow-threshold hash)) + ;; Change deleted to free + (setf (%svref vector vector-index) free-hash-key-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-key-marker) + (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-key-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-key-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.count hash) 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.count hash)) + (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) + (declare (optimize (speed 3)(safety 0))) + (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t) + (declare (fixnum hash-code index entries)) + (when (null hash-code)(cerror "nuts" "Nuts")) + (let* ((vector (nhash.vector hash)) + (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-key-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-key-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)) + #.(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)) + #.(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))))) + ((hash-table-p key) + (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) 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))) + ((or pathname logical-pathname) + (dotimes (i (uvsize expr) key) + (declare (fixnum i)) + (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)) + + + +#+ppc32-target +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (fixnum tag)) + (or (= tag ppc32::tag-fixnum) + (= tag ppc32::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 get-fwdnum (&optional hash) + (let* ((res (%get-fwdnum))) + (if hash + (setf (nhash.fixnum hash) res)) + res)) + +(defun gc-count (&optional hash) + (let ((res (%get-gc-count))) + (if hash + (setf (nhash.gc-count hash) res) + res))) + + +(defun %cons-nhash-vector (size &optional (flags 0)) + (declare (fixnum size)) + (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector (%unbound-marker)))) + (setf (nhash.vector.link vector) 0 + (nhash.vector.flags vector) flags + (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.cache-key vector) (%unbound-marker) + (nhash.vector.cache-value vector) nil + (nhash.vector.cache-idx vector) nil) + vector)) + +(defun assert-hash-table-readonly (hash) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (or (nhash.read-only hash) + (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 (hash-table-p hash) + (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 (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (nhash.read-only hash)) + +(defun hash-table-owner (hash) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (nhash.owner hash)) + +(defun claim-hash-table (hash &optional steal) + (unless (hash-table-p hash) + (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 + (write-lock-hash-table hash) + (setf (nhash.exclusion-lock hash) nil + (nhash.owner hash) *current-process*) + t)))) + + + + + +(defun enumerate-hash-keys (hash out) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (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 out)) + (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* ((val (%svref in in-idx))) + (unless (or (eq val free-hash-key-marker) + (eq val deleted-hash-key-marker)) + (setf (%svref out out-idx) val) + (incf out-idx)))))))) + +(defun enumerate-hash-keys-and-values (hash keys values) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (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 keys)) + (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-key-marker) + (eq key deleted-hash-key-marker)) + (setf (%svref keys out-idx) key) + (setf (%svref values out-idx) (%svref in (the fixnum (1+ in-idx)))) + (incf out-idx)))))))) Index: /branches/experimentation/later/source/level-0/l0-init.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-init.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-init.lisp (revision 8058) @@ -0,0 +1,138 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + :clozure + :clozure-common-lisp + :ansi-cl + :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 + :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 + #+x8664-target :x86-64 + #+x8664-target :x86_64 + #+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 + #+darwinppc-target :darwinppc-target + #+darwinppc-target :darwinppc-host + #+darwinppc-target :darwin + #+darwinppc-target :darwin-target + #+freebsd-target :freebsd-host + #+freebsd-target :freebsd-target + #+freebsdx86-target :freebsdx86-target + #+freebsdx8664-target :freebsdx8664-target + #+freebsdx8664-target :freebsdx8664-host + #+darwin-target :darwin-host + #+darwin-target :darwin-target + #+darwinx86-target :darwinx86-target + #+darwinx8664-target :darwinx8664-target + #+darwinx8664-target :darwinx8664-host + #+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 + :mcl ;deprecated + ) + "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) + +(defvar *nx-speed* 1) +(defvar *nx-space* 1) +(defvar *nx-safety* 1) +(defvar *nx-cspeed* 1) +(defvar *nx-debug* 1) + +;;; end Index: /branches/experimentation/later/source/level-0/l0-int.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-int.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-int.lisp (revision 8058) @@ -0,0 +1,188 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 rem)) + (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/experimentation/later/source/level-0/l0-io.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-io.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-io.lisp (revision 8058) @@ -0,0 +1,264 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + #+linuxppc-target + (require "PPC-LINUX-SYSCALLS") + #+linuxx8664-target + (require "X8664-LINUX-SYSCALLS") + #+darwinppc-target + (require "DARWINPPC-SYSCALLS") + #+darwinx8664-target + (require "DARWINX8664-SYSCALLS") + #+freebsd-target + (require "X8664-FREEBSD-SYSCALLS") + ) + + +(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-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))) + (logand #x3f code)) + (incf idx 4)))))) + +(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)) + (let* ((code (%get-unsigned-byte pointer i)) + (nexti (+ i (cond ((< code #x80) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + (t 4))))) + (declare (type (unsigned-byte 8) code)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti))))) + + + +;;; write nbytes bytes from buffer buf to file-descriptor fd. +(defun fd-write (fd buf nbytes) + (syscall syscalls::write fd buf nbytes)) + +(defun fd-read (fd buf nbytes) + (loop + (let* ((n (syscall syscalls::read fd buf nbytes))) + (unless (eql n (- #$EINTR)) (return n))))) + + +(defun fd-open (path flags &optional (create-mode #o666)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path)) + (let* ((fd (syscall syscalls::open p flags create-mode))) + (declare (fixnum fd)) + (when (or (= fd (- #$EMFILE)) + (= fd (- #$EMFILE))) + (gc) + (drain-termination-queue) + (setq fd (syscall syscalls::open p flags create-mode))) + fd))) + +(defun fd-chmod (fd mode) + (syscall syscalls::fchmod fd mode)) + +;;; This should really be conditionalized on whether the seek system +;;; call supports 64-bit offsets or on whether one has to use some +;;; variant. +#+(and ppc32-target linux-target) +(defun fd-lseek (fd offset whence) + (let* ((high (ldb (byte 32 32) offset)) + (low (ldb (byte 32 0) offset))) + (declare (type (unsigned-byte 32) high low)) + (%stack-block ((pos 8)) + (let* ((res (syscall syscalls::_llseek fd high low pos whence))) + (declare (fixnum res)) + (if (< res 0) + res + (let* ((pos-high (%get-unsigned-long pos 0)) + (pos-low (%get-unsigned-long pos 4))) + (declare (type (unsigned-byte 32) pos-high pos-low)) + (if (zerop pos-high) + pos-low + (dpb pos-high (byte 32 32) pos-low)))))))) + +#-(and ppc32-target linux-target) +(defun fd-lseek (fd offset whence) + #+freebsd-target + (syscall syscalls::lseek fd 0 offset whence) + #-freebsd-target + (syscall syscalls::lseek fd offset whence)) + +(defun fd-close (fd) + (syscall syscalls::close fd)) + +(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) + (without-interrupts + (let* ((curpos (fd-lseek fd 0 #$SEEK_CUR))) + (unwind-protect + (fd-lseek fd 0 #$SEEK_END) + (fd-lseek fd curpos #$SEEK_SET))))) + +(defun fd-ftruncate (fd new) + (syscall syscalls::ftruncate fd new)) + +(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/experimentation/later/source/level-0/l0-misc.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-misc.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-misc.lisp (revision 8058) @@ -0,0 +1,1168 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 *locks-held* () "per-thread list of held locks") +(defparameter *locks-pending* () "per-thread list of locks we're waiting for.") +(defparameter *lock-conses* ()) + +;; Cold-load lossage. +#+lock-accounting +(setq *lock-conses* (make-list 20)) + +;;; Per-thread consing, for lock-ownership tracking. +#+lock-accounting +(defun %lock-cons (x y) + (let* ((cell (prog1 *lock-conses* + (setq *lock-conses* (cdr *lock-conses*))))) + (if cell + (progn + (rplaca cell x) + (rplacd cell y)) + (cons x y)))) + + +;;; Bootstrapping for futexes +#+(and linuxx8664-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) + (require "X8664-LINUX-SYSCALLS") + (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) + #+x8664-target + (debug-trap-with-string arg) + #-x8664-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 () + (%normalize-areas) + (let ((res 0)) + (with-macptrs (p) + (do-consing-areas (area) + (when (eql (%fixnum-ref area target::area.code) area-dynamic) + (%setf-macptr-to-object p area) + (incf res (- (%get-natural p target::area.high) + (%get-natural p target::area.active)))))) + res)) + +(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 () + (%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)))) + +;;; 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)))) + +(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. +(defun %suspend-other-threads () + (ff-call (%kernel-import target::kernel-import-suspend-other-threads) + :void)) + +(defun %resume-other-threads () + (ff-call (%kernel-import target::kernel-import-resume-other-threads) + :void)) + +(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))) + +(defun note-lock-wait (lock) + #+lock-accounting + (setq *locks-pending* (%lock-cons lock *locks-pending*)) + #-lock-accounting (declare (ignore lock))) + +(defun note-lock-held () + #+lock-accounting + (let* ((p *locks-pending*)) + (setq *locks-pending* (cdr *locks-pending*)) + (rplacd p *locks-held*) + (setq *locks-held* p))) + +(defun note-lock-released () + #+lock-accounting + (setf (car *locks-held*) nil + *locks-held* (cdr *locks-held*))) + +#-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))) + (note-lock-wait lock) + (loop + (without-interrupts + (when (eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + (note-lock-held) + (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) + (note-lock-held) + (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) + (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0))) + #+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*) + (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0) + (incf *total-futex-wait-times* (- (get-internal-real-time) start))))))) + + + + +#+futex +(defun futex-wake (p n) + (syscall syscalls::futex p FUTEX-WAKE n (%null-ptr) (%null-ptr) 0)) + +#+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 val)) + (note-lock-wait lock) + (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))) + (note-lock-held) + (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)) + #+lock-accounting + (setq *locks-held* (%lock-cons lock *locks-held*)) + (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) + #+lock-accounting + (setq *locks-held* (%lock-cons lock *locks-held*)) + (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)) + #+lock-accounting* + (setq *locks-held* (%lock-cons lock *locks-held*)) + (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) + #+lock-accounting + (setq *locks-held* (%lock-cons lock *locks-held*)) + (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)))) + (note-lock-released) + (%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)))) + (note-lock-released) + (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 %suspend-tcr (tcr) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp tcr) + (not (zerop (the fixnum + (ff-call (%kernel-import target::kernel-import-suspend-tcr) + :address tcrp + :unsigned-fullword)))))) + +(defun %resume-tcr (tcr) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp tcr) + (not (zerop (the fixnum + (ff-call (%kernel-import target::kernel-import-resume-tcr) + :address tcrp + :unsigned-fullword)))))) + + + +(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)) + (note-lock-wait lock) + (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) + (note-lock-held) + (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. + (note-lock-held) + (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)) + (note-lock-wait lock) + (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) + (note-lock-held) + (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. + (note-lock-held) + (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)) + (note-lock-wait lock) + (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) + (setq *locks-pending* (cdr *locks-pending*)) + (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) + (note-lock-held) + (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)) + (note-lock-wait lock) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (%unlock-futex ptr) + (setq *locks-pending* (cdr *locks-pending*)) + (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))) + (note-lock-held) + (%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.) + (note-lock-released) + (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) + (note-lock-released) + (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))) Index: /branches/experimentation/later/source/level-0/l0-numbers.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-numbers.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-numbers.lisp (revision 8058) @@ -0,0 +1,1955 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))))) + + + + (defmacro two-arg-+/- (name op big-op) + `(defun ,name (x y) + (number-case x + (fixnum (number-case y + (fixnum (,op (the fixnum x) (the fixnum y))) + (double-float (rat-dfloat ,op x y)) + (short-float (rat-sfloat ,op x y)) + (bignum (with-small-bignum-buffers ((bx x)) + (,big-op bx y))) + (complex (complex (,op x (%realpart y)) + ,(if (eq op '-)`(- (%imagpart y)) `(%imagpart y)))) + (ratio (let* ((dy (%denominator y)) + (n (,op (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (double-float (number-case y + (double-float (,op (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (,op (the double-float x) (the double-float dy)))) + (rational (dfloat-rat ,op x y)) + (complex (complex (,op x (%realpart y)) + ,(if (eq op '-)`(- (%imagpart y)) `(%imagpart y)))))) + (short-float (number-case y + (short-float (,op (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (,op (the double-float dx) (the double-float y)))) + (rational (sfloat-rat ,op x y)) + (complex (complex (,op x (%realpart y)) + ,(if (eq op '-) `(- (%imagpart y)) `(%imagpart y)))))) + (bignum (number-case y + (bignum (,big-op x y)) + (fixnum (with-small-bignum-buffers ((by y)) + (,big-op x by))) + (double-float (rat-dfloat ,op x y)) + (short-float (rat-sfloat ,op x y)) + (complex (complex (,op x (realpart y)) + ,(if (eq op '-)`(- (%imagpart y)) `(%imagpart y)))) + (ratio + (let* ((dy (%denominator y)) + (n (,op (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (complex (number-case y + (complex (canonical-complex (,op (%realpart x) (%realpart y)) + (,op (%imagpart x) (%imagpart y)))) + ((rational float) (complex (,op (%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 (,op (* nx dy) (* dx ny)) (* dx dy)) + (let* ((t1 (,op (* 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 (,op (%numerator x) (* y dx)))) + (%make-ratio n dx))) + (double-float (rat-dfloat ,op x y)) + (short-float (rat-sfloat ,op x y)) + (complex (complex (,op x (%realpart y)) + ,(if (eq op '-)`(- (%imagpart y)) `(%imagpart 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 ppc32::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))) + + + + +(two-arg-+/- +-2 + add-bignums) +(two-arg-+/- --2 - subtract-bignum) + + +;;; 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))) + (if (eql den 1) + num + (%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) + #+ppc32-target + `(ppc32::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 + (if (eql number most-negative-fixnum) + (if (zerop divisor) + (error 'division-by-zero :operation 'truncate :operands (list number divisor)) + (with-small-bignum-buffers ((bn number)) + (multiple-value-bind (quo rem) (truncate bn divisor) + (if (eq quo bn) + (values number rem) + (values quo rem))))) + (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 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 + #+ppc32-target + (ppc32::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) + #+ppc32-target + (ppc32::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) + #+ppc32-target + `(ppc32::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 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 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) + #+ppc32-target + (ppc32::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 + #+ppc32-target + (ppc32::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 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) + + + +(defun init-random-state-seeds () + (let* ((ticks (ldb (byte 32 0) (+ (mixup-hash-code (%current-tcr)) + (primary-ip-interface-address) + (mixup-hash-code + (logand (get-internal-real-time) + (1- 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))) + + +#+32-bit-target +(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)) + (locally (declare (fixnum number)) + (if (< number 65536) + (fast-mod (%next-random-seed state) number) + (let* ((n 0) + (nhalf (ash (+ 15 (integer-length number)) -4))) + (declare (fixnum n nhalf)) + (dotimes (i nhalf (fast-mod n number)) + (setq n (logior (the fixnum (ash n 16)) + (the fixnum (%next-random-seed 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))))))) + +#+64-bit-target +(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)) + (locally (declare (fixnum number)) + (let* ((n 0) + (n32 (ash (+ 31 (integer-length number)) -5))) + (declare (fixnum n n32)) + (dotimes (i n32 (fast-mod n number)) + (setq n (logior (the fixnum (ash n 32)) + (the fixnum (%next-random-seed 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))))))) + + +#| +Date: Mon, 3 Feb 1997 10:04:08 -0500 +To: info-mcl@digitool.com, wineberg@franz.scs.carleton.ca +From: dds@flavors.com (Duncan Smith) +Subject: Re: More info on the random number generator +Sender: owner-info-mcl@digitool.com +Precedence: bulk + +The generator is a Linear Congruential Generator: + + X[n+1] = (aX[n] + c) mod m + +where: a = 16807 (Park&Miller recommend 48271) + c = 0 + m = 2^31 - 1 + +See: Knuth, Seminumerical Algorithms (Volume 2), Chapter 3. + +The period is: 2^31 - 2 (zero is excluded). + +What makes this generator so simple is that multiplication and addition mod +2^n-1 is easy. See Knuth Ch. 4.3.2 (2nd Ed. p 272). + + ab mod m = ... + +If m = 2^n-1 + u = ab mod 2^n + v = floor( ab / 2^n ) + + ab mod m = u + v : u+v < 2^n + ab mod m = ((u + v) mod 2^n) + 1 : u+v >= 2^n + +What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of +2^31. This reduces the whole generator to 5 instructions on the 680x0 or +80x86, and 8 on the 60x. + +-Duncan + +|# + +#+64-bit-target +(defun %next-random-seed (state) + (let* ((n (the fixnum (* (the fixnum (random.seed-1 state)) 48271)))) + (declare (fixnum n)) + (setf (random.seed-1 state) (fast-mod n (1- (expt 2 31)))) + (logand n (1- (ash 1 32))))) + +#+32-bit-target +(defun %next-random-seed (state) + (multiple-value-bind (high low) (%next-random-pair (random.seed-1 state) + (random.seed-2 state)) + (declare (type (unsigned-byte 15) high) + (type (unsigned-byte 16) low)) + (setf (random.seed-1 state) high + (random.seed-2 state) low) + (logior high (the fixnum (logand low (ash 1 15)))))) + +#+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 words words-2 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 + (setf (aref 16-bit-dividend index) (%next-random-seed state)) + (decf half-words) + (when (<= half-words 0) (return)) + (setf (aref 16-bit-dividend (the fixnum (1- index))) + (%next-random-seed 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 most-positive-fixnum state) most-positive-fixnum))) + (declare (dynamic-extent ratio)) + (* number ratio))) + +(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 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 most-negative-fixnum) + (if (eql n2 most-negative-fixnum) + (- most-negative-fixnum) + (bignum-fixnum-gcd (- most-negative-fixnum) (abs n2))) + (if (eql n2 most-negative-fixnum) + (bignum-fixnum-gcd (- 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 most-negative-fixnum) + (%bignum-bignum-gcd n2 (- most-negative-fixnum)) + (bignum-fixnum-gcd (bignum-abs n2)(fixnum-abs n1)))))) + (bignum + (number-case n2 + (fixnum + (if (eql n2 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/experimentation/later/source/level-0/l0-pred.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-pred.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-pred.lisp (revision 8058) @@ -0,0 +1,920 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 find-class-cell (type create?) + (declare (ignore create?)) + (make-class-cell type)) + +(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)) + #+ppc32-target + (and (>= typecode ppc32::min-numeric-subtag) + (<= typecode ppc32::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)) + #+ppc32-target + (or (= typecode ppc32::tag-fixnum) + (and (>= typecode ppc32::min-numeric-subtag) + (<= typecode ppc32::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::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)))))) + +(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)) + #+ppc32-target + (or (= typecode ppc32::tag-fixnum) + (and (>= typecode ppc32::min-numeric-subtag) + (<= typecode ppc32::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) + #+ppc32-target + (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) ppc32::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) + #+ppc32-target + (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) + ppc32::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 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 (%svref x 0))) + (and (eq structname (%svref y 0)) + (or (eq structname 'pathname) + (eq structname 'logical-pathname))) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-size (uvsize x))) + (declare (fixnum x-size)) + (when (= x-size (the fixnum (uvsize y))) + ;; Ignore last (version) slot in physical pathnames. + (when (eq structname 'pathname) + (decf x-size)) + (do* ((i 1 (1+ i))) + ((= i x-size) t) + (declare (fixnum i)) + (unless (equal (%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 + + + +#+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 + istruct + 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)) + +(defun structure-typep (thing type) + (if (= (the fixnum (typecode thing)) target::subtag-struct) + (if (memq type (%svref thing 0)) + t))) + + +(defun istruct-typep (thing type) + (if (= (the fixnum (typecode thing)) target::subtag-istruct) + (eq (%svref thing 0) type))) + +(defun symbolp (thing) + "Return true if OBJECT is a SYMBOL, and NIL otherwise." + #+ppc32-target + (if thing + (= (the fixnum (typecode thing)) ppc32::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) Index: /branches/experimentation/later/source/level-0/l0-symbol.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-symbol.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-symbol.lisp (revision 8058) @@ -0,0 +1,265 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 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/experimentation/later/source/level-0/l0-utils.lisp =================================================================== --- /branches/experimentation/later/source/level-0/l0-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/l0-utils.lisp (revision 8058) @@ -0,0 +1,159 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + + + +;;; We MAY need a scheme for finding all of the areas in a lisp library. +(defun %map-areas (function &optional (maxcode area-dynamic) (mincode area-readonly)) + (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)) + (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 area-dynamic area-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) + #+ppc32-target + (defmacro need-use-eql-macro (key) + `(let* ((typecode (typecode ,key))) + (declare (fixnum typecode)) + (or (= typecode ppc32::subtag-macptr) + (and (>= typecode ppc32::min-numeric-subtag) + (<= typecode ppc32::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/experimentation/later/source/level-0/nfasload.lisp =================================================================== --- /branches/experimentation/later/source/level-0/nfasload.lisp (revision 8058) +++ /branches/experimentation/later/source/level-0/nfasload.lisp (revision 8058) @@ -0,0 +1,1071 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 pb)) + (%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 nbytes)) + (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) + (declare (fixnum subtype)) + (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) + (declare (fixnum subtype)) + (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))))) + +(defun find-package (name) + (if (packagep name) + name + (%find-pkg (string name)))) + +(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)) + (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))))) + (apply (%car form) (%cdr form)) + (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 #+ppc32-target (if (= subtag ppc32::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 subtag 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) + #+ppc32-target + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes ppc32::subtag-double-float-vector + element-count)) + (vector (%alloc-misc element-count + ppc32::subtag-double-float-vector))) + (declare (fixnum subtag element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector (- ppc32::misc-dfloat-offset + ppc32::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 subtag 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))) + +(defvar *modules* nil) + +;;; Bootstrapping version +(defun provide (module-name) + (push (string module-name) *modules*)) + +(deffaslop $fasl-provide (s) + (provide (%fasl-expr s))) + + +;;; 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*)) + (%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 (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/experimentation/later/source/level-1/.cvsignore =================================================================== --- /branches/experimentation/later/source/level-1/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/level-1/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/level-1/l1-application.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-application.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-application.lisp (revision 8058) @@ -0,0 +1,301 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions Copyright (C) 2001-2004, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-APPLICATION-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))) + (if encoding + (setq *terminal-character-encoding-name* + (if (cdr encoding) + (let* ((*package* (find-package "KEYWORD"))) + (ignore-errors (read-from-string (cdr 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) + #$EX_USAGE + (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) + (initialize-interactive-streams))) + +(defmethod application-version-string ((a application)) + "Return a string which (arbitrarily) represents the application version. +Default version returns OpenMCL 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) + #$EX_USAGE + (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 toplevel-function ((a lisp-development-system) init-file) + (let* ((sr (input-stream-shared-resource *terminal-input*))) + (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)) + (listener-function) + 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 #'(lambda () + (with-standard-abort-handling nil + (loop + (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*) + (housekeeping))))) + (toplevel)) + + + +(defmethod application-init-file ((app lisp-development-system)) + ;; This is the init file loaded before cocoa. + #+clozure-common-lisp '("home:ccl-init" "home:openmcl-init") ;; transitional kludge + #-clozure-common-lisp "home:openmcl-init") + +(defmethod application-error ((a application) condition error-pointer) + (declare (ignore condition error-pointer)) + (quit)) Index: /branches/experimentation/later/source/level-1/l1-aprims.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-aprims.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-aprims.lisp (revision 8058) @@ -0,0 +1,2015 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + +(def-standard-initial-binding *package*) +(def-standard-initial-binding *gensym-counter* 0) +(def-standard-initial-binding *random-state* (initialize-random-state #xFBF1 9)) +#+lock-accounting +(progn +(def-standard-initial-binding *locks-held* ()) +(def-standard-initial-binding *locks-pending* ()) +(def-standard-initial-binding *lock-conses* (make-list 20))) +(def-standard-initial-binding *whostate* "Reset") +(setq *whostate* "Active") +(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 index 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 most-positive-fixnum))) + ((typep n 'fixnum) (nthcdr n list)) + (unless (setq list (nthcdr 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) + (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 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)))) + + +;;; 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) + (let* ((length (length seq))) + (declare (fixnum length)) + (if (not end) + (setq end length) + (unless (typep end 'fixnum) + (report-bad-arg end 'fixnum))) + (unless (typep start 'fixnum) + (report-bad-arg start 'fixnum)) + (locally (declare (fixnum start end)) + (cond ((> end length) + (report-bad-arg end `(integer 0 (,length)))) + ((< start 0) + (report-bad-arg start `(integer 0))) + ((< end 0) + (report-bad-arg end `(integer 0 (,length)))) + ((> start end) + (report-bad-arg start `(integer 0 ,end))) + (t 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 extended-string-p (thing) + (declare (ignore thing))) + +(defun simple-extended-string-p (thing) + (declare (ignore thing))) + + + +(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))))) + ) + +#+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." + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (if (and (>= code (char-code #\A))(<= code (char-code #\Z))) + (%code-char (%i+ code #.(- (char-code #\a)(char-code #\A)))) + (or (and (>= code #x80) + (%non-standard-lower-case-equivalent c)) + 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 char-upcase (c) + "Return CHAR converted to upper-case if that is possible. Don't convert + lowercase eszet (U+DF)." + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (if (and (>= code (char-code #\a))(<= code (char-code #\z))) + (%code-char (%i- code #.(- (char-code #\a)(char-code #\A)))) + (or (and (>= code #x80) (%non-standard-upper-case-equivalent c)) + c)))) + + + +(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-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 in OpenMCL 0.14 and to a multiple +of 32KBytes in earlier versions.)" + (let* ((was-enabled (egc-active-p))) + (unwind-protect + (progn + (egc nil) + (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-type e2size '(unsigned-byte 18)) 10))) + e1size (logand (lognot #xffff) (+ #xffff (ash (require-type e1size '(unsigned-byte 18)) 10))) + e0size (logand (lognot #xffff) (+ #xffff (ash (require-type e0size '(integer 1 #.(ash 1 18))) 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 + (#_bzero p size)) + p)) + +(defun %gcable-ptr-p (p) + (and (typep p 'macptr) + (= (uvsize p) target::xmacptr.element-count))) + +(defstatic *non-standard-lower-to-upper* (make-hash-table :test #'eq) + "Maps non-STANDARD-CHAR lowercase chars to uppercase equivalents") + +(defstatic *non-standard-upper-to-lower* (make-hash-table :test #'eq) + "Maps non-STANDARD-CHAR uppercase chars to lowercase equivalents") + +;;; This alist is automatically (and not to cleverly ...) generated. +;;; 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. +(dolist (pair '((#\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))) + (destructuring-bind (upper . lower) pair + (setf (gethash upper *non-standard-upper-to-lower*) lower + (gethash lower *non-standard-lower-to-upper*) upper))) + +(assert-hash-table-readonly *non-standard-upper-to-lower*) +(assert-hash-table-readonly *non-standard-lower-to-upper*) + +(defun %non-standard-upper-case-equivalent (char) + (gethash char *non-standard-lower-to-upper*)) + +;;;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))) + (if (< code #x80) + (and (>= code (char-code #\a)) + (<= code (char-code #\z))) + (not (null (%non-standard-upper-case-equivalent c)))))) + + +;;;True for a-z A-Z, others. + + +(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))) + (declare (fixnum code)) + (or (and (>= code (char-code #\A)) (<= code (char-code #\Z))) + (and (>= code (char-code #\a)) (<= code (char-code #\z))) + (and (>= code #x80) + (or (not (null (%non-standard-upper-case-equivalent c))) + (not (null (%non-standard-lower-case-equivalent c)))))))) + + + + +;;; 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) + + + + +(defpackage #.(ftd-interface-package-name + (backend-target-foreign-type-data *target-backend*)) + (:nicknames "OS") + (:use "COMMON-LISP")) + + + Index: /branches/experimentation/later/source/level-1/l1-boot-1.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-boot-1.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-boot-1.lisp (revision 8058) @@ -0,0 +1,123 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) + +(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)) + (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 + :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 () + (let ((startup (mac-default-directory))) + (replace-base-translation "home:" (or (user-homedir-pathname) startup)) + (replace-base-translation "ccl:" (ccl-directory)) + )) + +(push #'init-logical-directories *lisp-system-pointer-functions*) + + +(catch :toplevel + (setq *loading-file-source-file* nil) ;Reset from last %fasload... + (init-logical-directories) + ) + + + + + + Index: /branches/experimentation/later/source/level-1/l1-boot-2.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-boot-2.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-boot-2.lisp (revision 8058) @@ -0,0 +1,283 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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*)) + (%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*)) + (%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 an OpenMCL 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)) + + +(defloadvar *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. + +(defloadvar *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 0 + :basic t + :sharing :lock + :direction :input + :interactive (not *batch-flag*) + :encoding encoding-name)) + (setq *stdout* (make-fd-stream 1 :basic t :direction :output :sharing :lock :encoding encoding-name)) + + (setq *stderr* (make-fd-stream 2 :basic t :direction :output :sharing :lock :encoding encoding-name)) + (if *batch-flag* + (let* ((tty-fd (let* ((fd (fd-open "/dev/tty" #$O_RDWR))) + (if (>= fd 0) fd))) + (can-use-tty (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*) + + + + +(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") + #+x8664-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") + + #+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") + + #+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-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 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") + + (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 "SOURCE-FILES" "source-files") + (bin-load-provide "MCL-COMPAT" "mcl-compat") + (require "LOOP") + (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms") + (l1-load-provide "VERSION" "version") + (require "LISPEQU") ; Shouldn't need this at load time ... + ) + (setq *%fasload-verbose* nil) + ) +) + + + + + + Index: /branches/experimentation/later/source/level-1/l1-boot-3.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-boot-3.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-boot-3.lisp (revision 8058) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-1/l1-boot-lds.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-boot-lds.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-boot-lds.lisp (revision 8058) @@ -0,0 +1,119 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + #+clozure-common-lisp ;; Kludge to help people transition + (when (equalp (pathname-name init-file) "openmcl-init") + (warn ">>>>>> The use of openmcl-init.lisp is deprecated. Please rename your init file to ccl-init.lisp")) + (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*) + (value-stack-size *default-value-stack-size*) + (temp-stack-size *default-temp-stack-size*) + (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* + (make-echoing-two-way-stream + input-stream output-stream))) + (unwind-protect + (progn + (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/experimentation/later/source/level-1/l1-callbacks.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-callbacks.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-callbacks.lisp (revision 8058) @@ -0,0 +1,164 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + + +;;; 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) + +(defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts) + (vector routine-descriptor proc-info lisp-function sym without-interrupts nil)) + +;;; (defcallback ...) expands into a call to this function. +(defun define-callback-function (lisp-function &optional doc-string (without-interrupts t) monitor-exception-ports + &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)) + (setf (%svref %pascal-functions% index) + (%cons-pfe trampoline monitor-exception-ports lisp-function name without-interrupts))))) + ;;(%proclaim-special name) ; + ;; already done by defpascal expansion + (when name (set name trampoline)) + (record-source-file name 'defcallback) + (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 () + (#_mmap (%null-ptr) + (#_getpagesize) + (logior #$PROT_READ #$PROT_WRITE #$PROT_EXEC) + (logior #$MAP_PRIVATE #$MAP_ANON) + -1 + 0)) + +(defstatic *available-bytes-for-callbacks* 0) +(defstatic *current-callback-page* nil) + +(defun reset-callback-storage () + (setq *available-bytes-for-callbacks* (#_getpagesize) + *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/experimentation/later/source/level-1/l1-cl-package.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-cl-package.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-cl-package.lisp (revision 8058) @@ -0,0 +1,1021 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-1/l1-clos-boot.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-clos-boot.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-clos-boot.lisp (revision 8058) @@ -0,0 +1,3553 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) +(defun instance-slots (instance) + (let* ((typecode (typecode instance))) + (cond ((eql typecode target::subtag-instance) (instance.slots instance)) + ((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 %class-name (class) + (%class.name class)) + +(defun %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) + (if (typep class 'slots-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 (typep class 'slots-class) + (%class.slots class))) + +(defun (setf %class-slots) (new class) + (if (typep class 'slots-class) + (setf (%class.slots class) new) + new)) + +(defun %class-direct-slots (class) + (if (typep class 'slots-class) + (%class.direct-slots class))) + +(defun (setf %class-direct-slots) (new class) + (if (typep class 'slots-class) + (setf (%class.direct-slots class) new)) + 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-class (slotd) + (standard-slot-definition.class slotd)) + +(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). +(defun %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 (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))) + + + + +(defstatic *type-system-initialized* nil) + +(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 'function-encapsulation ;Redefined in encapsulate + (qlfun bootstrapping-function-encapsulation (name) + (declare (ignore name)) + nil)) + +(%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-unenecapsulated-def (spec) + (values + (typecase spec + (symbol (fboundp spec)) + (method (%method-function spec)) + (t spec)) + spec))) + +(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) + (let ((f (%method-function method))) + (when (function-encapsulation f) + (setq f (find-unencapsulated-definition f))) + (closure-function f))) + + +(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"))) + ;; 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)))) + +(defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers + &allow-other-keys) + (declare (dynamic-extent keys)) + (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 forget-encapsulations (name) + (declare (ignore name)) + nil) + +(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 + (if (function-encapsulation method-function) + (find-unencapsulated-definition method-function) + 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)) + +(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) + (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 OpenMCL." 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 (list cell)) + (unless found (return)) + (when (cdr 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)) + (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))) + + +(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))))) + + +(defparameter dcode-proto-alist + (list (cons #'%%one-arg-dcode *gf-proto-one-arg*) + (cons #'%%1st-two-arg-dcode *gf-proto-two-arg*))) + +(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 gf)) + (encapsulated-dcode-cons (and (combined-method-p old-dcode) + (eq '%%call-gf-encapsulation + (function-name (%combined-method-dcode old-dcode))) + (cdr (%combined-method-methods old-dcode))))) + (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode)) + (neq multi-method-index (%gf-dispatch-table-argnum dt))) + (let* ((proto (if non-dt + #'funcallable-trampoline + (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*)))) + (clear-gf-dispatch-table dt) + (setf (%gf-dispatch-table-argnum dt) multi-method-index) + (if encapsulated-dcode-cons ; and more? + (let ((old-gf (car encapsulated-dcode-cons))) + (if (not (typep old-gf 'generic-function)) + (error "Confused")) + ;(setf (uvref old-gf 0)(uvref proto 0)) + (setf (cdr encapsulated-dcode-cons) dcode)) + (progn + (setf (%gf-dcode gf) dcode) + (replace-function-code gf proto)))))) + (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar %find-classes% (make-hash-table :test 'eq)) + +(defun class-cell-typep (form class-cell) + (locally (declare (type class-cell class-cell)) + (let ((class (class-cell-class class-cell))) + (loop + (if class + (let* ((wrapper (if (%standard-instance-p form) + (instance.class-wrapper form) + (instance-class-wrapper form)))) + (return + (not (null (memq class (or (%wrapper-cpl wrapper) + (%inited-class-cpl (%wrapper-class wrapper)))))))) + (if (setq class (find-class (class-cell-name class-cell) nil)) + (setf (class-cell-class class-cell) class) + (return (typep form (class-cell-name class-cell))))))))) + + + +(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-cell (name create?) + (let ((cell (gethash name %find-classes%))) + (or cell + (and create? + (setf (gethash name %find-classes%) (make-class-cell name)))))) + + +(defun find-class (name &optional (errorp t) environment) + (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))) + (error "Class named ~S not found." name))))) + +(defun set-find-class (name class) + (clear-type-cache) + (let ((cell (find-class-cell name class))) + (when cell + (if (eq name (%class.name class)) + (setf (info-type-kind name) :instance)) + (setf (class-cell-class cell) class)) + class)) + + +;;; bootstrapping definition. real one is in "sysutils.lisp" + +(defun built-in-type-p (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) + (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 class))) + (declare (type class-cell cell)) + (let ((old-class (class-cell-class 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)) + (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)) + (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)))) +||# + + + +;;; 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)) + + +(defvar *t-class* (let* ((class (%cons-built-in-class 't)) + (wrapper (%cons-wrapper class (new-class-wrapper-hash-index))) + (cpl (list class))) + (setf (%class.cpl class) cpl) + (setf (%wrapper-cpl wrapper) cpl) + (setf (%class.own-wrapper class) wrapper) + (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-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))))) + (setq class (%cons-built-in-class name))) + (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)) + (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)) + +;;; 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)))) + (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-cpl wrapper) 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-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))) + +;; 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-built-in-class 'lock-acquisition *istruct-class*) + (make-built-in-class 'semaphore-notification *istruct-class*) + (make-built-in-class 'class-wrapper *istruct-class*) + ;; Compiler stuff, mostly + (make-built-in-class 'faslapi *istruct-class*) + (make-built-in-class 'var *istruct-class*) + (make-built-in-class 'afunc *istruct-class*) + (make-built-in-class 'lexical-environment *istruct-class*) + (make-built-in-class 'definition-environment *istruct-class*) + (make-built-in-class 'compiler-policy *istruct-class*) + (make-built-in-class 'deferred-warnings *istruct-class*) + (make-built-in-class 'ptaskstate *istruct-class*) + (make-built-in-class 'entry *istruct-class*) + (make-built-in-class 'foreign-object-domain *istruct-class*) + + + (make-built-in-class 'slot-id *istruct-class*) + (make-built-in-class 'value-cell) + (make-built-in-class 'restart *istruct-class*) + (make-built-in-class 'hash-table *istruct-class*) + (make-built-in-class 'readtable *istruct-class*) + (make-built-in-class 'pathname *istruct-class*) + (make-built-in-class 'random-state *istruct-class*) + (make-built-in-class 'xp-structure *istruct-class*) + (make-built-in-class 'lisp-thread *istruct-class*) + (make-built-in-class 'resource *istruct-class*) + (make-built-in-class 'periodic-task *istruct-class*) + (make-built-in-class 'semaphore *istruct-class*) + + (make-built-in-class 'type-class *istruct-class*) + + (defstatic *ctype-class* (make-built-in-class 'ctype *istruct-class*)) + (make-built-in-class 'key-info *istruct-class*) + (defstatic *args-ctype* (make-built-in-class 'args-ctype *ctype-class*)) + (make-built-in-class 'values-ctype *args-ctype*) + (make-built-in-class 'function-ctype *args-ctype*) + (make-built-in-class 'constant-ctype *ctype-class*) + (make-built-in-class 'named-ctype *ctype-class*) + (make-built-in-class 'cons-ctype *ctype-class*) + (make-built-in-class 'unknown-ctype (make-built-in-class 'hairy-ctype *ctype-class*)) + (make-built-in-class 'numeric-ctype *ctype-class*) + (make-built-in-class 'array-ctype *ctype-class*) + (make-built-in-class 'member-ctype *ctype-class*) + (make-built-in-class 'union-ctype *ctype-class*) + (make-built-in-class 'foreign-ctype *ctype-class*) + (make-built-in-class 'class-ctype *ctype-class*) + (make-built-in-class 'negation-ctype *ctype-class*) + (make-built-in-class 'intersection-ctype *ctype-class*) + + (make-built-in-class 'class-cell *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))) + + #+x8664-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-built-in-class 'logical-pathname (find-class 'pathname)) + + (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*)) + + #+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) + (%istruct 'foreign-object-domain index name recognize class-of classp + instance-class-wrapper class-own-wrapper slots-vector)) + + (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) + (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) + (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))) + (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 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*)) + #+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) + #-x8664-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) (or (find-class (%svref i 0) nil) *istruct-class*))) + (setf (%svref v target::subtag-basic-stream) + #'(lambda (b) (basic-stream.class b))) + (setf (%svref v target::subtag-instance) + #'%class-of-instance) + (setf (%svref v #+ppc-target target::subtag-symbol #+x86-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 + #+x86-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))) + #+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 + + +;;; Can't use typep at bootstrapping time. +(defun classp (x) + (or (and (typep x 'macptr) (foreign-classp x)) ; often faster + (let ((wrapper (standard-object-p x))) + (or + (and wrapper + (let ((super (%wrapper-class wrapper))) + (memq *class-class* (%inited-class-cpl super t)))))))) + +(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) +(defun union (l1 l2) + (dolist (e l1) + (unless (memq e l2) + (push e l2))) + l2) +) + +;; Stub to prevent errors when the user doesn't define types +(defun type-intersect (type1 type2) + (cond ((and (null type1) (null type2)) + nil) + ((equal type1 type2) + type1) + ((subtypep type1 type2) + type1) + ((subtypep type2 type1) + type2) + (t `(and ,type1 ,type2)) + ;(t (error "type-intersect not implemented yet.")) + )) + +(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) + (if errorp + (error "~s has no method for ~s ~s" + generic-function method-qualifiers specializers))) + (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)) + (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 ini targs)) + (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) + (find name slots :key #'%slot-definition-name)) + +(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))) + (%std-slot-vector-value (instance-slots instance) 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))) + ;; 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) + (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* ((class (class-of instance)) + (slotd (find-slotd slot-name (%class-slots class)))) + (if slotd + (slot-value-using-class class instance slotd) + (values (slot-missing class instance slot-name 'slot-value))))) + + + +(defmethod slot-unbound (class instance slot-name) + (declare (ignore class)) + (error 'unbound-slot :name slot-name :instance instance)) + + + +(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* ((class (class-of instance)) + (slotd (find-slotd name (%class-slots class)))) + (if slotd + (setf (slot-value-using-class class instance slotd) value) + (progn + (slot-missing class instance name 'setf value) + value)))) + +(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)))))) + +(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* ((class (class-of instance)) + (slotd (find-slotd name (%class-slots class)))) + (if slotd + (slot-boundp-using-class class instance slotd) + (values (slot-missing class instance name 'slot-boundp))))) + +(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 (or (standard-object-p instance) + (%class-own-wrapper (class-of instance))))) + (funcall (%wrapper-slot-id-value wrapper) instance slot-id))) + +(defun set-slot-id-value (instance slot-id value) + (let* ((wrapper (or (standard-object-p instance) + (%class-own-wrapper (class-of instance))))) + (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value))) + +;;; 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-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 'generic-function) + (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 (standard-generic-function-p instance) + (setq old-wrapper (gf.instance.class-wrapper instance))) + (unless old-wrapper + (report-bad-arg instance '(or standard-instance standard-generic-function)))) + (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))) + + +(defun compute-initargs-vector (instance class functions) + (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 (logbitp $lfbits-aok-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 + (if (standard-generic-function-p instance) + (setq wrapper (generic-function-wrapper instance)) + (when (typep instance 'funcallable-standard-object) + (setq wrapper (gf.instance.class-wrapper instance)))) + + (unless wrapper + (report-bad-arg instance '(or standard-object standard-generic-function)))) + (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 old-instance-slots)) + ;; 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-vector-pos)) + (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) + (error "No applicable method for args:~% ~s~% to ~s" args gf)) + + +(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)) + +(defun %compute-applicable-methods+ (gf &rest args) + (declare (dynamic-extent args)) + (%compute-applicable-methods* gf args)) + +(defun %compute-applicable-methods* (gf args) + (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 (class-of (car args-tail))))) + (dolist (m methods) + (if (%method-applicable-p m args cpls) + (push m res))) + (sort-methods res cpls (%gf-precedence-list gf)))))) + + +(defun %method-applicable-p (method args cpls) + (do* ((specs (%method-specializers method) (%cdr specs)) + (args args (%cdr args)) + (cpls cpls (%cdr cpls))) + ((null specs) t) + (let ((spec (%car specs))) + (if (typep spec 'eql-specializer) + (unless (eql (%car args) (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) + +(defmethod instance-class-wrapper (x) + (%class.own-wrapper (class-of x))) + +(defmethod instance-class-wrapper ((instance standard-object)) + (if (%standard-instance-p instance) + (instance.class-wrapper instance) + (if (typep instance 'macptr) + (foreign-instance-class-wrapper instance) + (%class.own-wrapper (class-of instance))))) + +(defmethod instance-class-wrapper ((instance standard-generic-function)) + (gf.instance.class-wrapper instance)) + + + + +(defun generic-function-wrapper (gf) + (unless (inherits-from-standard-generic-function-p (class-of gf)) + (%badarg gf 'standard-generic-function)) + (gf.instance.class-wrapper gf)) + +(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) (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/experimentation/later/source/level-1/l1-clos.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-clos.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-clos.lisp (revision 8058) @@ -0,0 +1,2209 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Copyright (C) 2002-2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-and-class-slotds (slotds) + (collect ((instance-slots) + (shared-slots)) + (dolist (s slotds (values (instance-slots) (shared-slots))) + (if (eq (%slot-definition-allocation s) :class) + (shared-slots s) + (instance-slots s))))) + + + +(defun direct-instance-and-class-slotds (class) + (extract-instance-and-class-slotds (%class-direct-slots class))) + +(defun effective-instance-and-class-slotds (class) + (extract-instance-and-class-slotds (%class-slots class))) + +(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 class-slots ((class class))) +(defmethod class-direct-slots ((class class))) +(defmethod class-default-initargs ((class class))) +(defmethod class-direct-default-initargs ((class class))) + +(defmethod direct-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys) + (unless (member allocation '(:instance :class)) + (report-bad-arg allocation '(member (:instance :class)))) + *standard-direct-slot-definition-class*) + +(defmethod effective-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys) + (unless (member allocation '(:instance :class)) + (report-bad-arg allocation '(member (:instance :class)))) + *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)) + +;;; 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))) + (type-specifier + (specifier-type `(and ,@(mapcar #'(lambda (d) + (or (%slot-definition-type d) + t)) + 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) + (extract-instance-and-class-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)))) + +(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) + +(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 + (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) + (typep class 'forward-referenced-class)) + +;;; This uses the primary class information to sort a class'es slots +(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) + (progn + (push class 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))))))))) + (scan-forward-refs original ()))) + + +(defmethod compute-class-precedence-list ((class class)) + (let* ((fwdref (class-has-a-forward-referenced-superclass-p class))) + (when fwdref + (error "~&Class ~s can't be finalized because at least one of its superclasses (~s) is a FORWARD-REFERENCED-CLASS." class fwdref))) + (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) + (not (class-has-a-forward-referenced-superclass-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))))) + (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)) + (declare (ignore slot-names)) + (if direct-superclasses-p + (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.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))) + +;;; 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) + (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) + (record-source-file name 'class) + ;; Maybe record source-file information for accessors as well + ;; We should probably record them as "accessors of the class", since + ;; there won't be any other explicit defining form associated with + ;; them. + (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 (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)) + (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 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)) + (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)) + :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 direct-slots :initform nil :initfunction ,#'false + :readers (class-direct-slots) + :writers ((setf class-direct-slots))) + (:name slots :initform nil :initfunction ,#'false + :readers (class-slots)) + (:name kernel-p :initform nil :initfunction ,#'false) + (:name direct-default-initargs :initform nil :initfunction ,#'false :readers (class-direct-default-initargs)) + (:name default-initargs :initform nil :initfunction ,#'false :readers (class-default-initargs)) + (: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 +(defclass method-combination (metaobject) + ((name :accessor method-combination-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) ()) + + +(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 (%wrapper-cpl wrapper) 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) 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)))) + +(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)) + (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) + + (replace-function-code instance *gf-proto*) + (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))) + + + +(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) + 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. + + + +(defmethod instance-class-wrapper ((instance funcallable-standard-object)) + (gf.instance.class-wrapper instance)) + +(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)) + (replace-function-code funcallable-instance #'funcallable-trampoline) + (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 OpenMCL 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) + +;;; 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))) + (when (or (eq dcode #'%%one-arg-dcode) + (eq dcode #'%%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)))))))) + +;;; 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* ((class (%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) + (%class-of-instance instance)) + class) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +;;; 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))) + (let* ((classes (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data)))) + (if (memq (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + classes) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +;;; 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 a single class +(defun reader-constant-location-inherited-from-single-class-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((defining-class (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data))) + (class (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)))) + (if (and class (memq defining-class (or (%class.cpl class) + (%inited-class-cpl class)))) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +;;; 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* ((location (%svref dt (1+ %gf-dispatch-table-first-data))) + (class (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance))) + (cpl (if class (or (%class.cpl class) (%inited-class-cpl class))))) + (if (dolist (defining-class (%svref dt %gf-dispatch-table-first-data)) + (when (memq defining-class cpl) (return t))) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + + +;;; 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)))) + +(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) + (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) + (clear-gf-dispatch-table dt) + (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 + (%svref dt (1+ %gf-dispatch-table-first-data)) location + (gf.dcode 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) #'reader-constant-location-dcode)) + ((null (cdr (setq classes (remove-subclasses-from-class-list classes)))) + ;; Lots of classes, all subclasses of a single class + (setf (%svref dt %gf-dispatch-table-first-data) + (car classes) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) + #'reader-constant-location-inherited-from-single-class-dcode)) + (t + ;; Multple classes. We should probably check + ;; to see they're disjoint + (setf (%svref dt %gf-dispatch-table-first-data) + classes + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode 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) #'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)))) + +(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)))) + +(defun %%one-arg-eql-method-hack-dcode (dt arg) + (let* ((mf (if (typep arg 'symbol) (get arg dt)))) + (if mf + (funcall mf 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) + (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. +(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 (null (car method-list)) + (values (cadr method-list) t) + ;; :around or :before methods, give up + (values nil nil))))) + +(defparameter *typecheck-slots-in-optimized-make-instance* nil) + + + + +;;; 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) + (ignorable) + (class-slot-inits) + (after-method-forms) + (forms)) + (flet ((generate-type-check (form type &optional spvar) + (if (null *typecheck-slots-in-optimized-make-instance*) + form + (if spvar + `(if ,spvar + (require-type ,form ',type) + (%slot-unbound-marker)) + `(require-type ,form ',type))))) + (dolist (slot slotds) + (let* ((initarg (car (slot-definition-initargs slot))) + (initfunction (slot-definition-initfunction slot)) + (initform (slot-definition-initform slot)) + (location (slot-definition-location slot)) + (name (slot-definition-name slot)) + (spvar nil) + (type (slot-definition-type slot)) + (initial-value-form (if initfunction + (if (self-evaluating-p initform) + initform + `(funcall ,initfunction)) + (progn + (when initarg + (setq spvar (make-symbol + (concatenate + 'string + (string name) + "-P")))) + `(%slot-unbound-marker))))) + (when spvar (ignorable spvar)) + (if initarg + (progn + (keys (list* + (list initarg name) + (let* ((default (assq initarg default-initargs))) + (if default + (destructuring-bind (form function) + (cdr default) + (if (self-evaluating-p form) + form + `(funcall ,function))) + initial-value-form)) + (if spvar (list spvar)))) + (if (consp location) + (class-slot-inits `(unless (eq ,name (%slot-unbound-marker)) (when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,(generate-type-check name type))))) + (forms `,(generate-type-check name type spvar)))) + (progn + (when initfunction + (setq initial-value-form (generate-type-check initial-value-form type))) + (if (consp location) + (if initfunction + (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,initial-value-form)))) + + (forms initial-value-form))))))) + (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)))) + ,@(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) + (setf (class-cell-instantiate cell) '%make-instance) + (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%)) + +;;; 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)) + (unless known-sealed-world + (cerror "Proceed, if it's known that no new classes or methods will be defined." + "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined.")) + (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 dcode-for-universally-applicable-singleton (gf) + (let* ((methods (generic-function-methods gf)) + (method (car methods))) + (when (and method + (null (cdr methods)) + (null (method-qualifiers 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/experimentation/later/source/level-1/l1-dcode.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-dcode.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-dcode.lisp (revision 8058) @@ -0,0 +1,1958 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + (error "New lambda list ~s of generic function ~s is not +congruent with lambda lists of existing methods." lambda-list gf))) + (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) + (declare (optimize (speed 3)(safety 0))) + (flet ((get-wrapper (arg) + (if (not (%standard-instance-p arg)) + (or (and (typep arg 'macptr) + (foreign-instance-class-wrapper arg)) + (and (generic-function-p arg) + (gf.instance.class-wrapper arg)) + (let* ((class (class-of arg))) + (or (%class.own-wrapper class) + (progn + (update-class class nil) + (%class.own-wrapper class))))) + (instance.class-wrapper arg)))) + (declare (inline get-wrapper)) + (let ((wrapper (get-wrapper arg))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance arg) + (setq wrapper (get-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))) + (flet ((get-wrapper (arg) + (if (not (%standard-instance-p arg)) + (or (and (typep arg 'macptr) + (foreign-instance-class-wrapper arg)) + (and (generic-function-p arg) + (gf.instance.class-wrapper arg)) + (let* ((class (class-of arg))) + (or (%class.own-wrapper class) + (progn + (update-class class nil) + (%class.own-wrapper class))))) + (instance.class-wrapper arg)))) + (declare (inline get-wrapper)) + (let ((wrapper (get-wrapper arg))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance arg) + (setq wrapper (get-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 val) + (setf (gf.dcode gf) val)) + +(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)) + +(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))))))) + +(defstatic *generic-function-class-wrapper* nil) +(defstatic *standard-generic-function-class-wrapper* nil) + +(defun 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))))) + (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) + (memq *generic-function-class* + (%inited-class-cpl (class-of thing))))))) + + +(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)) + +(defun %combined-method-methods (cm) + (combined-method.thing cm)) + +(defun %combined-method-dcode (cm) + ;(require-type cm 'combined-method) + (combined-method.dcode cm)) + + +; 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))) + (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; 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)))) + +(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))))) + + +(defun %%one-arg-dcode (dt arg) + (let ((method (%find-1st-arg-combined-method dt arg))) + (funcall method 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))) + + + +;;; 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))))) + + +(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 l)) + (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 () + (when magic + (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/experimentation/later/source/level-1/l1-error-signal.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-error-signal.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-error-signal.lisp (revision 8058) @@ -0,0 +1,145 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) + +(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)) + + (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 condition (condition-arg condition args 'simple-error)) + (signal condition) + (unless *interactive-streams-initialized* + (bug (format nil "Error during early application initialization:~% +~a" condition)) + (#_exit #$EX_SOFTWARE)) + (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/experimentation/later/source/level-1/l1-error-system.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-error-system.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-error-system.lisp (revision 8058) @@ -0,0 +1,1155 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + ((file-name :initarg :file-name :initform nil :accessor compiler-warning-file-name) + (stream-position :initform nil :accessor compiler-warning-stream-position) + (function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name) + (warning-type :initarg :warning-type :reader compiler-warning-warning-type) + (args :initarg :args :reader compiler-warning-args) + (nrefs :initform 1 :accessor compiler-warning-nrefs)) + (:report report-compiler-warning)) + +(define-condition style-warning (compiler-warning)) +(define-condition undefined-function-reference (style-warning)) +(define-condition macro-used-before-definition (compiler-warning)) +(define-condition invalid-arguments (style-warning)) +(define-condition invalid-arguments-global (style-warning)) + +(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 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 program-error (error)) +(define-condition simple-program-error (simple-condition program-error) + ((context :initarg :context :reader simple-program-error-context :initform nil))) + +(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 arguments provided, at most ~d accepted. " fn scaled-nargs max) + (format s "Too few arguments in call to ~s:~&~d arguments 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) p))))) + + +(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 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)) + (:report (lambda (c s) (format s "~S detected ~&performing ~S on ~:S" + (type-of c) + (arithmetic-error-operation c) + (arithmetic-error-operands c))))) + +(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))))) + +(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) + (error "~S is not a defined condition type name" name))) + +(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-homonym (name &optional test) + (let ((pname (and name (symbolp name) (symbol-name name))) + (other-name nil)) + (dolist (pkg (list-all-packages) other-name) + (let ((candidate (find-symbol pname pkg))) + (when (and candidate + (not (eq candidate name)) + (or (null test) (funcall test candidate))) + (when (and other-name (neq other-name candidate)) + (return nil)) ;; more than one, too complicated, give up + (setq other-name candidate)))))) + + +(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-variable (find-unique-homonym cell-name #'boundp))) + (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 () + :test (lambda (c) (and (or (null c) (eq c condition)) other-variable)) + :report (lambda (s) (format s "Use the value of ~s this time." other-variable)) + (symbol-value other-variable)) + (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-function (find-unique-homonym 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 () + :test (lambda (c) (and (or (null c) (eq c condition)) other-function)) + :report (lambda (s) (format s "Apply ~s to ~S this time." other-function args)) + (apply other-function 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))))) + + + + +; 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 $xnotfun 'call-special-operator-or-macro) + (cons $xaccessnth 'sequence-index-type-error) + (cons $ximproperlist 'improper-list) + (cons $xnospread 'cant-construct-arglist) + )) + + +(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 char (* * *)) + + )) + + +(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"))) + + + + Index: /branches/experimentation/later/source/level-1/l1-events.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-events.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-events.lisp (revision 8058) @@ -0,0 +1,237 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + +(defun force-break-in-listener (p) + (process-interrupt p + #'(lambda () + (let* ((condition (condition-arg "interrupt signal" nil 'simple-condition))) + (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 + #+ppc-target *fake-stack-frames* + #+x86-target (or (let* ((xcf (%current-xcf))) + (if xcf + (%%frame-backlink xcf))) + (%get-frame-ptr)) + condition) + (clear-input *terminal-io*)))))) + + + + +(defstatic *running-periodic-tasks* nil) + +(defun cmain () + (thread-handle-interrupts)) + +(defun select-interactive-abort-process () + (or *interactive-abort-process* + (let* ((sr (input-stream-shared-resource *terminal-input*))) + (if sr + (or (shared-resource-current-owner sr) + (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))))))) + +(defun housekeeping () + (progn + (handle-gc-hooks) + (unless *inhibit-abort* + (when (break-event-pending-p) + (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 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/experimentation/later/source/level-1/l1-files.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-files.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-files.lisp (revision 8058) @@ -0,0 +1,1336 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 "*;:"))) + +(defun native-to-directory-pathname (name) + (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) + (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 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." + (when (wild-pathname-p path) + (error 'file-error :error-type "Inappropriate use of wild pathname ~s" + :pathname 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)) + (native-to-pathname (%create-file path :if-exists if-exists + :create-directory create-directory))) +(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) (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 (< fd 0) + (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))) + + + +(defun pathname-host (thing) ; redefined later in this file + (declare (ignore thing)) + :unspecific) + +(defun pathname-version (thing) ; redefined later in this file + (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 (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 (host-namestring path) + (directory-namestring path) + (file-namestring path))) + +(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 nil "."))) + (if (or type version) + (%str-cat (case type + ((nil) ".") + (:wild ".*") + (t (%str-cat "." (%path-std-quotes type nil ".")))) + (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) + (if (neq host :unspecific) + (%cons-logical-pathname dir name type host version) + (%cons-pathname dir name type version))) + +(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 (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 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-sstring string start end) + (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 (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))) + (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 version) + (%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 make-pathname (&key (host nil host-p) + device + (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." + (declare (ignore device)) + (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))) + (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) + (%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)) + (default-dir (and defaults (pathname-directory defaults))) + (default-host (and defaults (pathname-host 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))))) + (if (and (pathnamep path) + (eq dir (%pathname-directory path)) + (eq nam path-name) + (eq typ (%pathname-type path)) + (eq host path-host) + (eq version (pathname-version path))) + path + (cons-pathname dir nam typ host version)))) + +(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-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)) + (cond ((typep (pathname thing) 'logical-pathname) :unspecific))) + + + +;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-sstring path) + #+no + (if (and (> end start) + (eql (schar sstr start) #\~)) + (setq sstr (tilde-expand (subseq sstr start end)) + start 0 + end (length sstr))) + (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end) + (unless (eq host :unspecific) (setq logical-p t)) + (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-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (if (eq host :unspecific) + nil + (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-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-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. +;; 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))) + (if (and file-type (neq file-type :unspecific)) + (values (probe-file full-name) file-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 fasl source) + (values true-source source source))) + (true-fasl + (values true-fasl fasl 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 file-name 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) + constructed-source-file + ;; 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*))) + (*loading-file-source-file* (namestring source-file))) ;reset by fasload to logical name stored in the file? + (declare (special *loading-files* *loading-file-source-file*)) + (unwind-protect + (progn + (when verbose + (format t "~&;Loading ~S..." *load-pathname*) + (force-output)) + (cond ((fasl-file-p file-name) + (flet ((attempt-load (file-name) + (multiple-value-bind (winp err) + (%fasload (native-translated-namestring file-name)) + (if (not winp) + (%err-disp err))))) + (let ((*fasload-print* print)) + (declare (special *fasload-print*)) + (setq constructed-source-file (make-pathname :defaults file-name :type (pathname-type *.lisp-pathname*))) + (when (equalp source-file *load-truename*) + (when (probe-file constructed-source-file) + (setq source-file constructed-source-file))) + (if (and source-file + (not (equalp source-file file-name)) + (probe-file source-file)) + ;;really need restart-case-if instead of duplicating code below + (restart-case + (attempt-load file-name) + #+ignore + (load-other () :report (lambda (x) (format s "load other file")) + (return-from + %load + (%load (choose-file-dialog) verbose print if-does-not-exist))) + (load-source + () + :report (lambda (s) + (format s "Attempt to load ~s instead of ~s" + source-file *load-pathname*)) + (return-from + %load + (%load source-file verbose print if-does-not-exist external-format)))) + ;;duplicated code + (attempt-load file-name))))) + (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)))) + (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*) + (while (neq eof-val (setq val (read stream nil eof-val))) + (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) + "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 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/experimentation/later/source/level-1/l1-format.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-format.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-format.lisp (revision 8058) @@ -0,0 +1,422 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 (function (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 (string *format-control-string*) char) + (prog* ((length *format-length*) (i *format-index*) (lastpos i)) + (declare (fixnum i length lastpos)) + (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-string string stream :start lastpos :end 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. +(defun format (stream control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (when (eq stream t) (setq stream *standard-output*)) + (when (null stream) + (return-from format + (with-output-to-string (x) + (apply #'format x control-string format-arguments)))) + (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)))) + +(defun 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) + (when (or colon atsign) (format-error "Flags 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) + (cond ((or (not repeat-count) + (and repeat-count (fixnump repeat-count) + (> repeat-count -1))) + (format-no-flags colon atsign) + (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) + (unless (eq repeat-count 0) + (fresh-line stream) + (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream)))) + +;Final version +(defformat #\~ format-~ (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream))) + +;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 + (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 cdr beyond end of list return :error" + (if (or (> count (list-length list)) (< count 0)) + nil ;:error + (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/experimentation/later/source/level-1/l1-init.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-init.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-init.lisp (revision 8058) @@ -0,0 +1,314 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 (floor #x8000 target::node-size) + "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") + + +(defconstant lambda-list-keywords + '(&OPTIONAL &REST &AUX &KEY &ALLOW-OTHER-KEYS &BODY &ENVIRONMENT &WHOLE) + "symbols which are magical in a lambda list") + + +(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 (type 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) +(defvar *record-source-file* nil) ; set in l1-utils. +(defvar *warn-if-redefine* nil) ; set in l1-utils. +(defparameter *level-1-loaded* nil) ; set t by l1-boot +(defparameter *save-definitions* nil) +(defparameter *save-local-symbols* t) + +(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)))) + (#_bzero p (* 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/experimentation/later/source/level-1/l1-io.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-io.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-io.lisp (revision 8058) @@ -0,0 +1,1949 @@ +;;; -*- Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + +(defun %new-ptr (size &optional clear-p) + (let* ((p (malloc size))) + (if (and clear-p (not (%null-ptr-p p))) + (#_bzero p size)) + p)) + + +;;;; ====================================================================== +;;;; Standard CL IO frobs + + +;;; 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 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 (real-print-stream output-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-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." + (let ((stream (real-print-stream output-stream))) + (write-string string stream :start start :end end) + (terpri 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 (real-print-stream 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* t) + +;;;; ====================================================================== + +(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 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 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)) + 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) + (stream-write-char stream #\space)) + (when thunk + (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 exp 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)))) + (%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)) + (stream-write-char stream delim) + (do* ((limit (length string)) + (i 0 (1+ i))) + ((= i limit)) + (declare (type fixnum last)) (declare (type fixnum limit) (type fixnum i)) + (let* ((char (char string i)) + (needs-escape? (%char-needs-escape-p char #\\ delim))) + (if needs-escape? + (stream-write-char stream #\\)) + (stream-write-char stream char))) + (stream-write-char stream delim)) + + +;;;; ---------------------------------------------------------------------- +;;;; 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) (type package package)) + (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))) + + +(defvar *pname-buffer* (%cons-pool "12345678901234567890")) + +(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) + (pool *pname-buffer*) + (outbuf (pool.data pool))) + (declare (fixnum outbuf-ptr) (simple-string outbuf)) + (setf (pool.data pool) nil) ; grab it. + (unless (and outbuf (>= (length outbuf) outbuf-len)) + (setq outbuf (make-array outbuf-len :element-type 'character))) + (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)) + (setf (pool.data pool) outbuf))))))) + +#| +(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)) + (pool *pname-buffer*) + (outbuf-ptr -1) + (outbuf (pool.data pool)) + (word-start t) + (offset 0)) + (declare (fixnum offset outbuf-ptr)) + (setf (pool.data pool) nil) + (unless (and outbuf (>= (length outbuf) end)) + (setq outbuf (make-array end :element-type 'character))) ; this may be fat string now - do we care? + (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) + (setf (pool.data pool) outbuf))) + + +;;;; ---------------------------------------------------------------------- +;;;; 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 + 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 (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)))) + +#+x8664-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) + ((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*) + 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 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." + (setq stream (real-print-stream 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/experimentation/later/source/level-1/l1-lisp-threads.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-lisp-threads.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-lisp-threads.lisp (revision 8058) @@ -0,0 +1,1109 @@ +;;; -*- Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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* + (#_sysconf #$_SC_CLK_TCK)) + +(defloadvar *ns-per-tick* + (floor 1000000000 *ticks-per-second*)) + +(defun %nanosleep (seconds nanoseconds) + (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*)))) + +(defloadvar *lisp-start-timeval* + (progn + (let* ((r (make-record :timeval))) + (#_gettimeofday r (%null-ptr)) + 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 (%null-ptr)) + (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) + nil)) + +(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) + +(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) + :unsigned-fullword cs-size + :unsigned-fullword vs-size + :unsigned-fullword ts-size + :address)))) + (declare (fixum 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)) + 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-exhausted-p (tcr) + (or (null tcr) + (eql tcr 0) + (unless (logbitp arch::tcr-flag-bit-awaiting-preset + (the fixnum (tcr-flags tcr))) + (let* ((vs-area (%fixnum-ref tcr target::tcr.vs-area))) + (declare (fixnum vs-area)) + (or (zerop vs-area) + (eq (%fixnum-ref vs-area target::area.high) + (%fixnum-ref tcr target::tcr.save-vsp))))))) + +(defun thread-exhausted-p (thread) + (or (null thread) + (tcr-exhausted-p (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. + (or (not (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending))) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp tcr) + (ff-call + (%kernel-import target::kernel-import-raise-thread-interrupt) + :address tcrp + :signed-fullword)))) + + + + + + +(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 most-positive-fixnum)) + (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* ((pthread (lisp-thread-os-thread thread))) + (when pthread + (setf (lisp-thread.tcr thread) nil + (lisp-thread.state thread) :exit) + (#_pthread_kill pthread #$SIGQUIT))))) + +;;; This returns the underlying pthread, whatever that is. +(defun lisp-thread-os-thread (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + #+linux-target + (let* ((pthread (#+32-bit-target %get-unsigned-long + #+64-bit-target %%get-unsigned-longlong + tcrp target::tcr.osid))) + (unless (zerop pthread) pthread)) + #+darwin-target + (let* ((pthread (%get-ptr tcrp target::tcr.osid))) + (unless (%null-ptr-p pthread) pthread))))) + +;;; 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)))) + +(defun %activate-tcr (tcr termination-semaphore allocation-quantum) + (if (and tcr (not (eql 0 tcr))) + (with-macptrs (tcrp s) + (%setf-macptr-to-object tcrp tcr) + (%setf-macptr s (%get-ptr tcrp target::tcr.activate)) + (unless (%null-ptr-p s) + (setf (#+64-bit-target %%get-unsigned-longlong + #+32-bit-target %get-unsigned-long + tcrp target::tcr.log2-allocation-quantum) + (or allocation-quantum (default-allocation-quantum))) + (setf (%get-ptr tcrp target::tcr.termination-semaphore) + (if termination-semaphore + (semaphore-value termination-semaphore) + (%null-ptr))) + (%signal-semaphore-ptr s) + 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 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) + (let* ((current (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 (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 (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*) + ;; Have to defer GCing, e.g., defer responding to a GC + ;; suspend request here (that also defers interrupts) + ;; We absolutely, positively can't take an exception + ;; in here, so don't even bother to typecheck on + ;; car/cdr etc. + (with-deferred-gc + (do ((spine (population-data *termination-population*) (cdr spine)) + (prev nil spine)) + ((null spine)) + (declare (optimize (speed 3) (safety 0))) + (let* ((head (car spine)) + (tail (cdr spine)) + (o (car head)) + (f (cdr head))) + (when (and (eq o object) + (or (null function-p) + (eq function f))) + (if prev + (setf (cdr prev) tail) + (setf (population-data *termination-population*) tail)) + (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 (%svref sym target::symbol.binding-index-cell)) + (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)))) Index: /branches/experimentation/later/source/level-1/l1-numbers.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-numbers.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-numbers.lisp (revision 8058) @@ -0,0 +1,955 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) + +(defun %cons-random-state (seed-1 seed-2) + #+32-bit-target + (gvector :istruct + 'random-state + seed-1 + seed-2) + #+64-bit-target + (gvector :istruct + 'random-state + (the fixnum (+ (the fixnum seed-2) + (the fixnum (ash (the fixnum seed-1) 16)))))) + +;;; random associated stuff except for the print-object method which +;;; is still in "lib;numbers.lisp" +(defun initialize-random-state (seed-1 seed-2) + (unless (and (fixnump seed-1) (%i<= 0 seed-1) (%i< seed-1 #x10000)) + (report-bad-arg seed-1 '(unsigned-byte 16))) + (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000)) + (report-bad-arg seed-2 '(unsigned-byte 16))) + (%cons-random-state seed-1 seed-2)) + +(defun make-random-state (&optional state) + "Make a random state object. If STATE is not supplied, return a copy + of the default random state. If STATE is a random state, then return a + copy of it. If STATE is T then return a random state generated from + the universal time." + (let* ((seed-1 0) + (seed-2 0)) + (if (eq state t) + (multiple-value-setq (seed-1 seed-2) (init-random-state-seeds)) + (progn + (setq state (require-type (or state *random-state*) 'random-state)) + (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state)))) + (%cons-random-state seed-1 seed-2))) + +(defun random-state-p (thing) (istruct-typep thing 'random-state)) + +;;; 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 ppc32-target (not darwinppc-target)) +(defun %single-float-expt! (b e result) + (declare (single-float b e result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-expt! (b e result) + (declare (single-float b e result)) + (with-stack-double-floats ((b2 b) + (e2 e) + (result2)) + (%double-float-expt! b2 e2 result2) + (%double-float->short-float result2 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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-sin! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-sin! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-sin! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-cos! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-cos! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-cos! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-acos! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-acos! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-acos! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-asin! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-asin! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-asin! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-cosh! (n result) + (declare (single-float n result)) + (ppc32::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_coshf n)) + (%sf-check-exception-1 'cosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-cosh! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-cosh! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+ppc32-target +(progn +#-darwinppc-target +(defun %single-float-log! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+darwinppc-target +(defun %single-float-log! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-log! n2 result2) + (%double-float->short-float result2 result))) +) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-tan! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-tan! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-tan! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-atan! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-atan! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-atan! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-atan2! (x y result) + (declare (single-float x y result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-atan2! (x y result) + (declare (single-float x y result)) + (with-stack-double-floats ((x2 x) + (y2 y) + (result2)) + (%double-float-atan2! x2 y2 result2) + (%double-float->short-float result2 result))) + +#+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 ppc32-target (not darwinppc-target)) +(defun %single-float-exp! (n result) + (declare (single-float n result)) + (ppc32::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 ppc32-target darwinppc-target) +(defun %single-float-exp! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-exp! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-sinh! (n result) + (declare (single-float n result)) + (ppc32::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_sinhf n)) + (%sf-check-exception-1 'sinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+(and darwinppc-target ppc32-target) +(defun %single-float-sinh! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-sinh! n2 result2) + (%double-float->short-float result2 result))) + +#+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))) + + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-tanh! (n result) + (declare (single-float n result)) + (ppc32::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_tanhf n)) + (%sf-check-exception-1 'tanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-tanh! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-tanh! n2 result2) + (%double-float->short-float result2 result))) + +#+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)) + +(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))) + + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-asinh! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-asinh! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-asinh! n2 result2) + (%double-float->short-float result2 result))) + +#+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)) + +(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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-acosh! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-acosh! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-acosh! n2 result2) + (%double-float->short-float result2 result))) + +#+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)) + +(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))) + +#+(and ppc32-target (not darwinppc-target)) +(defun %single-float-atanh! (n result) + (declare (single-float n result)) + (ppc32::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))) + +#+(and ppc32-target darwinppc-target) +(defun %single-float-atanh! (n result) + (declare (single-float n result)) + (with-stack-double-floats ((n2 n) + (result2)) + (%double-float-atanh! n2 result2) + (%double-float->short-float result2 result))) + +#+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/experimentation/later/source/level-1/l1-pathnames.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-pathnames.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-pathnames.lisp (revision 8058) @@ -0,0 +1,714 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (c) 2001 Clozure Associates. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) + (declare (dynamic-extent p)) + (%get-cstring (%get-kernel-global-ptr 'image-name p)))) + +(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-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)(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 ((foo-error (source from) + (error "Source ~S and from-wildname ~S do not match" source from))) + (let (r-host r-device r-directory r-name r-type r-version s-host f-host t-host) + (setq s-host (pathname-host source)) + (setq f-host (pathname-host from-wildname)) + (setq t-host (pathname-host to-wildname)) + (if (not (%host-component-match-p s-host f-host)) (foo-error 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)(foo-error 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))(foo-error 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))(foo-error 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))(foo-error 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 r-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-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. + (or (string-equal path-host wild-host) + (%component-match-p 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)) + (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))) + (case wildstr + (:wild (setq wildstr "*")) + (:wild-inferiors (setq wildstr "**"))) + (case pathstr + (:wild (setq pathstr "*")) + (:wild-inferiors (setq pathstr "**"))) + (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))))) + +(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))) + (when (eq p esc) + (when (eq (setq p-start (1+ p-start)) p-end) + (return nil)) + (setq p (%scharcode pattern p-start))) + (unless (eq p (%scharcode str s-start)) + (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* ((directory-containing-heap-image + (make-pathname :directory (pathname-directory (%realpath (heap-image-name))))) + (rpath (merge-pathnames + #+darwinppc-target "../Resources/ccl/" + #+linux-target "Resources/ccl/" + directory-containing-heap-image))) + (or (probe-file rpath) + directory-containing-heap-image))))) + + +(defun user-homedir-pathname (&optional host) + "Return the home directory of the user as a pathname." + (declare (ignore host)) + (let* ((native (get-user-home-dir (getuid)))) + (if native + (native-to-directory-pathname native)))) + + + +(defloadvar *user-homedir-pathname* (user-homedir-pathname)) + +(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))) + (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))))))) + +;;; 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 "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/experimentation/later/source/level-1/l1-processes.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-processes.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-processes.lisp (revision 8058) @@ -0,0 +1,685 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 :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)) + +(defmethod print-object ((p process) s) + (print-unreadable-object (p s :type t :identity t) + (format s "~a(~d) [~a]" (process-name p) + (process-serial-number p)(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." + (declare (ignore flavor)) + (let* ((p (make-instance + class + :name name + :thread (or thread + (new-thread name stack-size vstack-size tstack-size)) + :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))) + (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)))) + + +(defun process-whostate (p) + "Return a string which describes the status of a specified process." + (if (process-exhausted-p p) + "Exhausted" + (symbol-value-in-process '*whostate* p))) + +(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) + (symbol-value-in-tcr sym (process-tcr process))) + +(defun (setf symbol-value-in-process) (value sym process) + (setf (symbol-value-in-tcr sym (process-tcr process)) value)) + + +(defun process-enable (p &optional (wait 1)) + "Begin executing the initial function of a specified process." + (setq p (require-type p 'process)) + (not-in-current-process p 'process-enable) + (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) + p) + (cerror "Keep trying." + "Unable to enable process ~s; have been trying for ~s seconds." + p total-wait)))) + + +(defmethod (setf process-termination-semaphore) :after (new (p process)) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (process-tcr p)) + (unless (%null-ptr-p tcrp) + (setf (%get-ptr tcrp target::tcr.termination-semaphore) + (if new + (semaphore-value new) + (%null-ptr)))) + new)) + +(defun process-resume (p) + "Resume a specified process which had previously been suspended +by process-suspend." + (setq p (require-type p 'process)) + (%resume-tcr (process-tcr p))) + +(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.)") + (%suspend-tcr (process-tcr p)))) + +(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 +(defun process-preset (process function &rest args) + "Set the initial function and arguments of a specified process." + (let* ((p (require-type process 'process)) + (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 process))) + +(defun %process-preset-internal (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 process") + (abort () :report "Kill this process" (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) + ;; Enter the *initial-process* and have it finish us up + (without-interrupts + (if (eq kill :shutdown) + (progn + (setq *whostate* "Shutdown") + (add-to-shutdown-processes process))) + (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 + (%nanosleep 0 *ns-per-tick*))))) + + + +(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." + (yield)) + + +;;; 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))))) + + +(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*) + (prepare-to-quit) + (%set-toplevel thunk) + (fresh-line *stdout*) + (finish-output *stdout*) + (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 nil defaultp)) + (wait-on-semaphore (process-termination-semaphore p) nil "join-process") + (let ((result (process-result p))) + (cond ((car result) (values-list (cdr result))) + (defaultp default) + (t (error "Failed to join ~s" p))))) + + +(defmethod process-locks-held ((p process)) + #+lock-accounting + (copy-list (symbol-value-in-process '*locks-held* p))) + +(defmethod process-locks-pending ((p process)) + #+lock-accounting + (copy-list (symbol-value-in-process '*locks-pending* p))) Index: /branches/experimentation/later/source/level-1/l1-reader.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-reader.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-reader.lisp (revision 8058) @@ -0,0 +1,2954 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; 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) + ("Line_Separator" . #\u+2028) + ("Paragraph_Separator" . #\u+2029) + ("Replacement_Character" . #\u+fffd) + )) + (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 %initial-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))) + +(setq *readtable* %initial-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) %initial-readtable%)) + (setq to (if to + (readtable-arg to) + (%istruct 'readtable + (make-array 256 :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* ((fttab (rdtab.ttab from)) + (tttab (rdtab.ttab to))) + (%copy-ivector-to-ivector fttab 0 tttab 0 256)) + to) + +(declaim (inline %character-attribute)) + +(defun %character-attribute (char attrtab) + (declare (character char) + (type (simple-array (unsigned-byte 8) (256)) attrtab) + (optimize (speed 3) (safety 0))) + (let* ((code (char-code char))) + (declare (fixnum code)) + (if (< code 256) + (aref attrtab code) + ;; Should probably have an extension mechanism for things + ;; like NBS. + $cht_cnst))) + +;;; 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))))) + (if (and (= from-attr $cht_cnst) + (member to-char '(#\Newline #\Linefeed #\Page #\Return + #\Space #\Tab #\Backspace #\Rubout))) + (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) $cht_ill) + (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) 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 + (setf (uvref (rdtab.ttab readtable) (char-code char)) + (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 + (setf (uvref (rdtab.ttab readtable) (char-code char)) + (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 (cdr 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 ndots nondots)) + (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 + (%err-disp $XNOESYM (%string-from-token tb) 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 ... +(defun %parse-expression (stream firstchar dot-ok) + (let* ((readtable *readtable*) + (attrtab (rdtab.ttab readtable))) + (let* ((attr (%character-attribute firstchar attrtab))) + (declare (fixnum attr)) + (if (= 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))))))) + (declare (dynamic-extent vals) + (list vals)) + (if (null vals) + (values nil nil) + (values (car vals) t)))))) + + +#| +(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)) + (multiple-value-bind (val val-p) (%parse-expression stream firstch dot-ok) + (if val-p + (return (values val t)))))))) + + +(defun read-list (stream &optional nodots (termch #\))) + (let* ((dot-ok (cons nil nil)) + (head (cons nil nil)) + (tail head)) + (declare (dynamic-extent dot-ok head) + (list head tail)) + (if nodots (setq dot-ok nil)) + (multiple-value-bind (firstform firstform-p) + (%read-list-expression stream dot-ok termch) + (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) + (%read-list-expression stream dot-ok termch) + (if (not nextform-p) (return)) + (if (and dot-ok (eq nextform dot-ok)) ; just read a dot + (if (multiple-value-bind (lastform lastform-p) + (%read-list-expression stream nil termch) + (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)))))))) + (cdr head))) + +#| +(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)) + `(quote ,(read stream t nil t))))) + +(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 OpenMCL for Darwin, the value +of this variable is initially #\Return ; in OpenMCL 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*) + (let* ((lst (read-list stream t)) + (len (length lst)) + (vec (make-array len))) + (declare (list lst) (fixnum len) (simple-vector vec)) + (dotimes (i len vec) + (setf (svref vec i) (pop lst)))) + (locally + (declare (fixnum numarg)) + (do* ((vec (make-array numarg)) + (lastform) + (i 0 (1+ i))) + ((multiple-value-bind (form form-p) (%read-list-expression stream nil) + (if form-p + (setq lastform form) + (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)) + vec) + (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 &aux form) + (require-no-numarg char arg ) + (setq form (read stream t nil t)) + (unless *read-suppress* (apply #'complex form)))) + +(set-dispatch-macro-character + #\# + #\. + #'read-eval) + +;;; This has been deprecated. Why not nuke it ? +#-ansi-cl +(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))))))) + +;;; 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) + `(function ,(read stream t nil t))))) + +(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)) + (setq stream (input-stream-arg stream)) + (if recursive-p + (%read-form stream 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)) + (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 ENDCHAR, and return the objects as a list." + (setq char (require-type char 'character)) + (setq stream (input-stream-arg stream)) + (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)) (read stream t nil t)) + (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) + + + + +;;;arg=0 : read form, error if eof +;;;arg=nil : read form, eof-val if eof. +;;;arg=char : read delimited list +(defun %read-form (stream arg eof-val) + (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) (%parse-expression stream ch nil) + (if form-p + (if *read-suppress* + (return nil) + (return form))))))))) + + + + + + +;;;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 path (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)))) + (setq path (read 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) "")) + path))) + + + + + + Index: /branches/experimentation/later/source/level-1/l1-readloop-lds.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-readloop-lds.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-readloop-lds.lisp (revision 8058) @@ -0,0 +1,619 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + + + +(define-toplevel-command :break pop () "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" + (format t "~& (:C ) can be used to invoke one of the following restarts in this break loop:") + (let* ((r (apply #'vector (compute-restarts *break-condition*)))) + (dotimes (i (length r) (terpri)) + (format *debug-io* "~&~d. ~a" i (svref r i))))) + +;;; From Marco Baringer 2003/03/18 + +(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" + (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)))))) + + +(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 (n) "Choose restart " + (select-restart n)) + +(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 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) + +(defun check-toplevel-command (form) + (let* ((cmd (if (consp form) (car form) form)) + (args (if (consp form) (cdr form)))) + (if (keywordp cmd) + (dolist (g *active-toplevel-commands*) + (when + (let* ((pair (assoc cmd (cdr g)))) + (if pair + (progn (apply (cadr pair) args) + t))) + (return t)))))) + +(defparameter *quit-on-eof* nil) + +;;; 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) (print-listener-prompt stream t)))) + (let* ((*break-level* break-level) + (*last-break-level* break-level) + *loading-file-source-file* + *in-read-loop* + *** ** * +++ ++ + /// // / - + (eof-value (cons nil 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 path print-result) + (toplevel-read :input-stream input-stream + :output-stream output-stream + :prompt-function prompt-function + :eof-value eof-value) + (if (eq form eof-value) + (if (and (not *batch-flag*) + (not *quit-on-eof*) + (eof-transient-p (stream-device input-stream :input))) + (progn + (stream-clear-input input-stream) + (abort-break)) + (exit-interactive-process *current-process*)) + (or (check-toplevel-command form) + (let* ((values (toplevel-eval form path))) + (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*)) + (force-output output-stream) + (funcall prompt-function output-stream) + (read-toplevel-form input-stream eof-value)) + +(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 *loading-file-source-file*) + (setq +++ ++ ++ + + - - form) + (let* ((package *package*) + (values (multiple-value-list (cheap-eval-in-environment form nil)))) + (unless (eq package *package*) + (application-ui-operation *application* :note-current-package *package*)) + values)) + +(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)))) + +(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) + (if (%izerop *break-level*) + (%write-string "?" stream) + (format stream "~s >" *break-level*))) + (write-string " " stream) + (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 () + (print-call-history) + (quit -1)) + +(defun break-loop-handle-error (condition error-pointer) + (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))) + (%break-message "Error" condition error-pointer) + (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*)) + (with-terminal-input + (break-loop condition error-pointer)) + (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 string 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 (fp (%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 fp) + (with-terminal-input + (break-loop c fp)))) + +(defun %break-message (msg condition error-pointer &optional (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))) + (format s "~A ~A: " prefixchar msg) + (setf (indenting-string-output-stream-indent s) (column s)) + ;(format s "~A" condition) ; evil if circle + (report-condition condition s) + (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 + +(defun cbreak-loop (msg cont-string condition error-pointer) + (let* ((*print-readably* nil)) + (%break-message msg condition error-pointer) + (with-terminal-input + (restart-case (break-loop condition error-pointer) + (continue () :report (lambda (stream) (write-string cont-string stream)))) + (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 *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 frame-pointer) + "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)) + (let* ((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-toplevel-commands :break + (if *continuablep* + (let* ((*print-circle* *error-print-circle*) + (*print-level* 10) + (*print-length* 20) + ;(*print-pretty* nil) + (*print-array* nil)) + (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.") + (format t "~&> If continued: ~A~%" continue)) + (format t "~&> 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*)) + (let ((i 0)) + (format t "~&[Pretend that these are buttons.]") + (dolist (r (compute-restarts condition) i) + (format t "~&~a : ~A" i r) + (setq i (%i+ i 1))) + (fresh-line nil))) + +(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/experimentation/later/source/level-1/l1-readloop.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-readloop.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-readloop.lisp (revision 8058) @@ -0,0 +1,509 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-status 0)) + (unless (typep exit-status '(signed-byte 32)) + (report-bad-arg exit-status '(signed-byte 32))) + (let* ((ip *initial-process*) + (cp *current-process*)) + (when (process-verify-quit ip) + (process-interrupt ip + #'(lambda () + (process-exit-application *current-process* + #'(lambda () + (%set-toplevel nil) + (#__exit exit-status))))) + (unless (eq cp ip) + (process-kill cp))))) + + +(defglobal *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 + )) + + +(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 (eq (%svref env 0) '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))) + (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-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)) + +; This is different from AUGMENT-ENVIRONMENT. +; If "info" is a lambda expression, then +; record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr +; is the lambda expression iff the function named by "name" is +; declared/proclaimed INLINE in env +(defun note-function-info (name lambda-expression env) + (let ((definition-env (definition-environment env))) + (if definition-env + (let* ((already (assq (setq name (maybe-setf-function-name name)) + (defenv.defined definition-env))) + (info nil)) + (when (lambda-expression-p lambda-expression) + (multiple-value-bind (lfbits keyvect) (encode-lambda-list lambda-expression t) + (setq info (cons (cons lfbits keyvect) + (retain-lambda-expression name lambda-expression env))))) + (if already + (if info (%rplacd already info)) + (push (cons name info) (defenv.defined definition-env))))) + name)) + +; And this is different from FUNCTION-INFORMATION. +(defun retrieve-environment-function-info (name env) + (let ((defenv (definition-environment env))) + (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv))))) + +(defun maybe-setf-function-name (name) + (if (and (consp name) (eq (car name) 'setf)) + (setf-function-name (cadr name)) + name)) + +; 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)))))) + +(defun cheap-eval (form) + (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-in-environment (form env &aux sym) + (declare (resident)) + (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))) + (while (cdr body) + (cheap-eval-in-environment (pop body) base-env)) + (cheap-eval-in-environment (car body) base-env)))) + (if form + (cond ((symbolp form) + (multiple-value-bind (expansion win) (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)) + ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr 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 (%make-function nil sym env)))) + ((eq sym 'nfunction) + (verify-arg-count form 2 2) + (%make-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)) + (while (setq form (%cdr form)) + (setq sym (require-type (pop form) 'symbol)) + (multiple-value-bind (expansion expanded) + (macroexpand-1 sym env) + (if expanded + (setq val (cheap-eval-in-environment `(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) + (cheap-eval-in-environment (if (cheap-eval-in-environment test env) 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 + (cheap-eval-in-environment protected-form env) + (progn-in-env cleanup-forms env env))) + (funcall (%make-function nil `(lambda () (progn ,form)) env)))) + ((and (symbolp sym) (macro-function sym env)) + (if (eq sym 'step) + (let ((*compile-definitions* nil)) + (cheap-eval-in-environment (macroexpand-1 form env) env)) + (cheap-eval-in-environment (macroexpand-1 form env) env))) + ((or (symbolp sym) + (and (consp sym) (eq (%car sym) 'lambda))) + (let ((args nil)) + (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args)) + (apply #'call-check-regs (if (symbolp sym) sym (%make-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/experimentation/later/source/level-1/l1-sockets.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-sockets.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-sockets.lisp (revision 8058) @@ -0,0 +1,1527 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + WITH-OPEN-SOCKET))) + +;;; 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" + "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" + "WITH-OPEN-SOCKET")) + +(eval-when (:compile-toplevel :execute) + #+linuxppc-target + (require "PPC-LINUX-SYSCALLS") + #+linuxx8664-target + (require "X8664-LINUX-SYSCALLS") + #+darwinppc-target + (require "DARWINPPC-SYSCALLS") + #+darwinx8664-target + (require "DARWINX8664-SYSCALLS") + #+freebsdx8664-target + (require "X8664-FREEBSD-SYSCALLS") + ) + +(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))) + +(defvar *socket-error-identifiers* + (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)) + + +(declaim (inline socket-call)) +(defun socket-call (stream where res) + (if (< res 0) + (socket-error stream where res) + res)) + +(defun %hstrerror (h_errno) + (with-macptrs ((p (#_hstrerror (abs h_errno)))) + (if p + (%get-cstring p) + (format nil "Nameserver error ~d" (abs h_errno))))) + + + + +(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." + (when (< errno 0) + (setq errno (- errno))) + (if stream + (error (make-condition 'socket-error + :stream stream + :code errno + :identifier (getf *socket-error-identifiers* errno :unknown) + :situation where + ;; TODO: this is a constant arg, there is a way to put this + ;; in the class definition, just need to remember how... + :format-control "~a (error #~d) during ~a" + :format-arguments (list + (if nameserver-p + (%hstrerror errno) + (%strerror errno)) + errno where))) + (error (make-condition 'socket-creation-error + :code errno + :identifier (getf *socket-error-identifiers* errno :unknown) + :situation where + ;; TODO: this is a constant arg, there is a way to put this + ;; in the class definition, just need to remember how... + :format-control "~a (error #~d) during socket creation in ~a" + :format-arguments (list + (if nameserver-p + (%hstrerror 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. + +(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 :sockaddr_in.sin_addr.s_addr))) + (:port (ntohs (pref sockaddr :sockaddr_in.sin_port)))))))) + +(defun path-from-unix-address (addr) + (when (= #$AF_LOCAL (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)))) + +(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 (- #$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 :sockaddr_in.sin_addr.s_addr))) + (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))))) + +(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)) + +(defmethod local-filename ((socket socket)) + (local-socket-filename 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)) + +(defmethod remote-filename ((socket socket)) + (remote-socket-filename socket)) + +(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 + receive-timeout + send-timeout + &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)) + (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 (eq address-family :internet) + (when nodelay + (int-setsockopt fd + #+linux-target #$SOL_TCP + #+(or freebsd-target darwin-target) #$IPPROTO_TCP + #$TCP_NODELAY 1)) + (when (and receive-timeout (> receive-timeout 0)) + (timeval-setsockopt fd + #$SOL_SOCKET + #$SO_RCVTIMEO + receive-timeout)) + (when (and send-timeout (> send-timeout 0)) + (timeval-setsockopt fd + #$SOL_SOCKET + #$SO_SNDTIMEO + send-timeout)) + (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 :sockaddr_in.sin_addr.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) + (bind-unix-socket fd local-filename)) + (when (and nil *multiprocessing-socket-io*) + (socket-call socket "fcntl" (fd-set-flag fd #$O_NONBLOCK))))) + +;; 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) + receive-timeout send-timeout) + "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 receive-timeout send-timeout)) + (ecase address-family + ((:file) (apply #'make-file-socket keys)) + ((nil :internet) (apply #'make-ip-socket keys)))) + + + +(defun make-udp-socket (&rest keys &aux (fd -1)) + (unwind-protect + (let (socket) + (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 &allow-other-keys &aux (fd -1)) + (unwind-protect + (let (socket) + (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 &allow-other-keys &aux (fd -1)) + (unwind-protect + (let (socket) + (setq fd (socket-call nil "socket" (c_socket #$PF_LOCAL #$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 %socket-connect (fd addr addrlen) + (let* ((err (c_connect fd addr addrlen))) + (declare (fixnum err)) + (when (eql err (- #$EINPROGRESS)) + (process-output-wait fd) + (setq err (- (int-getsockopt fd #$SOL_SOCKET #$SO_ERROR)))) + (unless (eql err 0) (socket-error nil "connect" err)))) + +(defun inet-connect (fd host-n port-n) + (rlet ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET + (pref sockaddr :sockaddr_in.sin_port) port-n + (pref sockaddr :sockaddr_in.sin_addr.s_addr) host-n) + (%socket-connect fd sockaddr (record-length :sockaddr_in)))) + +(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)))) + + +(defun make-tcp-stream-socket (fd &rest keys + &key remote-host + remote-port + &allow-other-keys) + (inet-connect fd + (host-as-inet-host remote-host) + (port-as-inet-port remote-port "tcp")) + (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) (receive-timeout 0) &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 + :interactive (zerop receive-timeout))))) + +(defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream) sharing basic (auto-close t) &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)))) + +(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 socket) + (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) + (or (eql res (- #$ENETDOWN)) + (eql res (- #+linux-target #$EPROTO + #+(or darwin-target freebsd-target) #$EPROTOTYPE)) + (eql res (- #$ENOPROTOOPT)) + (eql res (- #$EHOSTDOWN)) + (eql res (- #+linux-target #$ENONET + #+(or darwin-target freebsd-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 ((old (socket-call socket "fcntl" (fd-get-flags fd)))) + (unwind-protect + (progn + (socket-call socket "fcntl" (fd-set-flags fd (logior old #$O_NONBLOCK))) + (_accept fd t)) + (socket-call socket "fcntl" (fd-set-flags fd old)))))))) + +(defun accept-socket-connection (socket wait stream-create-function) + (let ((listen-fd (socket-device socket)) + (fd -1)) + (unwind-protect + (progn + (setq fd (socket-accept listen-fd wait socket)) + (cond ((>= fd 0) + (prog1 (apply stream-create-function fd (socket-keys socket)) + (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) + (: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.) 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)) + (accept-socket-connection socket wait #'make-tcp-stream)) + +(defmethod accept-connection ((socket file-listener-socket) &key (wait t)) + (accept-socket-connection socket wait #'make-file-socket-stream)) + +(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) + #+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 :sockaddr_in.sin_addr.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 :sockaddr_in.sin_addr.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 :sockaddr_in.sin_addr.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." + (if values + (values (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr)) + (_inet_ntoa (htonl addr)))) + +(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 millis) + (milliseconds timeout) + (rlet ((valptr :timeval :tv_sec seconds :tv_usec millis)) + (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))))) + +#+(or darwin-target linux-target) +(defloadvar *h-errno-variable-address* nil) +#+linux-target +(defloadvar *h-errno-function-address* nil) + +(defun h-errno-location () + #+darwin-target + ;; As of Tiger, Darwin doesn't seem to have grasped the concept + ;; of thread-local storage for h_errno. + (or *h-errno-variable-address* + (setq *h-errno-variable-address* (foreign-symbol-address "_h_errno"))) + ;; Supported versions of FreeBSD seem to have grasped that concept. + #+freebsd-target + (#_ __h_error) + #+linux-target + ;; Current versions of Linux support thread-specific h_errno, + ;; but older versions may not. + (if *h-errno-function-address* + (ff-call *h-errno-function-address* :address) + (or *h-errno-variable-address* + (let* ((entry (foreign-symbol-entry "__h_errno_location"))) + (if entry + (ff-call (setq *h-errno-function-address* entry) :address) + (setq *h-errno-variable-address* + (foreign-symbol-address "h_errno"))))))) + + +#+(or darwin-target freebsd-target) +(defun c_gethostbyaddr (addr) + (rlet ((addrp :unsigned)) + (setf (pref addrp :unsigned) addr) + (without-interrupts + (let* ((hp (#_gethostbyaddr addrp (record-length :unsigned) #$AF_INET))) + (declare (dynamic-extent hp)) + (if (not (%null-ptr-p hp)) + (%get-cstring (pref hp :hostent.h_name)) + (values nil (pref (h-errno-location) :signed))))))) + +#+linux-target +(defun c_gethostbyaddr (addr) + (rlet ((hostent :hostent) + (hp (* (struct :hostent))) + (herr :signed) + (addrp :unsigned)) + (setf (pref addrp :unsigned) addr) + (do* ((buflen 1024 (+ buflen buflen))) () + (declare (fixnum buflen)) + (%stack-block ((buf buflen)) + (let* ((res (#_gethostbyaddr_r addrp (record-length :unsigned) #$AF_INET + hostent buf buflen hp herr))) + (declare (fixnum res)) + (unless (eql res #$ERANGE) + (return + (if (and (eql res 0) (not (%null-ptr-p (%get-ptr hp)))) + (%get-cstring (pref (%get-ptr hp) :hostent.h_name)) + (values nil (- (pref herr :signed))))))))))) + +#+(or darwin-target freebsd-target) +(defun c_gethostbyname (name) + (with-cstrs ((name (string name))) + (without-interrupts + (let* ((hp (#_gethostbyname name))) + (declare (dynamic-extent hp)) + (if (not (%null-ptr-p hp)) + (%get-unsigned-long + (%get-ptr (pref hp :hostent.h_addr_list))) + (values nil (pref (h-errno-location) :signed))))))) + +#+linux-target +(defun c_gethostbyname (name) + (with-cstrs ((name (string name))) + (rlet ((hostent :hostent) + (hp (* (struct :hostent))) + (herr :signed)) + (do* ((buflen 1024 (+ buflen buflen))) () + (declare (fixnum buflen)) + (%stack-block ((buf buflen)) + (let* ((res (#_gethostbyname_r name hostent buf buflen hp herr))) + (declare (fixnum res)) + (unless (eql res #$ERANGE) + (return + (if (eql res 0) + (%get-unsigned-long + (%get-ptr (pref (%get-ptr hp) :hostent.h_addr_list))) + (values nil (- (pref herr :signed)))))))))))) + +(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))))) + +#+linuxppc-target +(defun _inet_ntoa (addr) + (rlet ((addrp :unsigned)) + (setf (pref addrp :unsigned) addr) + (with-macptrs ((p)) + (%setf-macptr p (#_inet_ntoa addrp)) + (unless (%null-ptr-p p) (%get-cstring p))))) + +;;; On all of these platforms, the argument is a (:struct :in_addr), +;;; a single word that should be passed by value. The FFI translator +;;; seems to lose the :struct, so just using #_ doesn't work (that +;;; sounds like a bug in the FFI translator.) +#+(or darwin-target linuxx8664-target freebsd-target) +(defun _inet_ntoa (addr) + (with-macptrs ((p)) + (%setf-macptr p (external-call #+darwin-target "_inet_ntoa" + #-darwin-target "inet_ntoa" + :unsigned-fullword addr + :address)) + (unless (%null-ptr-p p) (%get-cstring p)))) + + +(defun _inet_aton (string) + (with-cstrs ((name string)) + (rlet ((addr :in_addr)) + (let* ((result #+freebsd-target (#___inet_aton name addr) + #-freebsd-target (#_inet_aton name addr))) + (unless (eql result 0) + (pref addr :in_addr.s_addr)))))) + +(defun c_socket_1 (domain type protocol) + #-linuxppc-target + (syscall syscalls::socket domain type protocol) + #+linuxppc-target + (rlet ((params (:array :unsigned-long 3))) + (setf (paref params (:* :unsigned-long) 0) domain + (paref params (:* :unsigned-long) 1) type + (paref params (:* :unsigned-long) 2) protocol) + (syscall syscalls::socketcall 1 params))) + +(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)) + + +(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_LOCAL) + (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)))))))) + +(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) + #+(or darwin-target linuxx8664-target freebsd-target) + (progn + #+(or darwin-target freebsd-target) + (setf (pref sockaddr :sockaddr_in.sin_len) addrlen) + (syscall syscalls::bind sockfd sockaddr addrlen)) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) sockaddr + (%get-long params 8) addrlen) + (syscall syscalls::socketcall 2 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) sockaddr + (%%get-unsigned-longlong params 16) addrlen) + (syscall syscalls::socketcall 2 params)))) + +(defun c_connect (sockfd addr len) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::connect sockfd addr len) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) addr + (%get-long params 8) len) + (syscall syscalls::socketcall 3 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) addr + (%%get-unsigned-longlong params 16) len) + (syscall syscalls::socketcall 3 params)))) + +(defun c_listen (sockfd backlog) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::listen sockfd backlog) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 8)) + (setf (%get-long params 0) sockfd + (%get-long params 4) backlog) + (syscall syscalls::socketcall 4 params)) + #+ppc64-target + (%stack-block ((params 16)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%%get-unsigned-longlong params 8) backlog) + (syscall syscalls::socketcall 4 params)))) + +(defun c_accept (sockfd addrp addrlenp) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::accept sockfd addrp addrlenp) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) addrp + (%get-ptr params 8) addrlenp) + (syscall syscalls::socketcall 5 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) addrp + (%get-ptr params 16) addrlenp) + (syscall syscalls::socketcall 5 params)))) + +(defun c_getsockname (sockfd addrp addrlenp) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::getsockname sockfd addrp addrlenp) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) addrp + (%get-ptr params 8) addrlenp) + (syscall syscalls::socketcall 6 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) addrp + (%get-ptr params 16) addrlenp) + (syscall syscalls::socketcall 6 params)))) + +(defun c_getpeername (sockfd addrp addrlenp) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::getpeername sockfd addrp addrlenp) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) addrp + (%get-ptr params 8) addrlenp) + (syscall syscalls::socketcall 7 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) addrp + (%get-ptr params 16) addrlenp) + (syscall syscalls::socketcall 7 params)))) + +(defun c_socketpair (domain type protocol socketsptr) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::socketpair domain type protocol socketsptr) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 16)) + (setf (%get-long params 0) domain + (%get-long params 4) type + (%get-long params 8) protocol + (%get-ptr params 12) socketsptr) + (syscall syscalls::socketcall 8 params)) + #+ppc64-target + (%stack-block ((params 32)) + (setf (%%get-unsigned-longlong params 0) domain + (%%get-unsigned-longlong params 8) type + (%%get-unsigned-longlong params 16) protocol + (%get-ptr params 24) socketsptr) + (syscall syscalls::socketcall 8 params)))) + + + +(defun c_sendto (sockfd msgptr len flags addrp addrlen) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::sendto sockfd msgptr len flags addrp addrlen) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 24)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) msgptr + (%get-long params 8) len + (%get-long params 12) flags + (%get-ptr params 16) addrp + (%get-long params 20) addrlen) + (syscall syscalls::socketcall 11 params)) + #+ppc64-target + (%stack-block ((params 48)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) msgptr + (%%get-unsigned-longlong params 16) len + (%%get-unsigned-longlong params 24) flags + (%get-ptr params 32) addrp + (%%get-unsigned-longlong params 40) addrlen) + (syscall syscalls::socketcall 11 params)))) + +(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::recvfrom sockfd bufptr len flags addrp addrlenp) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 24)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) bufptr + (%get-long params 8) len + (%get-long params 12) flags + (%get-ptr params 16) addrp + (%get-ptr params 20) addrlenp) + (syscall syscalls::socketcall 12 params)) + #+ppc64-target + (%stack-block ((params 48)) + (setf (%get-long params 0) sockfd + (%get-ptr params 8) bufptr + (%get-long params 16) len + (%get-long params 24) flags + (%get-ptr params 32) addrp + (%get-ptr params 40) addrlenp) + (syscall syscalls::socketcall 12 params)))) + +(defun c_shutdown (sockfd how) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::shutdown sockfd how) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 8)) + (setf (%get-long params 0) sockfd + (%get-long params 4) how) + (syscall syscalls::socketcall 13 params)) + #+ppc64-target + (%stack-block ((params 16)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%%get-unsigned-longlong params 8) how) + (syscall syscalls::socketcall 13 params)))) + +(defun c_setsockopt (sockfd level optname optvalp optlen) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::setsockopt sockfd level optname optvalp optlen) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 20)) + (setf (%get-long params 0) sockfd + (%get-long params 4) level + (%get-long params 8) optname + (%get-ptr params 12) optvalp + (%get-long params 16) optlen) + (syscall syscalls::socketcall 14 params)) + #+ppc64-target + (%stack-block ((params 40)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%%get-unsigned-longlong params 8) level + (%%get-unsigned-longlong params 16) optname + (%get-ptr params 24) optvalp + (%%get-unsigned-longlong params 32) optlen) + (syscall syscalls::socketcall 14 params)))) + +(defun c_getsockopt (sockfd level optname optvalp optlenp) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::getsockopt sockfd level optname optvalp optlenp) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 20)) + (setf (%get-long params 0) sockfd + (%get-long params 4) level + (%get-long params 8) optname + (%get-ptr params 12) optvalp + (%get-ptr params 16) optlenp) + (syscall syscalls::socketcall 15 params)) + #+ppc64-target + (%stack-block ((params 40)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%%get-unsigned-longlong params 8) level + (%%get-unsigned-longlong params 16) optname + (%get-ptr params 24) optvalp + (%get-ptr params 32) optlenp) + (syscall syscalls::socketcall 15 params)))) + +(defun c_sendmsg (sockfd msghdrp flags) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::sendmsg sockfd msghdrp flags) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) msghdrp + (%get-long params 8) flags) + (syscall syscalls::socketcall 16 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) msghdrp + (%%get-unsigned-longlong params 16) flags) + (syscall syscalls::socketcall 16 params)))) + +(defun c_recvmsg (sockfd msghdrp flags) + #+(or darwin-target linuxx8664-target freebsd-target) + (syscall syscalls::recvmsg sockfd msghdrp flags) + #+linuxppc-target + (progn + #+ppc32-target + (%stack-block ((params 12)) + (setf (%get-long params 0) sockfd + (%get-ptr params 4) msghdrp + (%get-long params 8) flags) + (syscall syscalls::socketcall 17 params)) + #+ppc64-target + (%stack-block ((params 24)) + (setf (%%get-unsigned-longlong params 0) sockfd + (%get-ptr params 8) msghdrp + (%%get-unsigned-longlong params 16) flags) + (syscall syscalls::socketcall 17 params)))) + + +;;; 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)))) + +(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 (pref addr :sockaddr_in.sin_addr.s_addr) + :netmask (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)))))) + + +(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)) + (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/experimentation/later/source/level-1/l1-sort.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-sort.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-sort.lisp (revision 8058) @@ -0,0 +1,166 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-1/l1-streams.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-streams.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-streams.lisp (revision 8058) @@ -0,0 +1,5752 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + #+linuxppc-target + (require "PPC-LINUX-SYSCALLS") + #+linuxx8664-target + (require "X8664-LINUX-SYSCALLS") + #+darwinppc-target + (require "DARWINPPC-SYSCALLS") + #+darwinx8664-target + (require "DARWINX8664-SYSCALLS") + #+freebsdx8664-target + (require "X8664-FREEBSD-SYSCALLS")) + +;;; + +(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)) + +;;; 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-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))))) + + + + + + + + + + + + + +(defloadvar *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) + (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) + #+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 (pointer vector) + (ccl::%make-heap-ivector subtag size-in-octets element-count) + (values pointer vector 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 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 '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 + (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 nil fixnum)) ;position of cursor + (device -1 :type 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) + (reserved3 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*) + (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 (* 5 size)) 0)) + (end (min (+ idx (* 5 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)) + (bufsize (io-buffer-size out)) + (buffer (io-buffer-buffer out))) + (declare (fixnum written bufsize)) + (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)) + (avail (- bufsize 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 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)) + (bufsize (io-buffer-size out)) + (buffer (io-buffer-buffer out))) + (declare (fixnum written bufsize col) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (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)) + (avail (- bufsize index))) + (declare (fixnum index avail count)) + (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-element)) + +(defun %ioblock-write-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 0 count 0)) + (setf (aref (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-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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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 0 count 0)) + (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-strng 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-strng 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-strng 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-strng 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-strng 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 need)) + (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 (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 idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +(defun %ioblock-close (ioblock) + (let* ((stream (ioblock-stream ioblock))) + (funcall (ioblock-close-function ioblock) stream ioblock) + (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))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; 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-input-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-input-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-input-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-char 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) '%ioblock-untyi) + (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)))))))) + +(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)))))))) + + +(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 + &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) *current-process*)) + (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) + (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination) + (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ in-size-in-octets insize) 2)))) + ))) + (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 (or share-buffers-p outsize) + (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))) + 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 (find-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) + (or (nth-value 6 (%fstat fd)) *elements-per-buffer*)) + + +;;; 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) + (elements-per-buffer (optimal-buffer-size fd)) + (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) + (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))) + (if auto-close + (terminate-when-unreachable stream + (lambda (stream) + (close stream :abort 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 :utf32-be #+little-endian-target :utf32-le :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))) + (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 0 nil nil nil nil nil) + (gvector :basic-stream 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))) + (if (eq b :eof) + (return i) + (rplaca tail b))))) + + + + + +(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))) + (if (eq b :eof) + (return i) + (setf (uvref vector i) 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)) + + +(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 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-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)) + +(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) + (error "~s is not an output stream." s)))) + + + + +;;; 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)) + +(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream)) + +(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) + +;;; Should only be used for a stream whose class is exactly +;;; *string-output-stream-class* +(defun %close-string-output-stream (stream ioblock) + (when (eq (basic-stream.class stream) + *string-output-stream-class*) + (without-interrupts + (setf (ioblock-stream ioblock) (pool.data %string-output-stream-ioblocks%) + (pool.data %string-output-stream-ioblocks%) ioblock)))) + +(defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys) + (declare (dynamic-extent keys)) + (let* ((recycled (and stream + (eq (basic-stream.class stream) + *string-output-stream-class*) + (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-charpos data) 0 + (string-output-stream-ioblock-index data) 0)) + 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 + :device nil + :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 + :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))) + +(defmethod stream-force-output ((stream string-output-stream)) nil) + +(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.")) + (%%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 (+ 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) + (let* ((char (schar string src))) + (if (eql char #\Newline) + (setq nlpos 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 () + (%%make-string-output-stream *string-output-stream-class* + (make-string 40) + '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-array len + :element-type 'character + :fill-pointer 0 + :adjustable nil) + '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)) + + + +(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.class stream) *indenting-string-output-stream-class*)) + (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) (basic-stream.class 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)) + +(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* (basic-stream.class 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-ioblock s)) + (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 5) start) (min (+ idx 5) 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 + :device nil + :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) (basic-stream.class 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 (ioblock-owner ioblock)))) + +(defmethod stream-owner ((stream basic-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (ioblock-owner ioblock)))) + + +(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 interactive-stream-p ((stream buffered-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (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 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) + #+freebsd-target + (fd-input-available-p fd 0) + #-freebsd-target + (rlet ((arg (* :char) (%null-ptr))) + (when (zerop (syscall syscalls::ioctl fd #$FIONREAD 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) + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-input-wait fd) + (- #$ETIMEDOUT))) + +(defun process-input-wait (fd &optional ticks) + "Wait until input is available on a given file-descriptor." + (let* ((wait-end (if ticks (+ (get-tick-count) ticks)))) + (loop + ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the + ;; thread receives an interrupt) before a timeout is + ;; reached. + (when (fd-input-available-p fd ticks) + (return t)) + ;; 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 ticks + (let* ((now (get-tick-count))) + (if (and wait-end (>= now wait-end)) + (return) + (setq ticks (- wait-end now)))))))) + + +(defun process-output-would-block (fd) + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-output-wait fd) + (- #$ETIMEDOUT))) + +(defun process-output-wait (fd) + "Wait until output is possible on a given file descriptor." + (loop + (when (fd-ready-for-output-p fd nil) + (return t)))) + + + + + + +(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 ticks) + (rletZ ((tv :timeval)) + (ticks-to-timeval ticks tv) + (%stack-block ((infds *fd-set-size*)) + (fd-zero infds) + (fd-set fd infds) + (let* ((res (syscall syscalls::select (1+ fd) infds (%null-ptr) (%null-ptr) + (if ticks tv (%null-ptr))))) + (> res 0))))) + +(defun fd-ready-for-output-p (fd &optional ticks) + (rletZ ((tv :timeval)) + (ticks-to-timeval ticks tv) + (%stack-block ((outfds *fd-set-size*)) + (fd-zero outfds) + (fd-set fd outfds) + (let* ((res (#_select (1+ fd) (%null-ptr) outfds (%null-ptr) + (if ticks tv (%null-ptr))))) + (> res 0))))) + +(defun fd-urgent-data-available-p (fd &optional ticks) + (rletZ ((tv :timeval)) + (ticks-to-timeval ticks tv) + (%stack-block ((errfds *fd-set-size*)) + (fd-zero errfds) + (fd-set fd errfds) + (let* ((res (#_select (1+ fd) (%null-ptr) (%null-ptr) errfds + (if ticks tv (%null-ptr))))) + (> res 0))))) + +;;; 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))) + (setf (io-buffer-idx buf) 0 + (io-buffer-count buf) 0 + (ioblock-eof ioblock) nil) + (when (or read-p (stream-listen s)) + (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-finish-output s)) + (let* ((fd (ioblock-device ioblock))) + (when fd + (setf (ioblock-device ioblock) nil) + (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* ((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 (elements-per-buffer *elements-per-buffer*) encoding) + (let* ((s (make-fd-stream fd + :elements-per-buffer elements-per-buffer + :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) + (elements-per-buffer *elements-per-buffer*) + (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 + elements-per-buffer + class + external-format + sharing + basic)) + (retry-open () + :report (lambda (stream) (format stream "Retry opening ~s" filename)) + nil)))) + + + + + +(defun gen-file-name (path) + (let* ((date (file-write-date path)) + (tem-path (merge-pathnames (make-pathname :name (%integer-to-string date) :type "tem" :defaults nil) path))) + (loop + (when (not (probe-file tem-path)) (return tem-path)) + (setf (%pathname-name tem-path) (%integer-to-string (setq date (1+ date))))))) + +(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 *terminal-io*))))) + (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) eof-value) + (read-toplevel-form (symbol-value (synonym-stream-symbol stream)) eof-value)) + +(defmethod read-toplevel-form ((stream two-way-stream) eof-value) + (if (typep stream 'echo-stream) + (call-next-method) + (read-toplevel-form (two-way-stream-input-stream stream) eof-value))) + +(defmethod read-toplevel-form :after ((stream echoing-two-way-stream) eof-value) + (declare (ignore eof-value)) + (stream-set-column (two-way-stream-output-stream stream) 0)) + +(defmethod read-toplevel-form ((stream input-stream) + eof-value) + (loop + (let* ((*in-read-loop* nil) + (first-char (peek-char t stream nil eof-value)) + (form + (cond ((eq first-char #\:) + (read-command-or-keyword stream eof-value)) + ((eq first-char eof-value) eof-value) + (t (read stream nil eof-value))))) + (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) + eof-value) + (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 column (&optional stream) + (let* ((stream (real-print-stream stream))) + (stream-line-column stream))) + +(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))) + + +; end of L1-streams.lisp Index: /branches/experimentation/later/source/level-1/l1-symhash.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-symhash.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-symhash.lisp (revision 8058) @@ -0,0 +1,831 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + (rplaca names (new-package-name new-name 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 (gvector :package + (%new-package-hashtable internal-size) + (%new-package-hashtable external-size) + nil + nil + (list (new-package-name name)) + nil + (make-read-write-lock) + nil))) + (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))) + (if ok-name (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))) + +;;; Somewhat saner interface to %find-symbol +(defun %findsym (string package) + (%find-symbol string (length string) package)) + +(defun intern (str &optional (package *package*)) + "Return a symbol in PACKAGE having the specified NAME, creating it + if necessary." + (setq package (pkg-arg 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 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 etab 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))))) + (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) + (setq %all-packages% (nremove package %all-packages%)) + (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/experimentation/later/source/level-1/l1-sysio.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-sysio.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-sysio.lisp (revision 8058) @@ -0,0 +1,902 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 :type fixnum) ; current io position in octets + (fileeof 0 :type fixnum) ; 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)) + ((= 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)))))))) + + + +(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 OpenMCL +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 characer 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) + (if (file-ioblock-untyi-char file-ioblock) + (1- curpos) + curpos) + (progn + (setf (file-ioblock-untyi-char file-ioblock) nil) + (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) + (if (file-ioblock-untyi-char file-ioblock) + (1- curpos) + curpos) + (let* ((incount (io-buffer-count outbuf))) + (unless (= newpos 0) + (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) + (when (file-ioblock-untyi-char file-ioblock) + (setf (file-ioblock-untyi-char file-ioblock) nil) + (if (> curidx 0) + (decf curpos))) + (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) + (setf (file-ioblock-untyi-char file-ioblock) nil) + (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)))) + (curpos (ioblock-octets-to-elements + file-ioblock + (file-octet-filepos file-ioblock)))) + (unless (eql newpos curpos) + (error "Expected newpos to be ~d, fd is at ~d" newpos curpos)) + (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) + ;; Check to see if we're where we think we should be. + (let* ((curpos (file-ioblock-octet-pos file-ioblock))) + (unless (eql curpos (file-octet-filepos file-ioblock)) + (error "Expected newpos to be ~d, fd is at ~d" + curpos (file-octet-filepos file-ioblock))) + (let* ((n (fd-stream-force-output stream file-ioblock count finish-p))) + (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) + 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) + (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock)) + (output-file-force-output stream file-ioblock count finish-p)) + + +;;; 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-untyi-char file-ioblock) nil) + (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) + (%ioblock-input-file-length file-ioblock newlen))) + +(defmethod stream-length ((stream basic-file-input-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (%ioblock-input-file-length file-ioblock newlen)))) + + +(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen) + (with-stream-ioblock-output (file-ioblock s :speedy t) + (%ioblock-output-file-length file-ioblock newlen))) + + +(defmethod stream-length ((stream basic-file-output-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (file-ioblock) + (%ioblock-output-file-length file-ioblock newlen)))) + +(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen) + (with-stream-ioblock-input (file-ioblock s :speedy t) + (%ioblock-output-file-length file-ioblock newlen))) + +(defmethod stream-length ((stream basic-file-io-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (%ioblock-output-file-length file-ioblock newlen)))) + +(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 + (if abort + (progn + (setf (ioblock-dirty ioblock) nil) + (fd-stream-close s ioblock) + (unix-rename (namestring actual-filename) (probe-file-x filename))) + (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))) + + + + +(defun make-file-stream (filename + direction + element-type + if-exists + if-does-not-exist + elements-per-buffer + class + external-format + sharing + basic) + + (let* ((temp-name 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)))) + (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))) + ((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)) + (setq native-truename (%create-file filename)) + (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 + :elements-per-buffer elements-per-buffer + :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))) + (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) temp-name) + (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/experimentation/later/source/level-1/l1-typesys.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-typesys.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-typesys.lisp (revision 8058) @@ -0,0 +1,4252 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) + +(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) (find-class name nil))) + (error "Cannot redefine type ~S" name)) + (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 '*) + `(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))) + + +(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 #'(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 (%svref x 0) + '#.(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))) + + +;;; ### 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) + (make-constant-ctype :type (specifier-type type))) + + +;;; 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) + (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)) + (setf (args-ctype-required result) (mapcar #'specifier-type required)) + (setf (args-ctype-optional result) (mapcar #'specifier-type optional)) + (setf (args-ctype-rest result) (if restp (specifier-type 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 (specifier-type (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 '*)) + (let ((res (make-function-ctype + :returns (values-specifier-type result)))) + (if (eq args '*) + (setf (function-ctype-wild-args res) t) + (parse-args-types args res)) + res)) + +(def-type-translator values (&rest values) + (let ((res (make-values-ctype))) + (parse-args-types values res) + (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-type 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)))) +;;; 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) + (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 + (multiple-value-bind (first rest) + (if (intersection-ctype-p (car types)) + (values (car (intersection-ctype-types (car types))) + (append (cdr (intersection-ctype-types (car types))) + (cdr types))) + (values (car types) (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 (or (function-ctype-p type2) (eq function type2))) + (csubtypep type2 function) + (not (csubtypep function type2))) + (and (function-ctype-p type2) + (not (or (function-ctype-p type1) (eq 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))) + +;;; 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) + (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes + + (let ((spec (type-expand orig))) + (cond + ((and (not (eq spec orig)) + (info-type-builtin spec))) + ((eq (info-type-kind spec) :instance) + (let* ((class-ctype (%class.ctype (find-class spec)))) + (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 + (let* ((lspec (if (atom spec) (list spec) spec)) + (fun (info-type-translator (car lspec)))) + (cond (fun (funcall fun lspec nil)) + ((or (and (consp spec) (symbolp (car spec))) + (symbolp spec)) + (when *type-system-initialized* + (signal 'parse-unknown-type :specifier spec)) + ;; + ;; Inhibit caching... + nil) + (t + (error "Bad thing to be a type specifier: ~S." spec))))))))) + +(eval-when (:compile-toplevel :execute) + (defconstant type-cache-size (ash 1 12)) + (defconstant type-cache-mask (1- type-cache-size))) + +;;; 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 (%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 (%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)))) + ;; 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)) + + (defun clear-type-cache () + (%init-misc 0 type-cache-specs) + (%init-misc 0 type-cache-ctypes) + (incf ncleared) + nil) + + (defun values-specifier-type (spec) + (if (typep spec 'class) + (let* ((class-ctype (%class.ctype spec))) + (or (class-ctype-translation class-ctype) class-ctype)) + (if locked + (or (values-specifier-type-internal spec) + (make-unknown-ctype :specifier spec)) + (unwind-protect + (progn + (setq locked t) + (if (or (symbolp spec) + (and (consp spec) (symbolp (car 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))) + (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))) + (setq locked nil))))) + + (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) + (let ((res (values-specifier-type x))) + (when (values-ctype-p res) + (signal-program-error "VALUES type illegal in this context:~% ~S" x)) + res)) + +(defun single-value-specifier-type (x) + (let ((res (specifier-type x))) + (if (eq res *wild-type*) + *universal-type* + res))) + +(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) + (istruct-typep x 'hairy-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) + (let* ((not-type (specifier-type typespec)) + (spec (type-specifier not-type))) + (cond + ;; canonicalize (NOT (NOT FOO)) + ((and (listp spec) (eq (car spec) 'not)) + (specifier-type (cadr spec))) + ;; 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)))) + (intersection-ctype-types not-type)))) + ((union-ctype-p not-type) + (apply #'type-intersection + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)))) + (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)) + (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)))) + *universal-type*) + (make-cons-ctype + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-ctype-cdr-ctype not-type))))))) + ((not (eq (cons-ctype-car-ctype not-type) *universal-type*)) + (make-cons-ctype + (specifier-type `(not ,(type-specifier + (cons-ctype-car-ctype not-type)))) + *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)))))) + (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) + (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))) + (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-type 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) + (specialize-array-type + (make-array-ctype :dimensions (check-array-dimensions dimensions) + :complexp :maybe + :element-type (specifier-type element-type)))) + +(def-type-translator simple-array (&optional element-type dimensions) + (specialize-array-type + (make-array-ctype :dimensions (check-array-dimensions dimensions) + :element-type (specifier-type element-type) + :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) + (apply #'type-union + (mapcar #'specifier-type 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) + (apply #'type-intersection + (mapcar #'specifier-type + 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 '*)) + (make-cons-ctype (specifier-type car-type-spec) + (specifier-type cdr-type-spec))) + +(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-type 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 (%svref x 0) + '(args-ctype values-ctype function-ctype)))) + +(defun function-ctype-p (x) (istruct-typep x 'function-ctype)) +(defun valuec-ctype-p (x) (istruct-typep x 'values-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) + (if (memq class2 (class-direct-superclasses class1)) + (values t t) + (if (class-has-a-forward-referenced-superclass-p class1) + (values nil nil) + (let ((supers (%inited-class-cpl class1))) + (if (memq class2 supers) + (values t t) + (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 class2) + (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) + (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)) + (values (not (null (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)) + (header-p (= typecode target::subtag-arrayH))) + (or (eq (array-ctype-dimensions type) '*) + (and (null (cdr ctype-dimensions)) (not header-p)) + (and header-p + (let* ((rank (%svref object target::arrayH.rank-cell))) + (declare (fixnum rank)) + (and (= 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))) + ((= i rank) t) + (unless (or (eq (car want) '*) + (= (car want) got)) + (return nil))))))) + (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 extended-string (&optional size) + (declare (ignore size)) + 'nil) + +(deftype simple-extended-string (&optional size) + (declare (ignore size)) + 'nil) + +(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-double-float-vector (&optional size) + `(simple-array double-float (,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-fixnum-vector (&optional size) + `(simple-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) +) + + +(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 OpenMCL'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)) + +) ; 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))) + (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/experimentation/later/source/level-1/l1-unicode.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-unicode.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-unicode.lisp (revision 8058) @@ -0,0 +1,6305 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006 Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + + +(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 + ;; 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) + ) + +(defconstant byte-order-mark #\u+feff) +(defconstant byte-order-mark-char-code (char-code byte-order-mark)) +(defconstant swapped-byte-order-mark #\u+fffe) +(defconstant swapped-byte-order-mark-char-code (char-code swapped-byte-order-mark)) + + +(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 start)) + (values 0 0))) + +(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start) + (declare (ignore pointer start)) + 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 + "An 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))) + (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) + (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))) (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) + (if (= i end) (values nchars i))) + (declare (fixnum i)) + (let* ((code (aref vector i)) + (nexti (+ i (cond ((< code #x80) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + (t 4))))) + (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) + ) + + +;;; 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))) + + +(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)) + + +(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) + + +;;; 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 len 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 p)) + (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) + ) + +;;; 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 len 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 p)) + (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) + ) + +;;; 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)) + (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* ((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 (+ idx noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i len 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)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum p 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 nunits 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 p)) + (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 + #'utf-16-octets-in-string + :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) + (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 i)) + (nchars 0)) + ((> j end) + (if (= i 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) + (let* ((swap (when (>= noctets 2) + (case (%get-unsigned-word pointer (+ start start)) + (#.byte-order-mark-char-code + (incf start 2) + (decf noctets 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf start 2) + (decf noctets 2) + t) + (t #+little-endian-target t))))) + (do* ((i start) + (nchars 0 (1+ nchars))) + ((>= i noctets) + (if (= i noctets) nchars)) + (let* ((code (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code)) + (if swap (setq code (%swap-u16 code))) + (incf i + (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4))))))) + :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) + ) + + +(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)) + + +;;; 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 len 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 + (nfunction + native-ucs-2-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start (1+ i)) + (j (+ i 2) (+ i 2)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + native-ucs-2-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (ignore pointer)) + (values (floor noctets 2) (+ start noctets)))) + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + ) + +;;; 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 len 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 + (nfunction + reversed-ucs-2-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start (1+ i)) + (j (+ i 2) (+ i 2)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + reversed-ucs-2-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (ignore pointer)) + (values (floor noctets 2) (+ start noctets)))) + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + ) + +(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)) + (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 len 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)) + (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 + #'ucs-2-octets-in-string + :length-of-vector-encoding-function + (nfunction + ucs-2-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start (1+ i)) + (j (+ i 2) (+ i 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) + (when (> noctets 1) + (case (%get-unsigned-word pointer ) + (#.byte-order-mark-char-code + (incf start 2) + (decf noctets 2)) + (#.swapped-byte-order-mark-char-code + (incf start 2) + (decf noctets 2)))) + (values (floor noctets 2) (+ start noctets)))) + :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) + ) + + +(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 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) + (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 :utf32-le + #+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 len 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 (1+ i)) + (j (+ i 4) (+ i 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 (floor noctets 4) (+ start noctets)))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :nul-encoding #(0 0 0 0) + ) + +;;; 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 len 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 (1+ i)) + (j (+ i 4) (+ i 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 (floor noctets 4) (+ start noctets)))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :nul-encoding #(0 0 0 0) + ) + +(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 '(:utf-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)) + (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 len 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)) + + (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 + #'ucs-4-octets-in-string + :length-of-vector-encoding-function + (nfunction + utf-32-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start (1+ i)) + (j (+ i 2) (+ i 2)) + (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 1) + (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 (floor noctets 4) (+ start noctets)))) + :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) + ) + +(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 (unsgigned-byte 8) (*)))) + (funcall (character-encoding-length-of-vector-encoding-function encoding) + vector + start + (- end start))) + + +(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)))))))) + + + + + +;;; 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/experimentation/later/source/level-1/l1-utils.lisp =================================================================== --- /branches/experimentation/later/source/level-1/l1-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/l1-utils.lisp (revision 8058) @@ -0,0 +1,1287 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + + +(setq *warn-if-redefine-kernel* nil) + +(setq *warn-if-redefine* nil) +(setq *record-source-file* t) + +;;; Kludge for record-source-file bootstrapping + +; Set T by l1-boot.lisp +(setq *level-1-loaded* nil) + +(%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name)) + +(%fhave '%source-files (qlfun bootstrapping-%source-files (name) + (get name 'bootstrapping-source-files))) +(%fhave '%set-source-files (qlfun bootstrapping-%set-source-files (name value) + (put name 'bootstrapping-source-files value))) + + + + + +; real one is in setf.lisp +(%fhave '%setf-method (qlfun bootstripping-setf-fsname (spec) + spec nil)) + +; this new thing breaks for case of a function being defined in non-file place +; use some euphemism for that such as t or "{No file}" +; something is broken (probably) here calling assq with garbage + + +(defun source-file-or-files (symbol type setf-p method) + (let ((source-files-info (%source-files symbol)) + assoc-pair files) + (cond ((null (consp source-files-info)) + (values source-files-info + nil + (if (and source-files-info (eq type 'function)(not setf-p)) source-files-info))) + (t (setq assoc-pair (assq type (if setf-p + (cdr (assq 'setf source-files-info)) + source-files-info))) + (if (neq type 'method) + (setq files assoc-pair) + (setq files + (do* ((lst (cdr assoc-pair) (cdr lst)) + (clst (car lst)(car lst))) + ((null lst) nil) + (when (consp clst) + (when (or (eq method (car clst)) ; method is a place holder for q's and s's + (and (methods-congruent-p method (car clst)) + ; below avoids clutter + (rplaca clst method))) + (return clst)))))) + (values source-files-info assoc-pair files))))) + + +;;; warn if defining in no file iff previously defined in a file +;;; (i.e. dont warn every time something gets redefined in the +;;; listener) fix to not to bitch if file is anywhere in list name is +;;; function-name or (method-name (class-names)) or ((setf +;;; method-name) (class-names)) store('method (method file file) +;;; (method file file) ...) if type is 'method we expect name to be +;;; an actual method Remember to smash old methods with newer methods +;;; to avoid clutter - done + +(defun physical-pathname-p (file)(declare (ignore file)) nil) ; redefined later + + +;(%defvar *enqueued-window-title* nil) + +(defun booted-probe-file (file) + (declare (ignore file)) + nil) + +(queue-fixup + (defun booted-probe-file (file) + (probe-file file))) + +(defun record-source-file (name def-type + &optional (file-name *loading-file-source-file*)) + (let (symbol setf-p method old-file) + (flet ((same-file (x y) + (or (eq x y) + ;; funny because equal not defined before us + (and x + y + (or (equal x y) + (equal + (or (booted-probe-file x) (full-pathname x)) + (or (booted-probe-file y) (full-pathname y)))))))) + (when (and *record-source-file* ) ;file-name) + (when (and file-name (physical-pathname-p file-name)) + (setq file-name (namestring (back-translate-pathname file-name))) + (cond ((equalp file-name *last-back-translated-name*) + (setq file-name *last-back-translated-name*)) + (t (setq *last-back-translated-name* file-name)))) + (when (eq t def-type) (report-bad-arg def-type '(not (eql t)))) + (cond ((eq def-type 'method) + (setq method name symbol (%method-name name) name nil)) + ((consp name) + (cond ((neq (car name) 'setf) + (warn "record-source-file hates ~s" name)) + (t (setq symbol name)))) + ((symbolp name) (setq symbol name))) + (cond ((and (consp symbol)(eq (car symbol) 'setf)) + (let ((tem (%setf-method (cadr symbol)))) + (if tem + (setq symbol tem) + (progn (setq symbol (cadr symbol)) + (setq setf-p t)))))) + ;; assoc-pair is e.g. (function file1 ...) or (class . file) + ;; or (method (method-object file1 ...) ...) or (method + ;; (method-object . file) ...) + (when (symbolp symbol) ; avoid boot problems - you thought + (multiple-value-bind (source-files-info assoc-pair files) + (source-file-or-files symbol def-type setf-p method) + (setq old-file + (cond ((consp files) + (if (consp (cdr files)) (cadr files) (cdr files))) + (t files))) + (unless + (if (or (not (consp files))(not (consp (cdr files)))) + (same-file old-file file-name) + (do ((lst (cdr files)(cdr lst))) + ((null (consp lst)) nil) + (when (same-file file-name (car lst)) + (rplaca lst (cadr files)) + (rplaca (cdr files) file-name) + (return t)))) + (when (and *warn-if-redefine* + (neq def-type 'method) ; This should be more specific + (cond ((eq def-type 'function) + (and (fboundp name) old-file)) + (t old-file))) + (warn " ~S ~S previously defined in: ~A + is now being redefined in: ~A~%" + def-type + name + (or old-file "{Not Recorded}") + (or file-name "{No file}"))) + (if (consp files) + (%rplacd files (cons file-name + (if (consp (cdr files))(cdr files)(list (cdr files))))) + + (if assoc-pair + (%rplacd assoc-pair (cons (if (eq def-type 'method) + `(,method . , file-name) + file-name) + (if (consp (%cdr assoc-pair)) + (%cdr assoc-pair) + (list (%cdr assoc-pair))))) + (%set-source-files + symbol + (cond ((and (eq def-type 'function) + (null setf-p) + (not (consp source-files-info))) + (if (null old-file) + file-name + `((function ,file-name ,old-file)))) + (t + (when (and source-files-info + (not (consp source-files-info))) + (setq source-files-info `((function . , source-files-info)))) + (let ((thing (if (neq def-type 'method) + `(,def-type . ,file-name) + `(,def-type (,method . ,file-name))))) + (cons (if setf-p `(setf ,thing) thing) source-files-info)))))))) + )))))) + +(record-source-file 'record-source-file 'function) + + +(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) + +(%fhave 'find-unencapsulated-definition #'identity) + +(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 (similar-as-constants-p (%sym-global-value var) 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-extended-string +simple-vector +single-float +standard-char +stream +string +#| +lisp:string-char +|# +symbol +t +unsigned-byte +vector +)) + +(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 (proclaim-ftype (cons 'function (cddr spec)) (cadr spec))) + (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right... + (if (memq (%car spec) *cl-types*) + (apply #'proclaim-type spec) + (warn "Unknown declaration specifier(s) in ~S" spec)))))) + +(defun proclaim-type (type &rest vars) + (declare (dynamic-extent vars)) + (dolist (var vars) + (if (symbolp var) + (let ((spec (assq var *nx-proclaimed-types*))) + (if spec + (rplacd spec type) + (push (cons var type) *nx-proclaimed-types*))) + (warn "Invalid type declaration for ~S" var)))) + +(defun proclaim-ftype (ftype &rest names) + (declare (dynamic-extent names)) + (unless *nx-proclaimed-ftypes* + (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq))) + (dolist (name names) + (setf (gethash (ensure-valid-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)) + (dolist (sym vars) (%proclaim-special sym))) + + +(defun proclaim-notspecial (&rest vars) + (declare (dynamic-extent 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))) + (dolist (name names) + (setq name (ensure-valid-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)) + (dolist (sym syms) + (setq *nx-known-declarations* + (adjoin sym *nx-known-declarations* :test 'eq)))) + +(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))) + (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)))))) + +;;; avoid hanging onto beezillions of pathnames +(defvar *last-back-translated-name* nil) +(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* #\\ + "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) + (let* ((len (length string))) + (cond ((typep string 'simple-string) + (%copy-ivector-to-ptr string 0 ptr 0 len)) + ((typep string 'string) + (multiple-value-bind (data offset) + (array-data-and-offset string) + (%copy-ivector-to-ptr data offset ptr 0 len))) + (t (report-bad-arg string 'string))) + (setf (%get-byte ptr len) 0) + 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 + (dotimes (i (uvsize vector)) (declare (fixnum i))(uvset vector i initial-element)) + (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) + + +;end of L1-utils.lisp + Index: /branches/experimentation/later/source/level-1/level-1.lisp =================================================================== --- /branches/experimentation/later/source/level-1/level-1.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/level-1.lisp (revision 8058) @@ -0,0 +1,103 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 #'toplevel-loop) (set-user-environment t) (toplevel)) + + + + Index: /branches/experimentation/later/source/level-1/linux-files.lisp =================================================================== --- /branches/experimentation/later/source/level-1/linux-files.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/linux-files.lisp (revision 8058) @@ -0,0 +1,1432 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + #+linuxppc-target + (require "PPC-LINUX-SYSCALLS") + #+linuxx8664-target + (require "X8664-LINUX-SYSCALLS") + #+darwinppc-target + (require "DARWINPPC-SYSCALLS") + #+darwinx8664-target + (require "DARWINX8664-SYSCALLS") + #+(and freebsd-target x8664-target) + (require "X8664-FREEBSD-SYSCALLS") + ) + + +(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)) + ;; 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.). + ;; In any case, the use if %GET-CSTRING here is wrong ... + #-darwin-target + (%get-cstring pointer)) + +(defun nanoseconds (n) + (unless (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (check-type n (real 0 #xffffffff))) + (multiple-value-bind (q r) + (floor n) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000000000)))) + (values q r))) + +(defun milliseconds (n) + (unless (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (check-type n (real 0 #xffffffff))) + (multiple-value-bind (q r) + (floor n) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000)))) + (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") + (multiple-value-bind (secs millis) (milliseconds duration) + (let* ((now (get-internal-real-time)) + (stop (+ now + (* secs 1000) + millis))) + (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-millis) + (floor diff 1000) + (setq secs remaining-seconds + millis remaining-millis))))))))))) + +(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 bufsize) + ;; Return N < 0, if error + ;; N < bufsize: success, string is of length n + ;; N > bufsize: buffer needs to be larger. + (let* ((p (#_getcwd buf bufsize))) + (declare (dynamic-extent p)) + (if (%null-ptr-p p) + (let* ((err (%get-errno))) + (if (eql err (- #$ERANGE)) + (+ bufsize bufsize) + err)) + (dotimes (i bufsize (+ bufsize bufsize)) + (when (eql 0 (%get-byte buf i)) + (return i)))))) + + +(defun current-directory-name () + "Look up the current working directory of the OpenMCL process; unless +it has been changed, this is the directory OpenMCL was started in." + (flet ((try-getting-dirname (bufsize) + (%stack-block ((buf bufsize)) + (let* ((len (%os-getcwd buf bufsize))) + (cond ((< len 0) (%errno-disp len bufsize)) + ((< len bufsize) + (setf (%get-unsigned-byte buf len) 0) + (values (get-foreign-namestring buf) len)) + (t (values nil len))))))) + (do* ((string nil) + (len 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) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname)) + (syscall syscalls::chdir dirname))) + +(defun %mkdir (name mode) + (let* ((name name) + (len (length name))) + (when (and (> len 0) (eql (char name (1- len)) #\/)) + (setq name (subseq name 0 (1- len)))) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) + (syscall syscalls::mkdir name mode)))) + +(defun %rmdir (name) + (let* ((last (1- (length name)))) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) + (when (and (>= last 0) + (eql (%get-byte name last) (char-code #\/))) + (setf (%get-byte name last) 0)) + (syscall syscalls::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." + (with-cstrs ((ckey key) + (cvalue value)) + (#_setenv ckey cvalue (if overwrite 1 0)))) + +(defun setuid (uid) + "Attempt to change the current user ID (both real and effective); +fails unless the OpenMCL process has super-user privileges or the ID +given is that of the current user." + (syscall syscalls::setuid uid)) + +(defun setgid (uid) + "Attempt to change the current group ID (both real and effective); +fails unless the OpenMCL process has super-user privileges or the ID +given is that of a group to which the current user belongs." + (syscall syscalls::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. + +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :stat.st_mode) + (pref stat :stat.st_size) + #+linux-target + (pref stat :stat.st_mtim.tv_sec) + #-linux-target + (pref stat :stat.st_mtimespec.tv_sec) + (pref stat :stat.st_ino) + (pref stat :stat.st_uid) + (pref stat :stat.st_blksize)) + (values nil nil nil nil nil nil nil))) + + +(defun %%stat (name stat) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) + (%stat-values + #+linux-target + (#_ __xstat #$_STAT_VER_LINUX cname stat) + #-linux-target + (syscall syscalls::stat cname stat) + stat))) + +(defun %%fstat (fd stat) + (%stat-values + #+linux-target + (#_ __fxstat #$_STAT_VER_LINUX fd stat) + #-linux-target + (syscall syscalls::fstat fd stat) + stat)) + +(defun %%lstat (name stat) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) + (%stat-values + #+linux-target + (#_ __lxstat #$_STAT_VER_LINUX cname stat) + #-linux-target + (syscall syscalls::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. +(defun %stat (name &optional link-p) + (rlet ((stat :stat)) + (if link-p + (%%lstat name stat) + (%%stat name stat)))) + +(defun %fstat (fd) + (rlet ((stat :stat)) + (%%fstat fd stat))) + + +(defun %file-kind (mode) + (when mode + (let* ((kind (logand mode #$S_IFMT))) + (cond ((eql kind #$S_IFDIR) :directory) + ((eql kind #$S_IFREG) :file) + ((eql kind #$S_IFLNK) :link) + ((eql kind #$S_IFIFO) :pipe) + ((eql kind #$S_IFSOCK) :socket) + ((eql kind #$S_IFCHR) :character-special) + (t :special))))) + +(defun %unix-file-kind (path &optional check-for-link) + (%file-kind (nth-value 1 (%stat (native-translated-namestring path) check-for-link)))) + +(defun %unix-fd-kind (fd) + (if (isatty fd) + :tty + (%file-kind (nth-value 1 (%fstat fd))))) + +(defun %uts-string (result idx buf) + (if (eql 0 result) + (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH + #+darwin-target #$_SYS_NAMELEN + #+freebsd-target #$SYS_NMLN idx))) + "unknown")) + + +#+linux-target +(defun %uname (idx) + (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) + (%uts-string (syscall syscalls::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))) + +(defun fd-dup (fd) + (syscall syscalls::dup fd)) + +(defun fd-fsync (fd) + (syscall syscalls::fsync fd)) + +(defun fd-get-flags (fd) + (syscall syscalls::fcntl fd #$F_GETFL)) + +(defun fd-set-flags (fd new) + (syscall syscalls::fcntl fd #$F_SETFL 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))) + (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) "/"))))))) + + + +;;; This doesn't seem to exist on VxWorks. It's a POSIX +;;; function AFAIK, so the source should be somewhere ... + +(defun %realpath (namestring) + (when (zerop (length namestring)) + (setq namestring (current-directory-name))) + (%stack-block ((resultbuf #$PATH_MAX)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-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)))) + +(defun timeval->milliseconds (tv) + (+ (* 1000 (pref tv :timeval.tv_sec)) (round (pref tv :timeval.tv_usec) 1000))) + +(defun timeval->microseconds (tv) + (+ (* 1000000 (pref tv :timeval.tv_sec)) (pref tv :timeval.tv_usec))) + +(defun %add-timevals (result a b) + (let* ((seconds (+ (pref a :timeval.tv_sec) (pref b :timeval.tv_sec))) + (micros (+ (pref a :timeval.tv_usec) (pref b :timeval.tv_usec)))) + (if (>= micros 1000000) + (setq seconds (1+ seconds) micros (- micros 1000000))) + (setf (pref result :timeval.tv_sec) seconds + (pref result :timeval.tv_usec) micros) + result)) + +(defun %sub-timevals (result a b) + (let* ((seconds (- (pref a :timeval.tv_sec) (pref b :timeval.tv_sec))) + (micros (- (pref a :timeval.tv_usec) (pref b :timeval.tv_usec)))) + (if (< micros 0) + (setq seconds (1- seconds) micros (+ micros 1000000))) + (setf (pref result :timeval.tv_sec) seconds + (pref result :timeval.tv_usec) micros) + result)) + + +(defun %%rusage (usage &optional (who #$RUSAGE_SELF)) + (syscall syscalls::getrusage who usage)) + + + +(defconstant unix-to-universal-time 2208988800) + +(defun %file-write-date (namestring) + (let* ((date (nth-value 3 (%stat namestring)))) + (if date + (+ date unix-to-universal-time)))) + +(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)))))))) + +(defun %utimes (namestring) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring)) + (let* ((err (#_utimes cnamestring (%null-ptr)))) + (declare (fixnum err)) + (or (eql err 0) + (%errno-disp err namestring))))) + + +(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) + (= 1 (#_isatty fd))) + +(defun %open-dir (namestring) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring)) + (let* ((DIR (#_opendir name))) + (unless (%null-ptr-p DIR) + DIR)))) + +(defun close-dir (dir) + (#_closedir DIR)) + +(defun %read-dir (dir) + (let* ((res (#_readdir dir))) + (unless (%null-ptr-p res) + (get-foreign-namestring (pref res :dirent.d_name))))) + +(defun tcgetpgrp (fd) + (#_tcgetpgrp fd)) + +(defun getpid () + "Return the ID of the OpenMCL OS process." + (syscall syscalls::getpid)) + +(defun getuid () + "Return the (real) user ID of the current user." + (syscall syscalls::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." + (rlet ((pwd :passwd) + (result :address)) + (do* ((buflen 512 (* 2 buflen))) + () + (%stack-block ((buf buflen)) + (let* ((err (#_getpwuid_r userid pwd buf buflen result))) + (if (eql 0 err) + (return (get-foreign-namestring (pref pwd :passwd.pw_dir))) + (unless (eql err #$ERANGE) + (return nil)))))))) + +(defun %delete-file (name) + (with-cstrs ((n name)) + (syscall syscalls::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)))) + +;;; Kind of has something to do with files, and doesn't work in level-0. +#+linux-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))) + (map (shlib.map lib))) + (unless (shlib.opened-by-lisp-kernel lib) + (when map + (let* ((found nil) + (base (shlib.base lib))) + (do* () + ((progn + (#_dlclose map) + (or (not (setq found (shlib-containing-address base))) + (not completely))))) + (when (not found) + (setf (shlib.pathname lib) nil + (shlib.base 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 &rest strings) &body body) + `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings)) + +(defloadvar *max-os-open-files* (#_getdtablesize)) + +(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))) + + + + + + +;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd. +;;; Use libc's interface. +(defun pipe () + ;; (rlet ((filedes (:array :int 2))) + (%stack-block ((filedes 8)) + (let* ((status (#_pipe filedes)) + (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 (#_pipe filedes) + errno (if (zerop status) 0 (%get-errno))))) + (if (zerop status) + (values (paref filedes (:array :int) 0) (paref filedes (:array :int) 1)) + (%errno-disp errno))))) + + + +(defstruct external-process + pid + %status + %exit-code + pty + input + output + error + status-hook + plist + token + core + args + (signal (make-semaphore)) + (completed (make-semaphore)) + watched-fd + watched-stream + ) + +(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) + &allow-other-keys) + (etypecase object + ((eql t) + (values nil nil close-in-parent close-on-error)) + (null + (let* ((fd (fd-open "/dev/null" (case direction + (:input #$O_RDONLY) + (:output #$O_WRONLY) + (t #$O_RDWR))))) + (if (< fd 0) + (signal-file-error fd "/dev/null")) + (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 + :basic t + :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 + :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))))) + (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 "lisp-tempXXXXXX")) + (let* ((fd (#_mkstemp template))) + (if (< fd 0) + (%errno-disp fd)) + (#_unlink template) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (let* ((len (length line))) + (%stack-block ((buf (1+ len))) + (%cstr-pointer line buf) + (fd-write fd buf len) + (if no-newline + (return)) + (setf (%get-byte buf) (char-code #\newline)) + (fd-write fd buf 1))))) + (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) + (setf (external-process-watched-fd proc) read-pipe + (external-process-watched-stream proc) object) + (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))) + ) + + + +(defun monitor-external-process (p) + (let* ((in-fd (external-process-watched-fd p)) + (out-stream (external-process-watched-stream p)) + (token (external-process-token p)) + (terminated)) + (loop + (when (and terminated (null in-fd)) + (signal-semaphore (external-process-completed p)) + (return)) + (if in-fd + (when (fd-input-available-p in-fd *ticks-per-second*) + (%stack-block ((buf 1024)) + (let* ((n (fd-read in-fd buf 1024))) + (declare (fixnum n)) + (if (<= n 0) + (progn + (without-interrupts + (decf (car token)) + (fd-close in-fd) + (setq in-fd nil))) + (let* ((string (make-string 1024))) + (declare (dynamic-extent string)) + (%str-from-ptr buf n string) + (write-sequence string out-stream :end n))))))) + (let* ((statusflags (check-pid (external-process-pid p) + (logior + (if in-fd #$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 #$WCOREFLAG 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 &optional env) + ;; type-check the env variable + (dolist (pair env) + (destructuring-bind (var . val) pair + (assert (typep var '(or string symbol character))) + (assert (typep val 'string)))) + (call-with-string-vector + #'(lambda (argv) + (let* ((child-pid (#_fork))) + (declare (fixnum child-pid)) + (cond ((zerop child-pid) + ;; Running in the child; do an exec + (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)) + (monitor-external-process proc))))) + (external-process-args proc))) + + +(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) + "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 (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))) + (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)) + (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)) + (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 + :element-type element-type))) + (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)) + (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))))) + (and (external-process-pid proc) proc))) + + +(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)))) + +(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 (#_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-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))) + +(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-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 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 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; signal an error otherwise." + (require-type proc 'external-process) + (let* ((pid (external-process-pid proc)) + (error (syscall syscalls::kill pid signal))) + (or (eql error 0) + (%errno-disp error)))) + +;;; 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) + (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~%;;;~%~%" + *current-process* (shared-resource-name resource))) + (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)) + #+linux-target + (or + (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN))) + (declare (fixnum n)) + (if (> n 0) n)) + (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)))) + ))) + +(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 () + (#_sched_yield)) + +(defloadvar *host-page-size* (#_getpagesize)) + +;;(assert (= (logcount *host-page-size*) 1)) + +(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) + (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))))) + (setf (pref header-addr :unsigned-long) + (logior (element-type-subtype upgraded-type) + (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits))) + (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)))))) + (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc))) + (let* ((vector (rlet ((p :address v)) (%get-object p 0)))) + ;; Tell some parts of OpenMCL - 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))))) + + +;;; 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)) + (base-address (%inc-ptr data-address (- *host-page-size*))) + (fd (pref base-address :int))) + (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*))) + (#_munmap base-address (+ size-in-octets *host-page-size*)) + (fd-close fd) + t))) + +(defun unmap-octet-vector (v) + (unmap-ivector v)) + +(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))) + +#+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/experimentation/later/source/level-1/ppc-callback-support.lisp =================================================================== --- /branches/experimentation/later/source/level-1/ppc-callback-support.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/ppc-callback-support.lisp (revision 8058) @@ -0,0 +1,65 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 monitor-exception-ports) + (declare (ignorable monitor-exception-ports)) + (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 + (if monitor-exception-ports + #.(subprim-name->offset '.SPpoweropen-callbackX) + #.(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 monitor-exception-ports) + (declare (ignorable monitor-exception-ports)) + (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/experimentation/later/source/level-1/ppc-error-signal.lisp =================================================================== --- /branches/experimentation/later/source/level-1/ppc-error-signal.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/ppc-error-signal.lisp (revision 8058) @@ -0,0 +1,156 @@ +;;; PPC-specific code to handle trap and uuo callbacks. +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-1/ppc-threads-utils.lisp =================================================================== --- /branches/experimentation/later/source/level-1/ppc-threads-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/ppc-threads-utils.lisp (revision 8058) @@ -0,0 +1,209 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-1/ppc-trap-support.lisp =================================================================== --- /branches/experimentation/later/source/level-1/ppc-trap-support.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/ppc-trap-support.lisp (revision 8058) @@ -0,0 +1,1003 @@ +;;; ppc-trap-support +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 ?? ppc32::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 ?? ppc64::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/experimentation/later/source/level-1/runtime.lisp =================================================================== --- /branches/experimentation/later/source/level-1/runtime.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/runtime.lisp (revision 8058) @@ -0,0 +1,158 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/level-1/sysutils.lisp =================================================================== --- /branches/experimentation/later/source/level-1/sysutils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/sysutils.lisp (revision 8058) @@ -0,0 +1,727 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-extended-string . simple-extended-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) + (extended-string . extended-string-p) + (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))) + (t + (if (eql (typecode form) target::subtag-istruct) + (%svref form 0) + (let* ((class (class-of form)) + (class-name (class-name class))) + (if (eq class (find-class class-name nil)) + class-name + 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?" + (declare (ignore env)) + (let* ((pred (if (symbolp type) (type-predicate type)))) + (if pred + (funcall pred object) + (values (%typep object 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) + (declare (ignore 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) (specifier-type type2))) + + + + +(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 OpenMCL." 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)) + (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) +(def-accessors (deferred-warnings) %svref + nil + deferred-warnings.parent + deferred-warnings.warnings + deferred-warnings.defs + deferred-warnings.flags ; might use to distinguish interactive case/compile-file +) + +(defun %defer-warnings (override &optional flags) + (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags)) + +(defun report-deferred-warnings () + (let* ((current *outstanding-deferred-warnings*) + (parent (deferred-warnings.parent current)) + (defs (deferred-warnings.defs current)) + (warnings (deferred-warnings.warnings current)) + (any nil) + (harsh nil)) + (if parent + (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent)) + (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent)) + parent t) + (let* ((file nil) + (init t)) + (dolist (w warnings) + (let ((wfname (car (compiler-warning-args w)))) + (when (if (typep w 'undefined-function-reference) + (not (or (fboundp wfname) + (assq wfname defs)))) + (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) (setq harsh-p t)) + (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))) + (format s "~&; ~A" w)) + (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) + +#+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/experimentation/later/source/level-1/version.lisp =================================================================== --- /branches/experimentation/later/source/level-1/version.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/version.lisp (revision 8058) @@ -0,0 +1,38 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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* 2) +(defparameter *openmcl-revision* 0) +;;; May be set by xload-level-0 +(defvar *openmcl-svn-revision* nil) +(defparameter *openmcl-dev-level* nil) + +(defparameter *openmcl-version* (format nil "~d.~d~@[.~d~]~@[-r~a~] ~@[+~s~] (~@[~A: ~]~~A)" + *openmcl-major-version* + *openmcl-minor-version* + (unless (zerop *openmcl-revision*) + *openmcl-revision*) + *openmcl-svn-revision* + *optional-features* + *openmcl-dev-level*)) + + + + +;;; end Index: /branches/experimentation/later/source/level-1/x86-callback-support.lisp =================================================================== --- /branches/experimentation/later/source/level-1/x86-callback-support.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/x86-callback-support.lisp (revision 8058) @@ -0,0 +1,41 @@ +;;; +;;; Copyright (C) 2005-2006 Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-callback-trampoline (index &optional monitor-exception-ports) + (declare (ignorable monitor-exception-ports)) + (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)) + + Index: /branches/experimentation/later/source/level-1/x86-error-signal.lisp =================================================================== --- /branches/experimentation/later/source/level-1/x86-error-signal.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/x86-error-signal.lisp (revision 8058) @@ -0,0 +1,248 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2006 Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 xp-argument-count (xp) + (ldb (byte (- 16 x8664::fixnumshift) 0) + (encoded-gpr-lisp xp x8664::nargs.q))) + + + +(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))))))) + +;;; 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 x8664::fname)) args) + frame-ptr))) + (f #'(lambda (values) (apply #'values values)))) + (setf (encoded-gpr-lisp xp x8664::arg_z) values + (encoded-gpr-lisp xp x8664::fn) f))) + +(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 #xa0) + (setq skip (%check-anchored-uuo xcf 2)) + ;; #x9x - register X is a symbol. It's unbound. + (%kernel-restart-internal $xvunbnd + (list + (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)))) + + + + + + + + + + + + + + + + Index: /branches/experimentation/later/source/level-1/x86-threads-utils.lisp =================================================================== --- /branches/experimentation/later/source/level-1/x86-threads-utils.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/x86-threads-utils.lisp (revision 8058) @@ -0,0 +1,170 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2006 Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 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))))) + + + +(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)))))) + +(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))) + (or (eql 0 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)))) + + + + + + +(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/experimentation/later/source/level-1/x86-trap-support.lisp =================================================================== --- /branches/experimentation/later/source/level-1/x86-trap-support.lisp (revision 8058) +++ /branches/experimentation/later/source/level-1/x86-trap-support.lisp (revision 8058) @@ -0,0 +1,237 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2006 Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (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) + (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 +;;; Apple has decided that compliance with some Unix standard or other +;;; requires gratuitously renaming ucontext/mcontext structures and +;;; their components. Do you feel more compliant now ? +(progn + (eval-when (:compile-toplevel :execute) + (def-foreign-type nil + (:struct :portable_mcontext64 + (:es :x86_exception_state64_t) + (:ss :x86_thread_state64_t) + (:fs :x86_float_state64_t))) + (def-foreign-type nil + (:struct :portable_uc_stack + (:ss_sp (:* :void)) + (:ss_size (:unsigned 64)) + (:ss_flags (:signed 32)))) + (def-foreign-type nil + (:struct :portable_ucontext64 + (:onstack (:signed 32)) + (:sigmask (:unsigned 32)) + (:stack (:struct :portable_uc_stack)) + (:link :address) + (:uc_mcsize (:unsigned 64)) + (:uc_mcontext64 (:* (:struct :portable_mcontext64)))))) + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.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 + ))) + +(defun indexed-gpr-lisp (xp igpr) + (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))) +(defun (setf indexed-gpr-lisp) (new xp igpr) + (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::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) + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))) +(defun (setf indexed-gpr-integer) (new xp igpr) + (setf + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::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 x8664::word-shift)))) +(defun (setf indexed-gpr-macptr) (new xp igpr) + (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) new)) +(defun indexed-gpr-macptr (xp igpr) + (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))) +(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) + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift)))) + + + +(defun %get-xcf-byte (xcf-ptr delta) + (let* ((containing-object (%get-object xcf-ptr x8664::xcf.containing-object)) + (byte-offset (%get-object xcf-ptr x8664::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 (+ target::tag-function + (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 x8664::xcf.relative-pc new-rpc) + -1) + skip)) + + +(defun decode-arithmetic-error (xp xcf) + (declare (ignore xp xcf)) + (values 'unknown nil)) + +;;; 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 :int) + (let* ((frame-ptr (macptr->fixnum xcf))) + (cond ((zerop signal) ;thread interrupt + (cmain)) + ((< signal 0) + (%err-disp-internal code () frame-ptr)) + ((= signal #$SIGFPE) + (multiple-value-bind (operation operands) + (decode-arithmetic-error xp xcf) + (let* ((condition-name + (cond ((or (= code #$FPE_INTDIV) + (= code #$FPE_FLTDIV)) + 'division-by-zero) + ((= code #$FPE_FLTOVF) + 'floating-point-overflow) + ((= code #$FPE_FLTUND) + 'floating-point-underflow) + ((= code #$FPE_FLTRES) + 'floating-point-inexact) + (t + 'floating-point-invalid-operation)))) + (%error (make-condition condition-name + :operation operation + :operands operands) + () + frame-ptr)))) + ((= signal #$SIGSEGV) + ;; Stack overflow. + (let* ((on-tsp (not (eql 0 code)))) + (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)))) + ((= signal #$SIGBUS) + (%error (make-condition 'invalid-memory-access + :address addr + :write-p (not (zerop code))) + () + frame-ptr)))) + 0) + Index: /branches/experimentation/later/source/lib/.cvsignore =================================================================== --- /branches/experimentation/later/source/lib/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lib/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/lib/apropos.lisp =================================================================== --- /branches/experimentation/later/source/lib/apropos.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/apropos.lisp (revision 8058) @@ -0,0 +1,247 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + (push sym theList))) + (do-all-symbols (sym) + (when (%apropos-substring-p theString (symbol-name sym)) + (push 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)))) + (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/experimentation/later/source/lib/arglist.lisp =================================================================== --- /branches/experimentation/later/source/lib/arglist.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/arglist.lisp (revision 8058) @@ -0,0 +1,279 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (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 (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 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 (not (null map)) (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/experimentation/later/source/lib/arrays-fry.lisp =================================================================== --- /branches/experimentation/later/source/lib/arrays-fry.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/arrays-fry.lisp (revision 8058) @@ -0,0 +1,465 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/backquote.lisp =================================================================== --- /branches/experimentation/later/source/lib/backquote.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/backquote.lisp (revision 8058) @@ -0,0 +1,393 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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* (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/experimentation/later/source/lib/backtrace-lds.lisp =================================================================== --- /branches/experimentation/later/source/lib/backtrace-lds.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/backtrace-lds.lisp (revision 8058) @@ -0,0 +1,631 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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* + #+x8664-target 4 + #+ppc-target 8) + +(defparameter *saved-register-names* + #+x8664-target #(save3 save2 save1 save0) + #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0)) + + +;;; 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. +(defun frame-supplied-args (frame lfun pc child context) + (declare (ignore child)) + (let* ((arglist (arglist-from-map lfun)) + (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))))) + +;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's +;;; pretty PPC-specific +#+ppc-target +(progn +;;; 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 saved-register-values)) + (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)))))) + + + + +;;; (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. +;;; + +#+ppc-target +(progn + +(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 +#+ppc-target +(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))))) + +) ; end of #+ppc-target progn +) ; end of another #+ppc-target progn +#| +(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/experimentation/later/source/lib/backtrace.lisp =================================================================== --- /branches/experimentation/later/source/lib/backtrace.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/backtrace.lisp (revision 8058) @@ -0,0 +1,564 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + +;;; This PRINTS the call history on *DEBUG-IO*. It's more dangerous +;;; (because of stack consing) to actually return it. + +(defun print-call-history (&key context + (origin (%get-frame-ptr)) + (detailed-p t) + (count most-positive-fixnum) + (start-frame-number 0)) + (let* ((tcr (if context (bt.tcr context) (%current-tcr)))) + (if (eq tcr (%current-tcr)) + (%print-call-history-internal context origin detailed-p (or count most-positive-fixnum) start-frame-number) + (unwind-protect + (progn + (%suspend-tcr tcr ) + (%print-call-history-internal context origin detailed-p + count start-frame-number)) + (%resume-tcr tcr))) + (values))) + +(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) + (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))))) + (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) + (collect ((call)) + (let* ((name (function-name lfun))) + (if (function-is-current-definition? lfun) + (call name) + (progn + (call 'funcall) + (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">"))))) + (multiple-value-bind (req opt restp keys) + (function-args lfun) + (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys) + (let* ((arglist (arglist-from-map lfun))) + (if (null arglist) + (call "???") + (progn + (dotimes (i req) + (let* ((val (argument-value context cfp lfun pc (pop arglist)))) + (if (eq val (%unbound-marker)) + (call "?") + (call (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (format nil "~s" val)))))) + (if (or restp keys (not (eql opt 0))) + (call "[...]")) + )))))) + (call))) + + +;;; 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 %print-call-history-internal (context origin detailed-p + &optional (count most-positive-fixnum) (skip-initial 0)) + (let ((*standard-output* *debug-io*) + (*print-circle* nil) + (p origin) + (q (last-frame-ptr context))) + (dotimes (i skip-initial) + (setq p (parent-frame p context)) + (when (or (null p) (eq p q) (%stack< q p context)) + (return (setq p nil)))) + (do* ((frame-number (or skip-initial 0) (1+ frame-number)) + (i 0 (1+ i)) + (p p (parent-frame p context))) + ((or (null p) (eq p q) (%stack< q p context) + (>= i count)) + (values)) + (declare (fixnum frame-number i)) + (when (or (not (catch-csp-p p context)) + *backtrace-show-internal-frames*) + (multiple-value-bind (lfun pc) (cfp-lfun p) + (when (or lfun *backtrace-show-internal-frames*) + (unless (and (typep detailed-p 'fixnum) + (not (= (the fixnum detailed-p) frame-number))) + (format t "~&(~x) : ~D ~a ~d" + (index->address p) frame-number + (if lfun (backtrace-call-arguments context p lfun pc)) + pc) + (when detailed-p + (if (eq detailed-p :raw) + (%show-stack-frame p context lfun pc) + (%show-args-and-locals p context lfun 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 (and pos (< pos nargs)) + (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) + (locals)) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (when valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (nlocals (- (length vars) nargs)) + (local-vars (nthcdr nargs vars)) + (local-indices (nthcdr nargs map-indices)) + (arg-vars (nbutlast vars nlocals)) + (arg-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)) + #+no + (setq local-vars (nreverse local-vars) + local-indices (nreverse local-indices)) + (dolist (name local-vars) + (get-local-value name))))) + (values (args) (locals)))))) + + + +(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/experimentation/later/source/lib/case-error.lisp =================================================================== --- /branches/experimentation/later/source/lib/case-error.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/case-error.lisp (revision 8058) @@ -0,0 +1,69 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/ccl-export-syms.lisp =================================================================== --- /branches/experimentation/later/source/lib/ccl-export-syms.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ccl-export-syms.lisp (revision 8058) @@ -0,0 +1,853 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + *break-on-warnings* + ; misc + record-source-file + get-source-files + edit-definition + edit-definition-p + *loading-file-source-file* + show-documentation + %set-toplevel + toplevel-loop + toplevel-function + toplevel + cancel + catch-cancel + throw-cancel + *backtrace-on-break* + print-call-history + dbg-form + *backtrace-print-level* + *backtrace-print-length* + *backtrace-show-internal-frames* + *quit-on-eof* + compiler-macroexpand + compiler-macroexpand-1 + uncompile-function + abort-break + *trace-print-level* + *trace-print-length* + *trace-bar-frequency* + *ignore-extra-close-parenthesis* + advise + unadvise + advisedp + nfunction + function-name + + 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* + 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-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* + *warn-if-redefine* + *break-on-errors* + *save-definitions* + *save-local-symbols* + *fasl-save-local-symbols* + *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 + 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* + 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-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 + +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 + *trace-max-indent* + *trace-level* + *fasl-save-doc-strings* + *fasl-save-definitions* + + 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-initial-form + process-whostate + process-priority + process-total-run-time + process-creation-time + clear-process-run-time + process-resume + process-suspend + 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 + + 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 + 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 + *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 + + ) "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-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-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-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-file-source-file* (cdr fn.source))) + (funcall (car fn.source))) + (setq %lisp-system-fixups% (cdr %lisp-system-fixups%))) + (setq %lisp-system-fixups% T)) + + + + Index: /branches/experimentation/later/source/lib/chars.lisp =================================================================== --- /branches/experimentation/later/source/lib/chars.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/chars.lisp (revision 8058) @@ -0,0 +1,582 @@ +; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + +; If object is a character, it is returned. If it is an integer, its INT-CHAR +; 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 (typep arg 'fixnum) + (code-char 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) + (%err-disp $xcoerce arg 'character))))))) + + + +(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))))))))) + + + +;True for ascii codes 32-126 inclusive. +; and for guys >= 128. Its really a function of the font of the moment. +(defun graphic-char-p (c) + "The argument must be a character object. GRAPHIC-CHAR-P returns T if the + argument is a printing character (space through ~ in ASCII), otherwise + returns NIL." + (let* ((code (char-code c))) + (unless (eq c #\rubout) + (>= code (char-code #\space))))) + + +;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 %non-standard-lower-case-equivalent (char) + (gethash char *non-standard-upper-to-lower*)) + + + +(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))) + (declare (type (mod #x110000) code)) + (or (and (>= code (char-code #\A)) + (<= code (char-code #\Z))) + (and (>= code #x80) + (not (null (%non-standard-lower-case-equivalent c))))))) + + + + +(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))) + (declare (type (mod #x110000) code)) + (or (and (>= code (char-code #\A)) + (<= code (char-code #\Z))) + (and (>= code (char-code #\a)) + (<= code (char-code #\z)))))) + +(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))) + (and (>= code (char-code #\a)) + (<= code (char-code #\z))) + (and (>= code (char-code #\A)) + (<= code (char-code #\Z))) + (and (> code #x80) + (or (not (null (%non-standard-upper-case-equivalent c))) + (not (null (%non-standard-lower-case-equivalent c)))))))) + +(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 end) + (setq string (copy-string-arg string)) + (if (not start) (setq start 0)(require-type start 'fixnum)) + (if (not end)(setq end (length string))(require-type end 'fixnum)) + (%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))) + ((>= i end) string) + (declare (fixnum i)) + (let* ((ch (schar string i)) + (code (char-code ch)) + (lower (if (and (char<= ch #\Z) + (char>= ch #\A)) + (%code-char (the (unsigned-byte 8) + (+ code (- (char-code #\a)(char-code #\A))))) + (if (>= code #x80) + (%non-standard-lower-case-equivalent ch))))) + (declare (character ch) (type (mod #x11000) code)) + (when lower + (setf (schar string i) lower))))) + + + + +(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 :element-type (type-of string))))) + (%substr string org (+ len org))) + +(defun string-upcase (string &key start end) + (setq string (copy-string-arg string)) + (if (not start) (setq start 0)(require-type start 'fixnum)) + (if (not end)(setq end (length string))(require-type end 'fixnum)) + (%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))) + ((>= i end) string) + (declare (fixnum i)) + (let* ((ch (schar string i)) + (code (char-code ch)) + (upper (if (and (char<= ch #\z) + (char>= ch #\a)) + (%code-char (the (unsigned-byte 8) + (- code (- (char-code #\a)(char-code #\A))))) + (if (>= code #x80) + (%non-standard-upper-case-equivalent ch))))) + (declare (character ch) (type (mod #x11000) code)) + (when upper + (setf (schar string i) upper))))) + + + +(defun string-capitalize (string &key start end) + (setq string (copy-string-arg string)) + (if (not start) (setq start 0)(require-type start 'fixnum)) + (if (not end)(setq end (length string))(require-type end 'fixnum)) + (%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 end) + (etypecase string + (string + (if (not start) (setq start 0)(require-type start 'fixnum)) + (if (not end)(setq end (length string))(require-type end 'fixnum)) + (multiple-value-bind (sstring org) (array-data-and-offset string) + (%strdown sstring (+ start org)(+ end org))) + string))) + +(defun nstring-upcase (string &key start end) + (etypecase string + (string + (if (not start) (setq start 0)(require-type start 'fixnum)) + (if (not end)(setq end (length string))(require-type end 'fixnum)) + (multiple-value-bind (sstring org) (array-data-and-offset string) + (%strup sstring (+ start org)(+ end org))) + string))) + + +(defun nstring-capitalize (string &key start end) + (etypecase string + (string + (if (not start) (setq start 0)(require-type start 'fixnum)) + (if (not end)(setq end (length string))(require-type end 'fixnum)) + (multiple-value-bind (sstring org) (array-data-and-offset string) + (%strcap sstring (+ start org)(+ end org))) + 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))) + +(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)." + (eq t (string-compare string1 start1 end1 string2 start2 end2))) + + +(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/experimentation/later/source/lib/compile-ccl.lisp =================================================================== --- /branches/experimentation/later/source/lib/compile-ccl.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/compile-ccl.lisp (revision 8058) @@ -0,0 +1,593 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + +; Interim PPC support +; sequences is here since l1-typesys REQUIREs it +(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)) + + +(defparameter *ppc-compiler-modules* + '(ppc32-arch + ppc64-arch + ppc-arch + ppcenv + ppc-asm + risc-lap + ppc-lap + ppc-backend +)) + +(defparameter *x86-compiler-modules* + '(x86-arch + x86-asm + x86-lap + x8664-arch + x8664env + 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 *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*) + (: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) + (:linuxx8664 'ffi-linuxx8664) + (:darwinx8664 'ffi-darwinx8664) + (:freebsdx8664 'ffi-freebsdx8664))))) + + +(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*)) + (: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)) + (:x8664 '(x86-backtrace x86-disassemble))))) + + +(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* + '(systems compile-ccl + lisp-package + number-macros number-case-macro + loop + runtime + mcl-compat + arglist + edit-callers + describe + asdf + defsystem +)) + + + + + + + +(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) + '(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) + (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) + (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 compile-level-1 (&optional force-compile) + (compile-modules (target-level-1-modules (backend-name *host-backend*)) + force-compile)) + + + + + +(defun target-xcompile-ccl (target &optional force) + (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 *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") + (:linuxx8664 "x86-boot64") + (:freebsdx8664 "fx86-boot64") + (:darwinx8664 "x86-boot64.image"))) + +(defun standard-kernel-name (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "dppccl") + (:linuxppc32 "ppccl") + (:darwinppc64 "dppccl64") + (:linuxppc64 "ppccl64") + (:linuxx8664 "lx86cl64") + (:freebsdx8664 "fx86cl64") + (:darwinx8664 "dx86cl64"))) + +(defun standard-image-name (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "dppccl.image") + (:linuxppc32 "PPCCL") + (:darwinppc64 "dppccl64.image") + (:linuxppc64 "PPCCL64") + (:linuxx8664 "LX86CL64") + (:freebsdx8664 "FX86CL64") + (:darwinx8664 "dx86cl64.image"))) + +(defun kernel-build-directory (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "darwinppc") + (:linuxppc32 "linuxppc") + (:darwinppc64 "darwinppc64") + (:linuxppc64 "linuxppc64") + (:linuxx8664 "linuxx8664") + (:freebsdx8664 "freebsdx8664") + (:darwinx8664 "darwinx8664"))) + +(defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait)) +(defvar *build-time-optional-features* nil) + + +(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features) + (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features)) + (*features* (append *build-time-optional-features* *features*))) + (when *build-time-optional-features* + (setq full t)) + (when full + (setq clean t kernel t reload t)) + (when update (update-ccl)) + (let* ((cd (current-directory))) + (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) + (multiple-value-bind + (status exit-code) + (external-process-status + (run-program "make" + (list "-k" "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "-j" + + (format nil "~d" (1+ (cpu-count)))) + :output s + :error s)) + (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" + (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) + 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 () + (let* ((cvs-update "cvs -q update -d -P") + (svn-update "svn update") + (use-cvs (probe-file "ccl:\.svnrev")) + (s (make-string-output-stream))) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "/bin/sh" + (list "-c" + (format nil "cd ~a && ~a" + (native-translated-namestring "ccl:") + (if use-cvs cvs-update svn-update))) + :output s)) + (when (and (eq status :exited) + (eql exit-code 0)) + (format t "~&~a" (get-output-stream-string s)) + t)))) + + Index: /branches/experimentation/later/source/lib/db-io.lisp =================================================================== --- /branches/experimentation/later/source/lib/db-io.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/db-io.lisp (revision 8058) @@ -0,0 +1,1791 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 OpenMCL 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. + (defun fid-open-input (pathname) + (let* ((id (fd-open (cdb-native-namestring pathname) #$O_RDONLY))) + (if (< id 0) + (%errno-disp id pathname) + id))) + + ;;; 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-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))) + +(defstruct (ffi-function (:include ffi-type)) + arglist + return-value) + + + +(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) + +(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) + 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))))) + (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) + (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))) + (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) + (%read-symbol-preserving-case + stream + package) + (unless *read-suppress* + (let* ((fv (%load-var sym query))) + (if query + fv + (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) + (fv.type fv) + 0 + nil)))))))) + + + + +(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)) + (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 error) + (handler-case (read stream nil nil) + (error (condition) (values nil condition))))) + (setf (readtable-case *readtable*) case))) + (when error + (error error)) + (values sym query))) + +(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) + (%read-symbol-preserving-case + stream + package) + (unless *read-suppress* + (etypecase sym + (symbol + (if query + (load-os-constant sym query) + (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)))) + sym))) + (string + (let* ((val 0) + (len (length sym))) + (dotimes (i 4 val) + (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) + (%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 + (load-external-function sym t) + (let* ((def (if (eql arg 0) + (gethash sym (ftd-external-function-definitions + *target-ftd*))))) + (if (and def (eq (macro-function sym) #'%external-call-expander)) + sym + (load-external-function sym nil)))))))) + +(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-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-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))))) + (: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) + `(,(if (eq (car spec) :struct) + #\r + #\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 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 + (when (lower-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 (lower-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. +(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-anon-struct-ref #.encoded-type-anon-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 (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) + (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 :union :name name)))) + (make-foreign-record-type + :kind (if (eql rcode encoded-type-anon-struct-ref) + :struct + :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) + (let* ((r (%load-foreign-record (db-records d) name ftd already))) + (when r (return r)))))) + + Index: /branches/experimentation/later/source/lib/defstruct-lds.lisp =================================================================== --- /branches/experimentation/later/source/lib/defstruct-lds.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/defstruct-lds.lisp (revision 8058) @@ -0,0 +1,379 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (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)) + (while args + (when (atom (cdr args)) (go bad-slot)) + (cond ((eq (%car args) :type) ) + ((eq (%car args) :read-only) + (setq read-only (%cadr args))) + (t (go bad-slot))) + (setq args (%cddr args))) + (push (make-ssd name initform offset read-only) 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 + (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 (list (defstruct-copier sd copier env))) + ,.(if predicate (defstruct-predicate sd named predicate)) + (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) + ;; 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 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))) + (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)) + (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 (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) + `(progn + (eval-when (:compile-toplevel) + (note-function-info ',copier nil ,env)) + (fset ',copier + ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector)))) +; (put 'COPY-SHIP 'nx-alias 'copy-list) + +(defun defstruct-predicate (sd named predicate &aux (arg (gensym))) + (let* ((sd-name (sd-name sd)) + (body + (case (sd-type sd) + ((nil) `(structure-typep ,arg ',sd-name)) + ((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)))))) + `((setf (symbol-function ',predicate) #'(lambda (,arg) ,body))))) + +; End of defstruct-lds.lisp Index: /branches/experimentation/later/source/lib/defstruct-macros.lisp =================================================================== --- /branches/experimentation/later/source/lib/defstruct-macros.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/defstruct-macros.lisp (revision 8058) @@ -0,0 +1,109 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) `(car (uvref ,struct 0))) +(defmacro struct-def (struct) `(gethash (car (uvref ,struct 0)) %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/experimentation/later/source/lib/defstruct.lisp =================================================================== --- /branches/experimentation/later/source/lib/defstruct.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/defstruct.lisp (revision 8058) @@ -0,0 +1,290 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (find-class (struct-name thing))) + +;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) + (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))) + (push + `(progn + ,fn + (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))) + stuff)))))) + `(progn ,@(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) + +(defun slot-accessor-fn (slot name &aux (ref (ssd-reftype slot)) + (offset (ssd-offset slot))) + (cond ((eq ref $defstruct-nth) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `(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*) + `(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*) + `(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) + (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)) + `(progn + (eval-when (:compile-toplevel) + ,@(mapcar #'(lambda (name) `(note-function-info ',name nil ,env)) defs)) + (declaim (inline ,@defs))))) + +;;;Used by setf and whatever... +(defun defstruct-ref-transform (predicate-or-type-and-refinfo args) + (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 + `(the ,type ,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))) + (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/experimentation/later/source/lib/describe.lisp =================================================================== --- /branches/experimentation/later/source/lib/describe.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/describe.lisp (revision 8058) @@ -0,0 +1,1897 @@ +;;; -*- Mode:Lisp; Package:INSPECTOR -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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")) + +(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))) + +;;; 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))) + +;;;;;;; +;;; +;;; 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)) + +(defmethod inspector-print-function ((i inspector) type) + (if (consp type) (setq type (car type))) + (if (eq type :comment) + 'prin1-comment + '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 + (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)) + +(defmethod prin1-comment ((i inspector) stream value &optional label type) + (when label + (prin1-label i stream value label type) + (end-of-label 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) + (unless end + (setq end (inspector-line-count i))) + (when (and start end) + (let ((index start)) + (dotimes (c (- end start)) + (declare (fixnum c)) + (multiple-value-call function i (line-n 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 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))) + (when (null (inspector-line-count inspector)) + (update-line-count inspector)) + (with-errorfree-printing + (let* ((*print-pretty* (or *print-pretty* *describe-pretty*)) + (temp #'(lambda (i value &rest rest) + (declare (dynamic-extent rest)) + (apply #'prin1-line i stream value rest) + (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")) + (if (eq :comment (if (consp type) (car type) type)) + (prin1-comment i stream value label type) + (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 + (if (stringp label) + (write-string label stream) + (princ label stream)) + (if colon-p (princ ": " stream))) + (end-of-label stream) ; used by cacheing code + (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 (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))) + (multiple-value-bind (instance-slots class-slots) (ccl::extract-instance-and-class-slotds (ccl::class-slots class)) + (let* ((ninstance-slots (length instance-slots)) + (nclass-slots (length class-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 (+ nclass-slots ninstance-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...] +(defun standard-object-line-n (i n) + (let* ((instance (inspector-object i)) + (class (class-of instance)) + (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)) + (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) + (values nil "Instance slots" :comment) + (let ((slot-name (slot-definition-name + (elt slotds (- n instance-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (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) + (values nil "Class slots" :comment) + (let ((slot-name (slot-definition-name + (elt slotds (- n shared-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-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-inspector) + +(defmethod compute-line-count ((sym symbol)) + (+ 1 ; The 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 1) (not (symbol-has-bindings-p sym))) (incf n)) + (if (and (>= n 6) (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 sym "Symbol: " type)) + (1 (values nil (symbol-type-line sym) comment)) + (2 (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))))) + (3 (values (symbol-name sym) "Print name: " static)) + (4 (values (if (boundp sym) (symbol-value sym) *unbound-marker*) + "Value: " type)) + (5 (values (if (fboundp sym) + (cond ((macro-function sym)) + ((special-operator-p sym) sym) + (t (symbol-function sym))) + *unbound-marker*) + "Function: " type)) + (6 (values (and (fboundp sym) (arglist sym)) + "Arglist: " static)) + (7 (values (symbol-plist sym) "Plist: " type)) + (8 (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 (replace-object *inspector* value)) + ((1 2 3 6) (setf-line-n-out-of-range sym n)) + (4 (setf resample-p (not (boundp sym)) + (symbol-value sym) value)) + (5 (setf resample-p (not (fboundp sym)) + (symbol-function sym) value)) + (7 (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 7) + (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) + ((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))) + +(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 ((f function-inspector)) + (+ 1 ; the function + 1 ; name + 1 ; arglist + (let* ((doc (documentation (inspector-object f) t))) + (if doc 1 0)) + (compute-disassembly-lines f))) + +(defmethod line-n ((f function-inspector) n) + (let* ((o (inspector-object f)) + (doc (documentation o t))) + (case n + (0 (values o "")) + (1 (values (function-name o) "Name" :colon)) + (2 (multiple-value-bind (arglist type) (arglist o) + (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown"))) + (values arglist label (if type :colon '(:comment (:plain))))))) + (3 (if doc + (values (substitute #\space #\newline doc) "Documentation" :colon) + (disassembly-line-n f (- n 3)))) + (t (disassembly-line-n f (- n (if doc 4 3))))))) + +(defmethod compute-line-count ((f closure-inspector)) + (let* ((o (inspector-object f)) + (nclosed (nth-value 8 (function-args (ccl::closure-function o))))) + (setf (closure-n-closed f) nclosed) + (+ (call-next-method) + 1 ; the function we close over + 1 ; "Closed over values" + nclosed + (if (disasm-p f) 1 0)))) ; "Disassembly" + +(defmethod line-n ((f closure-inspector) n) + (let ((o (inspector-object f)) + (nclosed (closure-n-closed f))) + (if (<= (decf n 2) 0) + (call-next-method) + (cond ((eql (decf n) 0) + (values (ccl::closure-function o) "Inner lfun: " :static)) + ((eql (decf n) 0) + (values nclosed "Closed over values" :comment #'prin1-comment)) + ((< (decf 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))) + ((eql (decf n nclosed) 0) + (values 0 "Disassembly" :comment #'prin1-comment)) + (t (disassembly-line-n f (- n 1))))))) + +(defmethod (setf line-n) (new-value (f function-inspector) n) + (let ((o (inspector-object f))) + (case n + (0 (replace-object f new-value)) + (1 (ccl::lfun-name o new-value) (resample-it)) + (2 (setf (arglist o) new-value)) + (t + (if (>= n 3) + (set-disassembly-line-n f (- n 3) new-value) + (setf-line-n-out-of-range f n))))) + 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 2) 0) ; function itself, name, or arglist + (call-next-method) + (cond ((<= (decf n 2) 0) ; inner-lfun or "Closed over values" + (setf-line-n-out-of-range f en)) + ((< (decf 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))) + ((eql (decf n nclosed) 0) ; "Disassembly" + (setf-line-n-out-of-range f en)) + (t (set-disassembly-line-n f (- n 1) new-value)))))) + +(defun compute-disassembly-lines (f &optional (function (inspector-object f))) + (if (functionp function) + (let* ((info (and (disasm-p f) (list-to-vector (ccl::disassemble-list function)))) + (length (length info)) + (last-pc (if info (car (svref info (1- length))) 0))) + (if (listp last-pc) (setq last-pc (cadr last-pc))) + (setf (pc-width f) (length (format nil "~d" last-pc))) + (setf (disasm-info f) info) + length) + 0)) + +(defun list-to-vector (list) + (let* ((length (length list)) + (vec (make-array length))) + (dotimes (i length) + (declare (fixnum i)) + (setf (svref vec i) (pop list))) + vec)) + +(defun disassembly-line-n (f n) + (let* ((line (svref (disasm-info f) n)) + (value (disasm-line-immediate line))) + (values value line (if value :static :comment)))) + +(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)) + +(defun disasm-line-immediate (line &optional (lookup-functions t)) + (pop line) ; remove address + (when (eq (car line) 'ccl::jsr_subprim) + (return-from disasm-line-immediate (find-symbol (cadr line) :ccl))) + (let ((res nil)) + (labels ((inner-last (l) + (cond ((atom l) l) + ((null (cdr l)) (car l)) + (t (inner-last (last l)))))) + (dolist (e line) + (cond ((numberp e) (when (null res) (setq res e))) + ((consp e) + (cond ((eq (car e) 'function) + (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e)))) + ((eq (car e) 17) ; locative + (setq e (cadr e)) + (unless (atom e) + (cond ((eq (car e) 'special) + (setq res (cadr e))) + ((eq (car e) 'function) + (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e)))) + (t (setq res (inner-last e)))))) + ((or (null res) (numberp res)) + (setq res (inner-last e)))))))) + res)) + +(defmethod inspector-print-function ((i function-inspector) type) + (declare (ignore type)) + 'prin1-normal-line) + +(defmethod prin1-label ((f function-inspector) stream value &optional label type) + (declare (ignore value type)) + (if (atom label) ; not a disassembly line + (call-next-method) + (let* ((pc (car label)) + (label-p (and (listp pc) (setq pc (cadr pc)))) + (pc-mark (pc f))) + (if (eq pc pc-mark) + (format stream "*~vd" (pc-width f) pc) + (format stream "~vd" (+ (pc-width f) (if pc-mark 1 0)) pc)) + (write-char (if label-p #\= #\ ) 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) + (slot-count :accessor slot-count :initform 0))) + +(defmethod inspector-class ((f standard-generic-function)) + (if (functionp f) + 'gf-inspector + 'standard-object-inspector)) + +(defmethod compute-line-count ((f gf-inspector)) + (let* ((gf (inspector-object f)) + (count (length (generic-function-methods gf))) + (res (+ 1 (setf (method-count f) count) + (call-next-method)))) + (if (disasm-p f) (1+ res) res))) + +(defmethod line-n ((f gf-inspector) n) + (let* ((count (method-count f)) + (slot-count (slot-count f)) + (lines (1+ count))) + (if (<= 3 n (+ lines slot-count 3)) + (let ((methods (generic-function-methods (inspector-object f)))) + (cond ((eql (decf n 3) 0) (values methods "Methods: " :static)) + ((<= n count) + (values (nth (- n 1) methods) nil :static)) + ((< (decf n (1+ count)) slot-count) + (standard-object-line-n f n)) + (t + (values 0 "Disassembly" :comment #'prin1-comment)))) + (call-next-method f (if (< n 3) n (- n lines slot-count 1)))))) + +(defmethod (setf line-n) (new-value (f gf-inspector) n) + (let* ((count (method-count f)) + (slot-count (slot-count f)) + (lines (1+ count))) + (if (<= 3 n (+ lines slot-count 3)) + (let ((en n)) + (cond ((<= (decf en 3) count) + (setf-line-n-out-of-range f n)) + ((< (decf en (1+ count)) slot-count) + (standard-object-setf-line-n new-value f en)) + (t (setf-line-n-out-of-range f n)))) + (call-next-method new-value f (if (< n 3) n (- n lines slot-count 1)))))) + +#| +(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)))) +|# + +(defclass method-inspector (standard-object-inspector function-inspector) + ((standard-object-lines :accessor standard-object-lines))) + +(defmethod inspector-class ((object standard-method)) + 'method-inspector) + +(defmethod compute-line-count ((i method-inspector)) + (+ (setf (standard-object-lines i) (call-next-method)) + (if (disasm-p i) 1 0) ; "Disassembly" + (compute-disassembly-lines i (method-function (inspector-object i))))) + +(defmethod line-n ((i method-inspector) n) + (let ((sol (standard-object-lines i))) + (cond ((< n sol) (call-next-method)) + ((eql n sol) (values nil "Disassembly" :comment)) + (t (disassembly-line-n i (- n sol 1)))))) + +(defmethod (setf line-n) (new-value (i method-inspector) n) + (let ((sol (standard-object-lines i))) + (cond ((< n sol) (call-next-method)) + ((eql n sol) (setf-line-n-out-of-range i n)) + (t (set-disassembly-line-n + i n new-value (method-function (inspector-object i))))))) + +;;; funtion-inspector never does prin1-comment. +(defmethod prin1-normal-line ((i method-inspector) stream value &optional + label type colon-p) + (declare (ignore colon-p)) + (if (eq type :comment) + (prin1-comment i stream value label type) + (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 (ignore n)) +) + +#| +(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 (list-to-vector (ccl::%stack-frames-in-context (context f))))) + (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)))) + +#+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)))) + +#+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* ()) + +(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))) + (when (null (inspector-line-count inspector)) + (update-line-count inspector)) + (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 origin) + (*print-pretty* (or *print-pretty* *describe-pretty*)) + (*print-length* 5) + (*print-level* 5) + (func #'(lambda (i value &rest rest) + (declare (dynamic-extent rest)) + (let* ((type (cadr rest))) + (unless (or (eq type :comment) + (and (consp type) + (eq (car type) :comment))) + (format stream "[~d] " tag)) + (incf tag)) + (format stream "~8t") + (apply #'prin1-line i stream value rest) + (terpri stream)))) + (declare (dynamic-extent func)) + (map-lines inspector func origin 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" + (invoke-restart 'exit-inspector)) + +(ccl::define-toplevel-command + :tty-inspect show () + "re-show currently inspected object" + (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))) + (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 () (terpri *debug-io*))))) + +(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n) + (let* ((inspector (inspector-ui-inspector ui))) + (multiple-value-bind (value label type) + (line-n inspector n) + (unless (or (eq type :comment) + (and (consp type) (eq (car type) :comment))) + (let* ((new-inspector (line-n-inspector inspector n value label type)) + (ccl::@ value)) + (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* ((*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))) + +(defglobal *default-inspector-ui-creation-function* 'tty-inspect) + + +(defun inspect (thing) + (let* ((ccl::@ thing)) + (funcall *default-inspector-ui-creation-function* thing))) + Index: /branches/experimentation/later/source/lib/distrib-inits.lisp =================================================================== --- /branches/experimentation/later/source/lib/distrib-inits.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/distrib-inits.lisp (revision 8058) @@ -0,0 +1,28 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/dumplisp.lisp =================================================================== --- /branches/experimentation/later/source/lib/dumplisp.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/dumplisp.lisp (revision 8058) @@ -0,0 +1,236 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 save-application (filename + &rest rest + &key toplevel-function + init-file + error-handler application-class + clear-clos-caches + (purify t) + impurify + (mode #o644) + prepend-kernel + ) + (declare (ignore toplevel-function error-handler application-class + resources clear-clos-caches init-file impurify + mode prepend-kernel)) + (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 (namestring (translate-logical-pathname filename))))) + (when (and kind (not (eq kind :file ))) + (error "~S is not a regular file." filename))) + (let* ((ip *initial-process*) + (cp *current-process*)) + (when (process-verify-quit ip) + (process-interrupt ip + #'(lambda () + (process-exit-application + *current-process* + #'(lambda () + (apply #'%save-application-internal + filename + :purify purify + rest))))) + (unless (eq cp ip) + (process-kill cp))))) + +(defun %save-application-internal (filename &key + toplevel-function ;???? + error-handler ; meaningless unless application-class or *application* not lisp-development.. + application-class + (mode #o644) + (purify t) + (impurify nil) + (init-file nil init-file-p) + (clear-clos-caches t) + (prepend-kernel nil)) + (when (and application-class (neq (class-of *application*) + (if (symbolp application-class) + (find-class application-class) + application-class))) + (setq *application* (make-instance application-class))) + (when (not toplevel-function) + (setq toplevel-function + #'(lambda () + (toplevel-function *application* + (if init-file-p + init-file + (application-init-file *application*)))))) + (when error-handler + (make-application-error-handler *application* error-handler)) + + (if clear-clos-caches (clear-clos-caches)) + (save-image (let ((fd (open-dumplisp-file filename + :mode mode + :prepend-kernel prepend-kernel))) + #'(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) + (%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)))))))))) + + +(defun %prepend-file (out-fd in-fd len) + (declare (fixnum out-fd in-fd len)) + (fd-lseek in-fd 0 #$SEEK_SET) + (let* ((bufsize (ash 1 15))) + (%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)) + (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 open-dumplisp-file (path &key (mode #o666) prepend-kernel) + (let* ((prepend-fd (if prepend-kernel (fd-open + (if (eq prepend-kernel t) + (car *command-line-argument-list*) + (native-translated-namestring + (pathname prepend-kernel))) + #$O_RDONLY))) + (prepend-len (if (and prepend-fd (>= prepend-fd 0)) + (skip-embedded-image prepend-fd))) + (filename (native-translated-namestring path))) + (when (probe-file filename) + (%delete-file filename)) + (when prepend-fd + (setq mode (logior #o111 mode))) + (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode))) + (unless (>= image-fd 0) (signal-file-error image-fd filename)) + (fd-chmod image-fd mode) + (when prepend-fd + (%prepend-file image-fd prepend-fd prepend-len)) + 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 () + (%revive-system-locks) + (refresh-external-entrypoints) + (restore-pascal-functions) + (dolist (f (reverse *lisp-system-pointer-functions*)) + (funcall f)) + (let ((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 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/experimentation/later/source/lib/edit-callers.lisp =================================================================== --- /branches/experimentation/later/source/lib/edit-callers.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/edit-callers.lisp (revision 8058) @@ -0,0 +1,208 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)(and (consp name)(eq (car name) 'setf)))) ; 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 (and (symbolp function) (fboundp function)) + (setq cfun (symbol-function function))) + (if (and (consp function)(eq (car function) 'setf)) + (let ((nm (cadr function))) + (setq function (or (%setf-method nm) + (and (symbolp nm) + (setq nm (setf-function-name nm)) + (fboundp nm) + nm) + function)))) + (when (copying-gc-p) (setq gccount (full-gccount))) + (flet ((do-it (fun) + ;(declare (special fun)) + (when (and gccount (neq gccount (full-gccount))) + (throw 'losing :lost)) + (let ((bits (lfun-bits fun))) + (declare (fixnum bits)) + (unless (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) + (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-encapsulation 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)) + +; 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/experimentation/later/source/lib/encapsulate.lisp =================================================================== --- /branches/experimentation/later/source/lib/encapsulate.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/encapsulate.lisp (revision 8058) @@ -0,0 +1,865 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; Lets try encapsulations +;; trace is here too +;; Make trace like 1.3, trace methods, trace (setf car) + + +(defvar *trace-alist* nil) +(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) + + +(defvar *advise-alist* nil) + +(defparameter *encapsulation-table* + (make-hash-table :test #'eq :rehash-size 2 :size 2)) + +(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 +) + +(defun setf-function-spec-name (spec) + (if (and (consp spec) (eq (car spec) 'setf)) + (or (%setf-method (cadr spec)) ; this can be an anonymous function + (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 nil nil t) + (format t "~%... Unadvising ~a" name) + (unadvise-1 name)) + nil) + +(defun function-encapsulated-p (fn-or-method) + (typecase fn-or-method + ((or method symbol cons)(function-encapsulation fn-or-method)) + (function + (or (function-traced-p fn-or-method) + (function-advised-p fn-or-method ))))) + +(defun function-traced-p (fn) + (%function-in-alist fn *trace-alist*)) + +(defun function-advised-p (fn) + (%function-in-alist fn *advise-alist*)) + +(defun %function-in-alist (def list) + (dolist (cap list) + (let ((symbol (encapsulation-owner cap))) + (typecase symbol + (symbol (when (eq (fboundp symbol) def) + (return cap))) + (method (when (eq (%method-function symbol) def) + (return cap))) + (standard-generic-function + (when (eq symbol def) (return cap))))))) + +(defun function-encapsulation (spec) + (typecase spec + ((or symbol method) + (gethash spec *encapsulation-table*)) + (function (function-encapsulated-p spec)) + (cons (gethash (setf-function-spec-name spec) *encapsulation-table*)))) +;; i.e. old 68K clos - vs 68K target with new clos + + + + +; she works now - does the equivalent of the original gf - called from traced def +(defun %%call-encapsulated-gf (thing args) + ; (print 'one)(print thing)(print args) + ; thing is gf . %%1st-arg-dcode + ; args is ok + (let* ((dcode (cdr thing)) + (proto (assq dcode dcode-proto-alist)) ; << + (dt (%gf-dispatch-table (car thing)))) + (if proto ; assume all of these special dudes want args individually + (if (listp args) + (apply dcode dt args) + (%apply-lexpr dcode dt args)) + (funcall dcode dt args)))) + + + + ; (apply encapsulation args) + + +;; the dcode function of the original gf has been bashed with a combined method whose +;; dcode function is this. So the combined method is called with 2 args (dispatch-table +;; and args to the gf). The combined method in turn makes a lexpr of those 2 args. + +(defun %%call-gf-encapsulation (thing args) + ; (print 'two)(print thing)(print (if (listp args) args (collect-lexpr-args args 0))) + ; thing traced-blitz gf-blitz . %%1st-arg-dcode + ; args = dispatch-table . original-args + ; dont need dispatch-table - its just there as a side effect + (if (listp args) ; this probably never happens + (let ((orig-args (cadr args))) + (if (listp orig-args) + (apply (car thing) orig-args) + (%apply-lexpr (car thing) orig-args))) + (let* ((orig-args (%lexpr-ref args (%lexpr-count args) 1))) + (if (listp orig-args) + (apply (car thing) orig-args) + ; knee deep in lexprs + (%apply-lexpr (car thing) orig-args))))) + + +(defun encapsulate (fn-spec old-def type trace-spec newsym + &optional advice-name advice-when) + (let ((capsule (function-encapsulation fn-spec)) + gf-dcode old-encapsulation) + (%fhave newsym + (if (standard-generic-function-p old-def) + (let ((dcode (%gf-dcode old-def))) + (setq gf-dcode + (if (and (combined-method-p dcode) + (eq '%%call-gf-encapsulation + (function-name (%combined-method-dcode dcode)))) + (let ((stuff (%combined-method-methods dcode))) + (setq old-encapsulation (car stuff)) + (cdr stuff)) + (cons old-def dcode))) + (replace-function-code old-def *gf-proto*) ; << gotta remember to fix it + (or old-encapsulation + (%cons-combined-method old-def gf-dcode #'%%call-encapsulated-gf))) + old-def)) ; make new symbol call old definition + ;; move the encapsulation from fn-spec to sym + (cond (capsule (put-encapsulation newsym capsule))) + (put-encapsulation fn-spec + (make-encapsulation + :symbol newsym + :type type + :spec trace-spec + :advice-name advice-name + :advice-when advice-when)) + (values newsym gf-dcode))) + + +;; call with cap nil to remove - for symbol anyway +;; maybe advising methods is silly - just define a before method + +(defun put-encapsulation (spec cap) + (when cap + (setf (encapsulation-owner cap) spec) + (record-encapsulation cap) + ) + (let ((key (typecase spec + ((or symbol method standard-generic-function) spec) + (cons (setf-function-spec-name spec)) + (t (report-bad-arg spec '(or symbol method cons)))))) + (if cap + (setf (gethash key *encapsulation-table*) cap) + (remhash key *encapsulation-table*))) + cap) + +(defun remove-encapsulation (capsule &optional dont-replace) + ; optional don't replace is for unadvising, tracing all on a method + (let (spec nextsym newdef def) + (setq spec (encapsulation-owner capsule)) + (setq def (typecase spec + (symbol (fboundp spec)) + (method spec))) + (setq nextsym (encapsulation-symbol capsule)) + (setq newdef (fboundp nextsym)) + (without-interrupts + (if (standard-generic-function-p def) + (if (and (combined-method-p newdef) + (eq '%%call-encapsulated-gf (function-name (%combined-method-dcode newdef)))) + (let* ((orig-decode (require-type (cdr (%combined-method-methods newdef)) 'function)) + (proto (cdr (assq orig-decode dcode-proto-alist))) + ) ; << + (setf (%gf-dcode def) orig-decode) + (replace-function-code def (or proto *gf-proto*))) + (setf (car (%combined-method-methods (%gf-dcode def))) newdef)) + (typecase spec + (symbol (%fhave spec newdef)) + (method (setf (%method-function spec) newdef) + (remove-obsoleted-combined-methods spec) + newdef))) + (put-encapsulation spec + (if (null dont-replace) + (function-encapsulation nextsym))) + (put-encapsulation nextsym nil) + (unrecord-encapsulation capsule) + ))) + + +(defun record-encapsulation (capsule) + (ecase (encapsulation-type capsule) + (trace + (when (not (memq capsule *trace-alist*)) + (push capsule *trace-alist*))) + (advice + (when (not (memq capsule *advise-alist*)) + (push capsule *advise-alist*))))) + +(defun unrecord-encapsulation (capsule) + (ecase (encapsulation-type capsule) + (trace + (setq *trace-alist* (delq capsule *trace-alist*))) + (advice + (setq *advise-alist* (delq capsule *advise-alist*))))) + + +(defun find-unencapsulated-definition (spec) + ;; spec is a symbol, function, or method object + ;; returns a raw function ?? + (let (foo) + (while (setq foo (function-encapsulation spec)) + (setq spec (encapsulation-symbol foo))) + (values + (typecase spec + (symbol (fboundp spec)) + (method (%method-function spec)) + (t spec)) + spec))) + +(defun %trace-fboundp (spec) + (typecase spec + (symbol (fboundp spec)) + (method (%method-function spec)))) + + +(defun %trace-function-spec-p (spec &optional define-if-not undefined-ok) + ;; weed out macros and special-forms + (typecase spec + (symbol + (when (or (null spec)(special-operator-p spec)(macro-function spec)) + (error "Cannot trace or advise ~S." spec)) + (let ((res (or (fboundp spec)(and define-if-not + (progn (warn "~S was undefined" spec) + (%fhave spec (%function 'trace-null-def))))))) + (when (not res) + (if undefined-ok + (values nil spec) + (error "~S is undefined." spec))) + (values res spec))) + (method + (values (%method-function spec) spec)) + (cons + (case (car spec) + (:method + (let ((gf (cadr spec)) + (qualifiers (butlast (cddr spec))) + (specializers (car (last (cddr spec)))) + method) + (require-type specializers 'list) + (prog () + AGN + (cond ((setq method + (find-method-by-names gf qualifiers specializers)) + (return (values (%method-function method) method))) + (define-if-not + (when (define-undefined-method spec gf qualifiers specializers) + (go AGN))) + (t (error "Method ~s qualifiers ~s specializers ~s not found." + gf qualifiers specializers)))))) + (setf + (let ((name-or-fn (setf-function-spec-name spec))) + (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn)) + ((functionp name-or-fn) ; its anonymous - give it a name + (let ((newname (gensym))) + (%fhave newname name-or-fn) + (store-setf-method (cadr spec) newname) + (values name-or-fn newname)))))))))) + + +(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 %trace (sym &key before after backtrace step define-if-not) + (let (def newdef trace-thing) + (prog1 + (block %trace-block + ;; + ;; see if we're a callback + ;; + (cond + ((and (typep sym 'symbol) + (boundp sym) + (macptrp (symbol-value 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)))) + (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 sym *trace-pfun-list*)))))) + + ;; + ;; now look for tracible 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. + ;; + ((multiple-value-setq (def trace-thing) + (%trace-function-spec-p sym define-if-not)) + (if def + (let () + (when (%traced-p trace-thing) + (%untrace-1 trace-thing) + (setq def (%trace-fboundp trace-thing))) + (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))) + (when (and (null before)(null after)(null step)) + (setq before #'trace-before) + (setq after #'trace-after)) + (case before + (:print (setq before #'trace-before))) + (case after + (:print (setq after #'trace-after))) + (when backtrace + (when (null before) + (setq before #'trace-before)) + (cond + ((functionp before) + (let ((bfun before)) + (if (integerp backtrace) + (setq before #'(lambda (&rest args) + (apply bfun args) + (let ((*debug-io* *trace-output*)) + (ccl::print-call-history :detailed-p nil :count backtrace) + (terpri *trace-output*)))) + (setq before #'(lambda (&rest args) + (apply bfun args) + (let ((*debug-io* *trace-output*)) + (ccl::print-call-history :detailed-p nil) + (terpri *trace-output*))))))) + ((and (consp before) (or (eq (car before) 'function) (eq (car before) 'quote))) + (if (integerp backtrace) + (setq before `#'(lambda (&rest args) + (apply ,before args) + (let ((*debug-io* *trace-output*)) + (ccl::print-call-history :detailed-p nil :count ,backtrace) + (terpri *trace-output*)))) + (setq before `#'(lambda (&rest args) + (apply ,before args) + (let ((*debug-io* *trace-output*)) + (ccl::print-call-history :detailed-p nil) + (terpri *trace-output*)))))) + (t + (warn ":backtrace is not compatible with :before ~A" before)))) + (setq newdef (trace-global-def + sym newsym before after step method-p)) + (when method-p + (copy-method-function-bits def newdef)) + (without-interrupts + (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym) + (declare (ignore ignore)) + (cond (gf-dcode + (setf (%gf-dcode def) + (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation))) + ((symbolp trace-thing) (%fhave trace-thing newdef)) + ((typep trace-thing 'method) + (setf (%method-function trace-thing) newdef) + (remove-obsoleted-combined-methods trace-thing) + newdef)))))) + (error "Trace does not understand ~S." sym))))) + (when *trace-hook* + (funcall *trace-hook* sym :before before :after after :backtrace backtrace :step step)) + ))) + +;; sym is either a symbol or a method + +(defun %traced-p (sym) + (let ((foo (function-encapsulation sym))) + (and foo (eq (encapsulation-type foo) '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 (sym) + (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 + (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym) + (let (val) + (when (typep def 'standard-generic-function) + (let ((methods (%gf-methods def))) + (dolist (m methods) + (let ((e (function-encapsulation m))) + (when (and e (eq (encapsulation-advice-when e) :step-gf)) + (remove-encapsulation e) + (push m val)))))) + ; gf could have first been traced :step, and then just plain traced + ; maybe the latter trace should undo the stepping?? + (when (%traced-p trace-thing) + (%untrace-1 trace-thing) + (push trace-thing val)) + (if (null (cdr val))(car val) val))))) + (when *untrace-hook* + (funcall *untrace-hook* sym))) + +(defun %untrace-all () + (let ((val nil)) + (dolist (cap *trace-alist*) + (push (encapsulation-spec cap) val) + (remove-encapsulation cap) + (when *untrace-hook* + (funcall *untrace-hook* (encapsulation-spec cap)))) + (dolist (pfun *trace-pfun-list*) + (%untrace pfun) + (when *untrace-hook* + (funcall *untrace-hook* pfun))) + val)) + +;; thing is a symbol or method - def is current definition +;; we already know its traced +(defun %untrace-1 (thing) + (let (capsule) + (setq capsule (function-encapsulation thing)) + ;; trace encapsulations must be first + (when (neq (encapsulation-type capsule) 'trace) + (error "~S was not traced." thing)) + (remove-encapsulation capsule) + (encapsulation-spec capsule))) + +(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 {Option Value}*}* + +TRACE is a debugging tool that provides information when specified +functions are called." + (if syms + `(%trace-0 ',syms) + `(%trace-list))) + +(defun %trace-0 (syms) + (dolist (symbol syms) + (cond ((consp symbol) + (cond ((null (cdr symbol)) + (%trace (car symbol) :before :print :after :print)) + ((memq (car symbol) '(:method setf)) + (%trace symbol :before :print :after :print)) + (t (apply #'%trace symbol)))) + (t (%trace symbol :before :print :after :print))))) + +(defun %trace-list () + (let (res) + (dolist (x *trace-alist*) + (push (encapsulation-spec x) res)) + (dolist (x *trace-pfun-list*) + (push x res)) + res)) + + +;; this week def is the name of an uninterned gensym whose fn-cell is original def + +(defun trace-global-def (sym def before after step &optional method-p) + (let ((saved-method-var (gensym)) do-it step-it) + (when step + (setq step-it + `(step-apply-simple ',def args))) + (setq do-it + (cond (step + (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 before method-p) + `(apply-with-method-context ,saved-method-var (symbol-function ',def) args) + `(apply ',def args))))) + (flet ((quoted-p (x) + (and (consp x) + (case (car x) + ((function quote) t))))) + (compile-named-function-warn + `(lambda (,@(if (and 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)) + (let ((*trace-level* (1+ *trace-level*))) + (declare (special *trace-enable* *trace-level*)) + ,(if before + `(when *trace-enable* + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym t)) + (let* ((*trace-enable* nil)) + ,(cond + ((eq before :break) + `(progn (apply #'trace-before ',sym args) + (break "~S" args))) + (t `(apply ,(if (quoted-p before) before `',before) ',sym args)))) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym nil)))) + ,(if after + `(let ((vals (multiple-value-list ,do-it))) + (when *trace-enable* + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym t)) + (let* ((*trace-enable* nil)) + ,(cond ((eq after :break) + `(progn + (apply #'trace-after ',sym vals) + (break "~S" vals))) + (t `(apply ,(if (quoted-p after) after `',after) ',sym vals)))) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym nil))) + (values-list vals)) + do-it))) + `(traced ,sym))))) + +; &method var tells compiler to bind var to contents of next-method-context +(defun advise-global-def (function-spec def when stuff &optional method-p) + (declare (ignore function-spec)) + (let* ((saved-method-var (gensym))) + `(lambda (,@(if (and method-p (neq when :after)) + `(&method ,saved-method-var)) + &rest arglist) + ;(declare (dynamic-extent arglist)) + (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) + (multiple-value-bind (result warnings)(compile-named-function fn name) + (when warnings + (let ((first t)) + (dolist (w warnings) + (signal-compiler-warning w first nil nil nil) + (setq first nil)))) + result)) + +;; want to look like +;; (setq values (multiple-value-list (progn ,@frob))) + + +(defun %advised-p (thing &optional when advice-name quick) + ;; thing is a symbol, result is list of encapsulations + ;; Quick when used as a simple predicate + (let ((nx thing) cap val) + (while (setq cap (function-encapsulation nx)) + (when (eq (encapsulation-type cap) 'advice) + (if quick (return-from %advised-p cap)) + (when (or (and (null when)(null advice-name)) + (and (eq when (encapsulation-advice-when cap)) + (equal advice-name (encapsulation-advice-name cap)))) + (push cap val))) + (setq nx (encapsulation-symbol cap))) + val)) + + +(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not) + (let (advise-thing def orig-sym orig-def) + (multiple-value-setq (def advise-thing) + (%trace-function-spec-p function-spec define-if-not)) + (when (not def)(error "Advise does not understand ~s." function-spec)) + (when (%traced-p advise-thing) + (setq orig-sym + (encapsulation-symbol (function-encapsulation advise-thing))) + (setq orig-def (fboundp orig-sym))) + (let ((capsules (%advised-p advise-thing when advice-name))) + (when capsules + (unadvise-capsules capsules) + ; get the right def you fool! + (setq def (%trace-function-spec-p function-spec)))) + (without-interrupts + (multiple-value-bind (ignore gf-dcode) + (encapsulate (or orig-sym advise-thing) (or orig-def def) + 'advice function-spec newsym + advice-name when) + (declare (ignore ignore)) + (lfun-name newdef `(advised ',function-spec)) + (if method-p (copy-method-function-bits def newdef)) + (if gf-dcode (setq newdef (%cons-combined-method def (cons newdef gf-dcode) + #'%%call-gf-encapsulation))) + (cond (orig-sym + (%fhave orig-sym newdef)) ; make traced call advised + (t (cond (gf-dcode (setf (%gf-dcode def) newdef)) + ((symbolp advise-thing) + (%fhave advise-thing newdef)) + ((typep advise-thing 'method) + (progn + (setf (%method-function advise-thing) newdef) + (remove-obsoleted-combined-methods advise-thing) + newdef))))))))) + +(defmacro advise (function form &key (when :before) name define-if-not) + (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 function newsym when form method-p))) + `(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 advisedp-1 (function-spec when name) + (let (val) + (flet ((xtract-capsule (c) + (list (encapsulation-spec c) + (encapsulation-advice-when c) + (encapsulation-advice-name c)))) + (cond ((eq t function-spec) + (dolist (c *advise-alist*) + (when (and + (or (null when)(eq when (encapsulation-advice-when c))) + (or (null name)(equal name (encapsulation-advice-name c)))) + (push (xtract-capsule c) val)))) + (t (let* ((advise-thing (nth-value 1 (%trace-function-spec-p function-spec))) + (capsules (%advised-p advise-thing when name))) + (dolist (capsule capsules) + (push (xtract-capsule capsule) val))))) + val))) + + +(defun unadvise-1 (function-spec &optional when advice-name ignore) + (declare (ignore ignore)) + (let ((advise-thing (nth-value 1 (%trace-function-spec-p function-spec)))) + (let ((capsules (%advised-p advise-thing when advice-name))) + (when capsules (unadvise-capsules capsules))))) + +(defun unadvise-capsules (capsules) + (let (val) + (dolist (capsule capsules) + (push (list (encapsulation-spec capsule) + (encapsulation-advice-when capsule) + (encapsulation-advice-name 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 () + (unadvise-capsules *advise-alist*)) + +(defun %set-unencapsulated-definition (spec newdef) + (let (foo) + (while (setq foo (function-encapsulation spec)) + (setq spec (encapsulation-symbol foo))) + (typecase spec + (symbol + (%fhave spec newdef)) ;; or fset ?? + (method + (setf (%method-function spec) newdef) + (remove-obsoleted-combined-methods spec) + newdef)))) + + +;; return t if we defined it, nil otherwise + +(defun %defun-encapsulated-maybe (name newdef) + (let ((def (fboundp name))) + (when (and def (function-encapsulated-p name)) + (cond ((or *loading-files* (typep def 'standard-generic-function)) + (forget-encapsulations name) + nil) + (t (%set-unencapsulated-definition name newdef) + T))))) + +(defun %move-method-encapsulations-maybe (oldmethod newmethod) + ;; deal with method redefinition + (let (cap newdef olddef old-inner-def) + (when (and (setq cap (function-encapsulation oldmethod)) + (neq oldmethod newmethod)) + (cond (*loading-files* + (when (%traced-p oldmethod) + (warn "~%... Untracing ~s" (%untrace-1 oldmethod))) + (when (%advised-p oldmethod nil nil t) + (format t "~%... Unadvising ~s" (unadvise-1 oldmethod)))) + (t (setq newdef (%method-function newmethod)) + (setq olddef (%method-function oldmethod)) + (setq old-inner-def (find-unencapsulated-definition oldmethod)) + ;; make last encapsulation call new definition + (%set-unencapsulated-definition oldmethod newdef) + (setf (%method-function newmethod) olddef) + (remove-encapsulation cap t) + (put-encapsulation newmethod cap) + (setf (%method-function oldmethod) old-inner-def) + (advise-set-method-bits newmethod newdef) + ))))) + +(defun advise-set-method-bits (spec newdef) + ;; spec is a symbol, function, or method object + (let (foo) + (while (setq foo (function-encapsulation spec)) + (let ((def (typecase spec + (symbol (fboundp spec)) + (method (%method-function spec)) + (t nil)))) + (if def + (copy-method-function-bits newdef def) + (error "whats going on here anyway"))) + (setq spec (encapsulation-symbol foo))))) + + +#| + Change History (most recent last): + 2 12/29/94 akh merge with d13 +|# ;(do not edit past this line!!) Index: /branches/experimentation/later/source/lib/ffi-darwinppc32.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-darwinppc32.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-darwinppc32.lisp (revision 8058) @@ -0,0 +1,254 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + (rlets (list name (foreign-record-type-name argtype))) + (inits `(setf ,(%foreign-access-form name type0 0 nil) + ,(next-scalar-arg type0)))) + (progn (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) + (lets (list name `(%inc-ptr ,stack-ptr ,offset )))))) + (lets (list name (next-scalar-arg argtype)))) + #+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/experimentation/later/source/lib/ffi-darwinppc64.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-darwinppc64.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-darwinppc64.lisp (revision 8058) @@ -0,0 +1,536 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 0)) + (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 0)) + (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)) + (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)))))) + (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) + (inits `(setf (%get-double-float ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type :double-float)))) + (let* ((high-single (single-float-at-offset bit-offset)) + (low-single (single-float-at-offset (+ bit-offset 32)))) + (inits `(setf (%%get-unsigned-longlong ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type '(:unsigned 64))))) + (when high-single + (when (< (incf fp-arg-num) 14) + (set-fp-regs-form) + (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) + (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) + (%get-single-float-from-double-ptr + ,fp-args-ptr + ,(* 8 (1- fp-arg-num))))))))))))) + (lets (list name (next-scalar-arg argtype)))) + #+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/experimentation/later/source/lib/ffi-darwinx8664.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-darwinx8664.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-darwinx8664.lisp (revision 8058) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/ffi-freebsdx8664.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-freebsdx8664.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-freebsdx8664.lisp (revision 8058) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/ffi-linuxppc32.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-linuxppc32.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-linuxppc32.lisp (revision 8058) @@ -0,0 +1,218 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + (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/experimentation/later/source/lib/ffi-linuxppc64.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-linuxppc64.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-linuxppc64.lisp (revision 8058) @@ -0,0 +1,198 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 + (rlets (list name (foreign-record-type-name argtype))) + (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))))) + (lets (list name access-form)) + (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/experimentation/later/source/lib/ffi-linuxx8664.lisp =================================================================== --- /branches/experimentation/later/source/lib/ffi-linuxx8664.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ffi-linuxx8664.lisp (revision 8058) @@ -0,0 +1,36 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/foreign-types.lisp =================================================================== --- /branches/experimentation/later/source/lib/foreign-types.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/foreign-types.lisp (revision 8058) @@ -0,0 +1,1869 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + +;;; 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))) + + + + +(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;") + (:linuxx8664 "ccl:x86-headers64;") + (:darwinx8664 "ccl:darwin-x86-headers64;") + (:freebsdx8664 "ccl:freebsd-headers64;")) + :interface-package-name + #.(ftd-interface-package-name *target-ftd*) + :attributes + '(:bits-per-word #+64-bit-target 64 #+32-bit-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 + )) + +(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 OpenMCL 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 OpenMCL 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 OpenMCL 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*)) + (note-foreign-type-ordinal val ftd) + (setf (gethash (make-keyword x) (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*)) + (note-foreign-type-ordinal val ftd) + (setf (gethash (make-keyword x) (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 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)) + (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 (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 (setf (info-foreign-type-union name ftd) + (make-foreign-record-type :name name :kind :union))))) + (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 + (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) + (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)) + + +(make-built-in-class 'external-entry-point *istruct-class*) + +(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)))) + #+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)))))) + +(make-built-in-class 'foreign-variable *istruct-class*) + +(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~168,'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)))))) + +(make-built-in-class 'shlib *istruct-class*) + +(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))))) + +#-darwin-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 symbol) + (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))))))) + + +(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 #-darwin-target + :l_info + #+darwin-target nil) + (canonicalize-foreign-type-ordinal '(:struct :timespec)) + (canonicalize-foreign-type-ordinal '(:struct :timeval)) + (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 :stat)) + (canonicalize-foreign-type-ordinal '(:struct :passwd)) + (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil) + (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)) + ))) + +(defun install-standard-foreign-types (ftd) + (let* ((*target-ftd* ftd) + (natural-word-size (getf (ftd-attributes ftd) :bits-per-word))) + + (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 array (ele-type &rest dims) + (when dims + (unless (typep (first dims) '(or index 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 ,natural-word-size))) + (unsigned-long-type (parse-foreign-type + `(:unsigned ,natural-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 OpenMCL 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) + )) + + + + + + Index: /branches/experimentation/later/source/lib/format.lisp =================================================================== --- /branches/experimentation/later/source/lib/format.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/format.lisp (revision 8058) @@ -0,0 +1,2179 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-stream-stack* () + "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?") + +; prevent circle checking rest args. Really EVIL when dynamic-extent +(defvar *format-top-level* nil) + +;;; Specials imported from ERRORFUNS + +(declaim (special *error-output*)) + +;;; 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) + "Might someday want to add proper format error checking for negative + parameters" + (let (neg-parm) + (when (eq ch #\-)(setq neg-parm ch) + (setq ch (format-nextchar))) + (case ch + (#\# (format-nextchar) (length *format-arguments*)) + ((#\V #\v) + (prog1 (pop-format-arg) (format-nextchar))) + (#\' (prog1 (format-nextchar) (format-nextchar))) + (t (cond ((setq ch (digit-char-p ch)) + (do ((number ch (%i+ ch (%i* 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 (cond (T ;(or (eq ch #\-)(digit-char-p ch)) ; t + (while (digit-char-p (format-nextchar)))) + (t nil)))))) + + +;;; 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 - (also allows :: or @@) + (case ch + (#\: (setq colon t)) + (#\@ (setq atsign t))) + (when (or colon atsign) + (case (setq ch (format-nextchar)) + (#\: (setq colon t) + (setq ch (format-nextchar))) + (#\@ (setq atsign t) + (setq 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"))))))) + +;;; 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 ((*format-control-string* (ensure-simple-string control-string)) + (*format-pprint* nil) + (*format-justification-semi* nil)) + (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?? + (declare (special *format-original-arguments* *format-arguments* + *format-control-string* *format-colon-rest*)) + (do-sub-format stream)))))) + nil)))) + +(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 +(defvar *logical-block-xp* nil) +(defun pop-format-arg (&aux (args *format-arguments*)(xp *logical-block-xp*)) + (when xp + (if (pprint-pop-check+ args xp) ; gets us level and length stuff in logical block + (throw 'logical-block nil))) + (if (and (null args)(null xp)) ; what if its 3? + (format-error "Missing argument") + (progn + (setq *format-arguments* (cdr args)) + (%car args)))) + +; SUB-FORMAT is now defined in L1-format.lisp +; DEFFORMAT is also defined there. + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pretty-printing stuff +;;; + +(defformat #\W format-write (stream colon atsign) + (if *format-justification-semi* + (format-error "~~W illegal in this context")) + (setq *format-pprint* t) + (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)) + (if *format-justification-semi* + (format-error "~~I illegal in this context")) + (setq *format-pprint* t) + (with-format-parameters parms ((n 0)) + (pprint-indent (if colon :current :block) n stream))) + +(defformat #\_ format-conditional-newline (stream colon atsign) + (if *format-justification-semi* + (format-error "~~_ illegal in this context")) + (setq *format-pprint* t) + (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 + (if *format-justification-semi* + (format-error "~~:T illegal in this context")) + (setq *format-pprint* 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 (string-upcase (%substr string ipos cpos))) + (when (eql #\: (schar string (%i+ 1 cpos))) + (setq cpos (%i+ cpos 1))) + (setq ipos (%i+ cpos 1))) + (t (setq package :cl-user))) + (let ((thing (intern (string-upcase (%substr string ipos epos)) (find-package 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 end-parms end-colon end-atsign) + (format-find-command '(#\))) + (when (or end-parms end-colon end-atsign) + (format-error "Flags or parameters not allowed")) + (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 end-parms end-colon end-atsign) + (format-find-command '(#\))) + (when (or end-parms end-colon end-atsign) + (format-error "Flags or parameters not allowed")) + (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 &rest parms) + (declare (special *format-colon-rest*)) ; worry about this later?? + (declare (ignore stream)) + (declare (dynamic-extent parms)) + (when atsign + (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon)) + (setq parms (remove-if #'null parms)) + (when + (cond ((null parms) + (null (if colon *format-colon-rest* *format-arguments*))) + ((null (cdr parms)) + (let ((p (car parms))) + (typecase p + (number (zerop p)) + (character (null p)) + (t nil)))) + ((null (cddr parms)) + (equal (car parms)(cadr parms))) + (t (let ((first (car parms))(second (cadr parms))(third (caddr parms))) + (typecase second + (integer + (<= first second third)) + (character + (char< first second third)) + (t nil))))) ; shouldnt this be an error?? + (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 parms colon atsign cmd) + (format-find-command '(#\; #\])) + (declare (ignore colon)) + (when (or atsign parms) + (format-error "Atsign flag or parameters not allowed")) + (sub-format stream prev tilde) + (unless (eq cmd #\]) + (format-find-command '(#\]))))) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (declare (ignore prev tilde)) + (when (or atsign parms) + (format-error "Atsign flag or parameters not allowed")) + (when (eq cmd #\]) (return)) + (when colon + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (declare (ignore parms colon atsign)) + (sub-format stream prev tilde) + (unless (eq cmd #\]) + (format-find-command '(#\])))) + (return)) + (format-nextchar))))) + + +;;; ~@[ + +(defun format-funny-condition (stream) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\])) + (when (or colon atsign parms) + (format-error "Flags or arguments not allowed")) + (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 parms colon atsign command) + (format-find-command '(#\; #\])) + (when (or parms colon atsign) + (format-error "Flags or parameters not allowed")) + (unless (eq command #\]) + (format-nextchar)) + (if (pop-format-arg) + (if (eq command #\;) + (multiple-value-bind (prev tilde parms colon atsign) + (format-find-command '(#\])) + (when (or colon atsign parms) + (format-error "Flags or parameters not allowed")) + (sub-format stream prev tilde))) + (progn + (sub-format stream prev tilde) + (unless (eq command #\]) + (format-find-command '(#\]))))))) + + +(defformat #\[ format-condition (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when parms + (let ((p (pop parms))) + (if p (push p *format-arguments*))) + (unless (null parms) + (format-error "Too many parameters to ~~["))) + (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-parms end-colon end-atsign) + (format-find-command '(#\})) + (when (or end-atsign end-parms) + (format-error "Illegal terminator for ~~{")) + (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)) + (declare (special *format-colon-rest*)) + (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 colon atsign parms cmd) + (format-find-command '(#\; #\>) nil T) + (when colon + (format-error "~~:; allowed only after first segment in ~~<")) + (when (or atsign parms) + (format-error "Flags and parameters not allowed")) + (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 eparms ecolon eatsign) + (format-find-command '(#\>)) ; bumps format-index + (declare (ignore tilde eparms)) + (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)))))))) + (if *format-justification-semi* + (format-error "~<...~:> illegal in this context.")) + (setq *format-pprint* t) + (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 &rest parms) + (declare (dynamic-extent parms)) + (when parms + (format-error "Parameters not allowed")) + (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) + (apply #'format-newline stream colon atsign parms)) + +(defformat #\return format-newline (stream colon atsign &rest parms) + (apply #'format-newline stream colon atsign parms)) + +;;; Indirection ~? + +(defformat #\? format-indirection (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when (or colon parms) + (format-error "Flags or parameters not allowed")) + (let ((string (pop-format-arg))) + (unless (or (stringp string)(functionp string)) + (format-error "Indirected control string is not a string or function")) + ; fix so 3.1 doesn't make an extended-string here! for which %str-member was busted + ; it didn't fail in 3.0 cause the setq was erroneously missing + ; should really fix the compiler macro to not do that! - done + (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)) + ((< 127 code) + (write-char char stream) + (when (and atsign + (neq #\Null (setq char (code-char (logand 127 code))))) + (princ " (Meta " stream) + (write-char char stream) + (write-char #\) stream))) + ((not (or atsign colon)) + (write-char char stream)) + ((and (< code 32) atsign) + (if (%str-member (setq char (code-char (logxor code 64))) + "@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*)) + (when (peek-char #\NewLine *query-io* nil) + (unread-char #\NewLine *query-io*) + (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."))))) + Index: /branches/experimentation/later/source/lib/hash.lisp =================================================================== --- /branches/experimentation/later/source/lib/hash.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/hash.lisp (revision 8058) @@ -0,0 +1,444 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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). +;; +;; 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 32 bits of the fixnum at nhash.vector.flags look like: +;; +;; TK0C0000 00000000 WVF00000 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 + +(in-package "CCL") + + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + +(defvar *hash-table-class* + (progn +; #+sparc-target (dbg) + (make-built-in-class 'hash-table *istruct-class*))) + +(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)")))) + + +;;; 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)))) + +(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) + (values nil nil 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)) + (let ((rehashF (function-name (nhash.rehashF hash))) + (keytransF (nhash.keytransF hash)) + (compareF (nhash.compareF hash)) + (vector (nhash.vector hash)) + (private (if (nhash.owner hash) '*current-process*)) + (count (nhash.count hash))) + (flet ((convert (f) + (if (or (fixnump f) (symbolp f)) + `',f + `(symbol-function ',(function-name f))))) + (values + `(%cons-hash-table + nil nil nil nil ,(nhash.grow-threshold hash) ,(nhash.rehash-ratio hash) ,(nhash.rehash-size hash) ,(nhash.address-based hash) nil nil ,private) + `(%initialize-hash-table ,hash ',rehashF ,(convert keytransF) ,(convert compareF) + ',vector ,count))))) + +(defun needs-rehashing (hash) + (%set-needs-rehashing hash)) + +(defun %initialize-hash-table (hash rehashF keytransF compareF vector count) + (setf (nhash.rehashF hash) (symbol-function rehashF) + (nhash.keytransF hash) keytransF + (nhash.compareF hash) compareF + (nhash.vector hash) vector + (nhash.count hash) count) + (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))) + (%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 + (write-lock-rwlock lock) + (progn + (unless (eq (nhash.owner hash-table) *current-process*) + (error "Current process doesn't own hash-table ~s" hash-table)))) + (push hash-table *fcomp-locked-hash-tables*)))) + +(defun fasl-unlock-hash-tables () + (dolist (h *fcomp-locked-hash-tables*) + (let* ((lock (nhash.exclusion-lock h))) + (if 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/experimentation/later/source/lib/late-clos.lisp =================================================================== --- /branches/experimentation/later/source/lib/late-clos.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/late-clos.lisp (revision 8058) @@ -0,0 +1,72 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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. + +(defparameter *compile-dcode-functions* nil) + +;;; 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) + (when *compile-dcode-functions* + (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/experimentation/later/source/lib/level-2.lisp =================================================================== --- /branches/experimentation/later/source/lib/level-2.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/level-2.lisp (revision 8058) @@ -0,0 +1,480 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (unless whole (setq whole (gensym))) + (unless environment (setq environment (gensym))) + (multiple-value-bind (bindings binding-decls) + (%destructure-lambda-list lambda-list whole nil nil + :cdr-p t + :whole-p nil + :use-whole-var t + :default-initial-value default-initial-value) + (values + `(lambda (,whole ,environment) + (declare (ignorable ,environment)) + ,@(hoist-special-decls whole local-decs) + ,@(hoist-special-decls environment local-decs) + (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)))) + (%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 listp (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/experimentation/later/source/lib/lists.lisp =================================================================== --- /branches/experimentation/later/source/lib/lists.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/lists.lisp (revision 8058) @@ -0,0 +1,903 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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." + "replace with above def when labels works." + (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." + "replace with above def when labels works" + (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." + "replace with above def when labels works." + (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." + "Replace with above def when labels works." + (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)) + (declare (cons argstail)) + (dolist (arg original-arglists) + (setf (car argstail) arg) + (pop argstail))) + (do ((res nil) + (argstail args args)) + ((memq nil arglists) + (if accumulate + (cdr ret-list) + (car original-arglists))) + (declare (cons argstail)) + (do ((l arglists (cdr l))) + ((not l)) + (setf (car 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/experimentation/later/source/lib/macros.lisp =================================================================== --- /branches/experimentation/later/source/lib/macros.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/macros.lisp (revision 8058) @@ -0,0 +1,3561 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 cons ,x))) + +(defmacro %cdr (x) + `(cdr (the cons ,x))) + +(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)) + +(defmacro dolist ((varsym list &optional ret) &body body &environment env) + (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym)) + (let* ((toplab (gensym)) + (tstlab (gensym)) + (lstsym (gensym))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (let* ((,lstsym ,list) ,varsym) + ,@decls + (tagbody + (go ,tstlab) + ,toplab + (setq ,lstsym (cdr (the list ,lstsym))) + ,@forms + ,tstlab + (setq ,varsym (car ,lstsym)) + (if ,lstsym (go ,toplab))) + ,@(if ret `((progn ,ret)))))))) + + +(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) + `(gvector :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))) + `(let* (,@fns + (,cluster (list ,@bindings)) + (%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent ,cluster %handlers%)) + ,@decls + (progn + ,@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)) + (%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent ,restart-name ,cluster %restarts%)) + (catch ,cluster (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))) + (%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent ,@restart-names ,cluster %restarts%)) + (catch ,cluster (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)) + (%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent ,cluster %handlers%)) + (catch ,cluster (return-from ,block ,form))))) + `(block ,block + (let* ((,cluster (list ',type)) + (%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent ,cluster %handlers%)) + (catch ,cluster (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))) + (%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent ,cluster %handlers%)) + (catch ,cluster (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)) + (%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent ,temp ,cluster %restarts%)) + (catch ,cluster ,@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)) + (%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent ,cluster %restarts%)) + (catch ,cluster ,@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 . + (if (atom form) + (progn + (unless (symbolp form)(signal-program-error $XNotSym form)) + `(setq ,form ,value)) + (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)) + (require-type ,value ',type)))) + `(setf ,(defstruct-ref-transform temp (%cdar args)) + ,value))) + (t + (multiple-value-bind (res win) + (macroexpand-1 form env) + (if win + `(setf ,res ,value) + (default-setf form value env)))))))))) + ((oddp temp) + (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 first set-car) +(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))) + ((and (consp spec) (eq 'setf (%car 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 + (eval-when (:compile-toplevel) + (note-function-info ',spec ',lambda-expression ,env)) + (%defun (nfunction ,spec ,lambda-expression) ',info) + ',spec)))) + +(defmacro %defvar-init (var initform doc) + `(unless (%defvar ',var ,doc) + (setq ,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) &environment env) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',name t ,env)) + (define-standard-initial-binding ',name #'(lambda () ,form)) + ',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 defglobal (&rest args) + "Synonym for DEFSTATIC." + `(defstatic ,@args)) + + +(defmacro defloadvar (&environment env var value &optional doc) + `(progn + (defstatic ,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)))))))) + +; %Pascal-Functions% Entry +; Used by "l1;ppc-callback-support" & "lib;dumplisp" +(def-accessor-macros %svref + pfe.routine-descriptor + pfe.proc-info + pfe.lisp-function + pfe.sym + pfe.without-interrupts + pfe.trace-p) + +(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) + (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) + (error "Invalid clause ~S in ~S form." c construct))) + (dolist (clause clauses) + (if (atom clause) + (bad-clause clause)) + (if otherwise-seen-p + (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) + `(gvector :istruct 'destructure-state ,tail ,whole ,lambda)) + + +; This is supposedly ANSI CL. +(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body) + (unless (lambda-expression-p lambda-expression) + (warn "Invalid lambda expression: ~s" lambda-expression)) + `(function (lambda ,paramlist ,@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)))) + (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 &environment env) + (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 &body 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-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-var (gensym "string"))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,string-var ,string) + (,var (if ,string-var + ,@(if element-type-p + `((progn + ,element-type + (%make-string-output-stream ,string-var))) + `((%make-string-output-stream ,string-var))) + ,@(if element-type-p + `((make-string-output-stream :element-type ,element-type)) + `((make-string-output-stream)))))) + ,@decls + (unwind-protect + (progn + ,@forms + ,@(if string () `((get-output-stream-string ,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 . args) &body body &aux (stream (gensym))(done (gensym))) + "Use open to create a file stream to file named by filespec. Filespec 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 ,@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." + `(let* ((*outstanding-deferred-warnings* (%defer-warnings ,override))) + (multiple-value-prog1 (progn ,@body) (report-deferred-warnings)))) + +; 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* (find-package "CL-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* %initial-readtable%)) + ,@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 *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-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-encoded-cstr ((encoding-name (sym string &optional start end)) + &rest body &environment env) + (let* ((encoding (get-character-encoding encoding-name)) + (str (gensym)) + (len (gensym)) + (nzeros (floor (character-encoding-code-unit-size encoding) 8))) + (collect ((trailing-zeros)) + (case nzeros + (1 (trailing-zeros `(setf (%get-unsigned-byte ,sym ,len) 0))) + (2 (trailing-zeros `(setf (%get-unsigned-word ,sym ,len) 0))) + (4 (trailing-zeros `(setf (%get-unsigned-long ,sym ,len) 0))) + (t + (dotimes (i nzeros) + (trailing-zeros `(setf (%get-unsigned-byte ,sym (the fixnum (+ ,len ,i))) 0))))) + (multiple-value-bind (body decls) (parse-body body env nil) + `(let* ((,str ,string)) + (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end))) + ,@decls + (let* ((,len (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end))) + (declare (fixnum ,len)) + ,@(trailing-zeros) + ,@body))))))) + +(defmacro with-encoded-cstrs (encoding-name bindings &body body) + (with-specs-aux 'with-encoded-cstr (mapcar #'(lambda (b) + `(,encoding-name ,b)) + bindings) body)) + + +(defun with-specs-aux (name spec-list original-body) + (multiple-value-bind (body decls) (parse-body original-body nil) + (when decls (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) + +(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) + (note-function-info ',name nil ,env)) + (compiler-let ((*nx-method-warning-name* + (list ',name + ,@(mapcar #'(lambda (x) `',x) 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)))) + + +(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) + (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)) + (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)) + (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)) + (push name signatures) + (push name readers)) + (:writer + (setq name (cadr options)) + (push name signatures) + (push name writers)) + (:accessor + (setq name (cadr options)) + (push name signatures) + (push name readers) + (push `(setf ,name) signatures) + (push `(setf ,name) writers)) + (:initarg + (push (require-type (cadr options) 'symbol) initargs)) + (:type + (if type-p + (duplicate-options slot) + (setq type-p t)) + ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options)) + (setq type (cadr options))) + (: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)))))) + `(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 )))) + `(progn + (eval-when (:compile-toplevel) + (%compile-time-defclass ',class-name ,env) + (progn + ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,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) + (note-function-info ',function-name nil ,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) + (push `(,defmethod ,function-name ,@(%cdr o)) 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) &optional ((&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))) + (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)) + (error "Invalid option ~s ." option)) + (if docp + (setq duplicate t) + (push (setq docp option) classopts))) + (:report + (unless (null (%cddr option)) + (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)))) + (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 (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"))) + (declare (fixnum types)) + (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) + #+lock-accounting + `(let* ((*locks-held* *locks-held*) + (*locks-pending* *locks-pending*) + (*lock-conses* *lock-conses*)) + ,@body) + #-lock-accounting + `(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~%" val)))))) + +(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) + (woi nil) + (monitor 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)) + (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) :monitor-exception-ports) + (setq monitor (cadr args) args (cddr 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) + (funcall (ftd-callback-bindings-function *target-ftd*) + stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name) + (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 + ,monitor))))))) + + +(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* ((result (gensym)) + (condition-name (if (atom error-return) 'error (car error-return))) + (error-return-function (if (atom error-return) error-return (cadr error-return))) + (body + `(rlet ,rlets + (let ,lets + ,dynamic-extent-decls + ,@other-decls + ,@inits + (let ((,result (progn ,@body))) + (declare (ignorable ,result) + (dynamic-extent ,result)) + + ,(funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + result + 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 errchk (form) + (let* ((res (gensym))) + `(let* ((,res ,form)) + (if (eql 0 ,res) + 0 + (signal-posix-error ,res))))) + +(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)))) + `(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." + `(progn + (setf ,place + (ensure-value-of-type + ,place + ',typespec + ',place + ,string)) + nil)) + + + +(defmacro with-hash-table-iterator ((mname hash-table) &body body &environment env) + "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") + (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 (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 (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 (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)))) + +#+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))))) + (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)) + (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) + (error "Unknown size for foreign type ~S." + (unparse-foreign-type ftype)))) + (p (gensym)) + (bzero (read-from-string "#_bzero"))) + `(let* ((,p (,allocator ,bytes))) + ,@(when (eq *host-backend* *target-backend*) + `((%set-macptr-type ,p ,ordinal-form))) + (,bzero ,p ,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)) + sym (car place))) + (ecase sym + (the `(the ,(cadr place) (atomic-incf-decf ,(caddr place) ,delta))) + (car `(%atomic-incf-car ,(cadr place) ,delta)) + (cdr `(%atomic-incf-cdr ,(cadr place) ,delta)) + ((svref %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))) + (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)) + (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) + (error "Malformed Once-Only binding spec: ~S." 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) + (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)) + (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))) + (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 (ccl::defstruct-ref-transform struct-transform (cdr place)) + 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))) + (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-managed-static) + (eql ,code area-static) + (eql ,code area-dynamic)) + ,@body))))) + +(declare-arch-specific-macro area-succ) + +(defmacro with-ioblock-lock-grabbed ((lock) + &body body) + `(with-lock-grabbed (,lock) + ,@body)) + +(defmacro with-ioblock-lock-grabbed-maybe ((lock) + &body body) + `(with-lock-grabbed-maybe (,lock) + ,@body)) + + +(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) + `(with-lock-grabbed ((ioblock-inbuf-lock ,ioblock)) + ,@body)) + +(defmacro with-ioblock-output-lock-grabbed ((ioblock) &body body) + `(with-lock-grabbed ((ioblock-outbuf-lock ,ioblock)) + ,@body)) + + +(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) + ,@body) + (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) + ,@body) + (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-maybe (,lock) + ,@body) + (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 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)))) Index: /branches/experimentation/later/source/lib/mcl-compat.lisp =================================================================== --- /branches/experimentation/later/source/lib/mcl-compat.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/mcl-compat.lisp (revision 8058) @@ -0,0 +1,47 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/method-combination.lisp =================================================================== --- /branches/experimentation/later/source/lib/method-combination.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/method-combination.lisp (revision 8058) @@ -0,0 +1,658 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 ...) +(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 (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 + (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 . 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 user-form args-var)))) + (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 (form &optional (args-sym (make-symbol "ARGS"))) + (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)) + (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*)))) + +;; +;; 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")) + (code `(lambda (,generic-fn-symbol ,methods-sym ,options-sym) + ,@(unless gf-symbol-specified? + `((declare (ignore-if-unused ,generic-fn-symbol)))) + (let* (,@(let* ((n -1) + (temp #'(lambda (sym) + `(,sym '(nth ,(incf n) ,args-sym))))) + (declare (dynamic-extent temp)) + (mapcar temp arguments))) + ,@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 ',args-sym #',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" :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/experimentation/later/source/lib/misc.lisp =================================================================== --- /branches/experimentation/later/source/lib/misc.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/misc.lisp (revision 8058) @@ -0,0 +1,805 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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." + (%uname 1)) + + +(defun machine-type () + "Returns a string describing the type of the local machine." + (%uname 4)) + + + +(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))) + ))) + + +(defun software-type () + "Return a string describing the supporting software." + (%uname 0)) + + +(defun software-version () + "Return a string describing version of the supporting software, or NIL + if not available." + (%uname 2)) + + + + + + + +;;; Yawn. + + + +(defmethod documentation (thing doc-id) + (%get-documentation thing doc-id)) + +(defun set-documentation (thing doc-id new) + (setf (documentation thing doc-id) new)) + +(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) +||# + +;; + +(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) + (100 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)))) + (rlet ((start :rusage) + (stop :rusage) + (timediff :timeval)) + (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))) + (%%rusage start) + (let* ((results (multiple-value-list (funcall thunk)))) + (declare (dynamic-extent results)) + (%%rusage stop) + (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 + (progn + (%sub-timevals timediff + (pref stop :rusage.ru_utime) + (pref start :rusage.ru_utime)) + (ecase internal-time-units-per-second + (1000000 (timeval->microseconds timediff)) + (1000 (timeval->milliseconds timediff))))) + (elapsed-system-time + (progn + (%sub-timevals timediff + (pref stop :rusage.ru_stime) + (pref start :rusage.ru_stime)) + (ecase internal-time-units-per-second + (1000000 (timeval->microseconds timediff)) + (1000 (timeval->milliseconds timediff))))) + (elapsed-minor (- (pref stop :rusage.ru_minflt) + (pref start :rusage.ru_minflt))) + (elapsed-major (- (pref stop :rusage.ru_majflt) + (pref start :rusage.ru_majflt))) + (elapsed-swaps (- (pref stop :rusage.ru_nswap) + (pref start :rusage.ru_nswap)))) + (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 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)))))))))))) + +;;; 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:")) + (%choose-file-dialog t prompt file-types)) + +(defun choose-new-file-dialog (&key prompt) + (%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 + #+x8664-target x8664-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 nil))) + fun)) + +(%fhave 'df #'disassemble) + +(defun local-svn-revision () + (or + ;; svn2cvs uses a .svnrev file to sync CVS and SVN; if present, + ;; it contains the svn revision in decimal. + (with-open-file (f "ccl:\\.svnrev" :direction :input :if-does-not-exist nil) + (when f (read f))) + (with-output-to-string (s) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "svnversion" (list (native-translated-namestring "ccl:") "/trunk/ccl"):output s)) + (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))))))))) + + +;;; Scan the heap, collecting infomation on the primitive object types +;;; found. Report that information. + +(defun heap-utilization (&key (stream *debug-io*) + (gc-first t)) + (let* ((nconses 0) + (nvectors (make-array 256)) + (vector-sizes (make-array 256)) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*)))) + (declare (type (simple-vector 256) nvectors vector-sizes) + (dynamic-extent nvectors vector-sizes)) + (when gc-first (gc)) + (%map-areas (lambda (thing) + (if (consp thing) + (incf nconses) + (let* ((typecode (typecode thing))) + (incf (aref nvectors typecode)) + (incf (aref vector-sizes typecode) + (funcall array-size-function typecode (uvsize thing))))))) + (report-heap-utilization stream nconses nvectors vector-sizes) + (values))) + +(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))))))) + #+ppc32-target + (dotimes (i 256) + (let* ((fulltag (logand i ppc32::fulltagmask))) + (setf (%svref a i) + (cond ((= fulltag ppc32::fulltag-immheader) + (%svref *immheader-types* (ash i -3))) + ((= fulltag ppc32::fulltag-nodeheader) + (%svref *nodeheader-types* (ash i -3))))))) + a)) + + + +(defun report-heap-utilization (out nconses nvectors vector-sizes) + (format out "~&Object type~42tCount~50tTotal Size in Bytes") + (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size)) + (dotimes (i (length nvectors)) + (let* ((count (aref nvectors i)) + (sizes (aref vector-sizes i))) + (unless (zerop count) + (format out "~&~a~36t~12d~48t~16d" (aref *heap-utilization-vector-type-names* i) count sizes))))) + + + Index: /branches/experimentation/later/source/lib/nfcomp.lisp =================================================================== --- /branches/experimentation/later/source/lib/nfcomp.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/nfcomp.lisp (revision 8058) @@ -0,0 +1,1760 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") +#+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-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 *fasl-save-doc-strings* t) +(defvar *fasl-save-definitions* nil) +(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 *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*) + (external-format :default) + force) + "Compile INPUT-FILE, 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*)) + (loop + (restart-case + (return (%compile-file src output-file verbose print load features + save-local-symbols save-doc-strings save-definitions force backend external-format)) + (retry-compile-file () + :report (lambda (stream) (format stream "Retry compiling ~s" src)) + nil) + (skip-compile-file () + :report (lambda (stream) (format stream "Skip compiling ~s" src)) + (return)))))) + + +(defun %compile-file (src output-file verbose print load features + save-local-symbols save-doc-strings save-definitions force target-backend external-format + &aux orig-src) + + (setq orig-src (merge-pathnames src)) + (let* ((output-default-type (backend-target-fasl-pathname target-backend))) + (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")))) + (let* ((*fasl-non-style-warnings-signalled-p* nil) + (*fasl-warnings-signalled-p* nil)) + (when (and (not force) + (probe-file output-file) + (not (fasl-file-p output-file))) + (unless (y-or-n-p + (format nil + "Compile destination ~S is not ~A file! Overwrite it?" + output-file (pathname-type + (backend-target-fasl-pathname + *target-backend*)))) + (return-from %compile-file nil))) + (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) + (*fasl-save-doc-strings* save-doc-strings) + (*fasl-save-definitions* save-definitions) + (*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)) + (*fcomp-external-format* external-format)) + (let ((forms nil)) + (let* ((*outstanding-deferred-warnings* (%defer-warnings nil))) + (rplacd (defenv.type defenv) *outstanding-deferred-warnings*) + (setq forms (fcomp-file src orig-src lexenv)) + (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) + (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)) + (deferred-warnings.defs *outstanding-deferred-warnings*) + (append (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))) + (when *compile-verbose* (fresh-line)) + (multiple-value-bind (any harsh) (report-deferred-warnings) + (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any) + *fasl-non-style-warnings-signalled-p* (or *fasl-non-style-warnings-signalled-p* harsh)))) + (fasl-scan-forms-and-dump-file forms output-file lexenv))) + (when load (load output-file :verbose (or verbose *load-verbose*))) + (values (truename (pathname output-file)) + *fasl-warnings-signalled-p* + *fasl-non-style-warnings-signalled-p*)))) + +(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) + (let* ((*target-backend* *host-backend*)) + ;; 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 () ,form) nil env nil nil + *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-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 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 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 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* filename) + (*fcomp-toplevel-forms* nil) + (*fasl-eof-forms* nil) + (*loading-file-source-file* (namestring orig-file)) ; why orig-file??? + (eofval (cons nil nil)) + (read-package nil) + form) + (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*)) + ;;This should really be something like `(set-loading-source + ;;,filename) but then couldn't compile level-1 with this... -> + ;;In any case, change this to be a fasl opcode, so don't make an + ;;lfun just to do this... There are other reasons - more + ;;compelling ones than "fear of tiny lfuns" - for making this a + ;;fasl opcode. + (fcomp-output-form $fasl-src env *loading-file-source-file*) + (let* ((*fcomp-previous-position* nil)) + (loop + (let* ((*fcomp-stream-position* (file-position stream))) + (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)))) + (setq form (read stream nil eofval))))) + (when (eq eofval form) (return)) + (fcomp-form form env processing-mode) + (setq *fcomp-previous-position* *fcomp-stream-position*)))) + (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-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 body env processing-mode)) + (compiler-let (fcomp-compiler-let body env processing-mode)) + (locally (fcomp-locally body env processing-mode)) + (macrolet (fcomp-macrolet body 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) (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)) + (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-toplevel) ,form) 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) + (dolist (form forms) (fcomp-form form env processing-mode))) + +(defun fcomp-compiler-let (form env processing-mode &aux vars varinits) + (fcomp-compile-toplevel-forms env) + (dolist (pair (pop form)) + (push (nx-pair-name pair) vars) + (push (%compile-time-eval (nx-pair-initform pair) env) varinits)) + (progv (nreverse vars) (nreverse varinits) + (fcomp-form-list form env processing-mode) + (fcomp-compile-toplevel-forms env))) + +(defun fcomp-locally (body env processing-mode) + (fcomp-compile-toplevel-forms env) + (multiple-value-bind (body decls) (parse-body body env) + (let* ((env (augment-environment env :declare (decl-specs-from-declarations decls)))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env)))) + +(defun fcomp-macrolet (body env processing-mode) + (fcomp-compile-toplevel-forms env) + (let ((outer-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)))) + (car body))))) + (multiple-value-bind (body decls) (parse-body (cdr body) outer-env) + (let* ((env (augment-environment + outer-env + :declare (decl-specs-from-declarations decls)))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env))))) + +(defun fcomp-symbol-macrolet (body env processing-mode) + (fcomp-compile-toplevel-forms env) + (let* ((outer-env (augment-environment env :symbol-macro (car body)))) + (multiple-value-bind (body decls) (parse-body (cdr body) env) + (let* ((env (augment-environment outer-env + :declare (decl-specs-from-declarations decls)))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env))))) + +(defun fcomp-eval-when (form env processing-mode &aux (eval-times (pop form))) + (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 form env :compile-time))) + (at-load-time + (fcomp-form-list form 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 form 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 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 ((definition-env (definition-environment env))) + (when 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)) + (push (cons symbol (if error (%unbound-marker-8) value)) (defenv.constants definition-env)))) + 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* ((fn (fcomp-function-arg valform env))) + (if (and (typep sym 'symbol) (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 (macroexpand-1 form env) env))))))) + +(defun define-compile-time-macro (name lambda-expression env) + (let ((definition-env (definition-environment env))) + (if definition-env + (push (list* name + 'macro + (compile-named-function lambda-expression name env)) + (defenv.functions definition-env))) + name)) + +(defun define-compile-time-symbol-macro (name expansion env) + (let* ((definition-env (definition-environment env))) + (if definition-env + (push (cons name expansion) (defenv.symbol-macros definition-env))) + name)) + + +(defun fcomp-proclaim-type (type syms) + (dolist (sym syms) + (if (symbolp sym) + (push (cons sym type) *nx-compile-time-types*) + (warn "~S isn't a symbol in ~S type declaration while compiling ~S." + sym type *fasl-source-file*)))) + +(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))) + (special + (dolist (sym spec) + (push (cons (require-type sym 'symbol) nil) (defenv.specials defenv)))) + (notspecial + (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))))))) + (optimize + (%proclaim-optimize spec)) + (inline + (dolist (sym spec) + (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv)))) + (notinline + (dolist (sym spec) + (unless (compiler-special-form-p sym) + (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv))))) + (declaration + (dolist (sym spec) + (pushnew (require-type sym 'symbol) *nx-known-declarations*))) + (ignore + (dolist (sym spec) + (push (cons (require-type sym 'symbol) t) *nx-proclaimed-ignore*))) + (unignore + (dolist (sym spec) + (push (cons (require-type sym 'symbol) nil) *nx-proclaimed-ignore*))) + (ftype + (let ((ftype (car spec)) + (fnames (cdr spec))) + ;; ----- 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))))) + (otherwise + (if (memq (if (consp sym) (%car sym) sym) *cl-types*) + (fcomp-proclaim-type sym spec) ; A post-cltl2 cleanup issue changes this + nil) ; ---- probably ought to complain + ))))) + +(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))) + (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 + (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-transform (form env) + (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 (lfun (args (%cdr form))) + (while args + (multiple-value-bind (arg win) (fcomp-transform (%car args) env) + (when (or (setq lfun (fcomp-function-arg arg env)) + win) + (when lfun (setq arg `',lfun)) + (labels ((subst-l (new ptr list) + (if (eq ptr list) (cons new (cdr list)) + (cons (car list) (subst-l new ptr (%cdr list)))))) + (setq form (subst-l arg args form)))) + (setq args (%cdr args)))))) + (push form *fcomp-toplevel-forms*))) + +(defun fcomp-function-arg (expr env) + (when (consp expr) + (if (and (eq (%car expr) 'nfunction) + (symbolp (car (%cdr expr))) + (lambda-expression-p (car (%cddr expr)))) + (fcomp-named-function (%caddr expr) (%cadr expr) env) + (if (and (eq (%car expr) 'function) + (lambda-expression-p (car (%cdr expr)))) + (fcomp-named-function (%cadr expr) nil env))))) + +(defun fcomp-compile-toplevel-forms (env) + (when *fcomp-toplevel-forms* + (let* ((forms (nreverse *fcomp-toplevel-forms*)) + (*fcomp-stream-position* *fcomp-previous-position*) + (lambda (if (null (cdr forms)) + `(lambda () (progn ,@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)) + (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-output-form (opcode env &rest args) + (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) + (let* ((env (new-lexical-environment env))) + (multiple-value-bind (lfun warnings) + (compile-named-function + def name + env + *fasl-save-definitions* + *fasl-save-local-symbols* + *default-file-compilation-policy* + cfasl-load-time-eval-sym + *fasl-target*) + (fcomp-signal-or-defer-warnings warnings env) + lfun))) + +; For now, defer only UNDEFINED-FUNCTION-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) + (setf (compiler-warning-file-name w) *fasl-source-file*) + (setf (compiler-warning-stream-position w) *fcomp-stream-position*) + (if (and (typep w 'undefined-function-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 (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 + :file-name (compiler-warning-file-name w) + :function-name (compiler-warning-function-name w) + :warning-type ':macro-used-before-definition + :args args) + 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 #xFF50) ;Fasl block format. + +(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)) + (*make-load-form-hash* (make-hash-table :test 'eq)) + (*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)) + #+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) + #+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-macptr #.target::subtag-dead-macptr) (unless (%null-ptr-p exp) (fasl-unknown 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 + #+x86-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 (uvref exp 0) *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))) + #+x86-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)) + + + + +(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)))) + +(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)))) + (t (when list + (fasl-scan-ref list) + (fasl-scan-form (%car list)) + (fasl-scan-form (%cdr list)))))) + +(defun fasl-scan-user-form (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)) + (vector (fasl-dump-gvector exp $fasl-vector-header)) + (array (fasl-dump-gvector exp $fasl-array-header)) + (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))) + (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 3)) + (do* ((k code-size (1+ k))) + ((= k function-size)) + (declare (fixnum k)) + (fasl-dump-form (uvref function-vector k)))))) + + + + +;;; Write a "concatenated function"; for now, assume that the target +;;; is x8664. +(defun fasl-xdump-clfun (f) + (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))))) + (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/experimentation/later/source/lib/number-case-macro.lisp =================================================================== --- /branches/experimentation/later/source/lib/number-case-macro.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/number-case-macro.lisp (revision 8058) @@ -0,0 +1,108 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/number-macros.lisp =================================================================== --- /branches/experimentation/later/source/lib/number-macros.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/number-macros.lisp (revision 8058) @@ -0,0 +1,140 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/numbers.lisp =================================================================== --- /branches/experimentation/later/source/lib/numbers.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/numbers.lisp (revision 8058) @@ -0,0 +1,817 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))) + + + +(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 + (let* ((invalid (ccl:get-fpu-mode :invalid))) + (unwind-protect + (progn + (ccl:set-fpu-mode :invalid nil) + (coerce + ;; we could also have used a double-float-nan + ;; variable binding here: + (+ double-float-positive-infinity + double-float-positive-infinity) + type)) + (ccl:set-fpu-mode :invalid invalid))))) + (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) + +#+32-bit-target +(defmethod print-object ((rs random-state) stream) + (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! + 'ccl::initialize-random-state + (random.seed-1 rs) + (random.seed-2 rs))) + +#+64-bit-target +(defmethod print-object ((rs random-state) stream) + (let* ((s1 (random.seed-1 rs))) + (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! + 'ccl::initialize-random-state + (ldb (byte 16 16) s1) + (ldb (byte 16 0) s1)))) + + + +(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 + (ppc32::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 + (ppc32::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 + (ppc32::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 + (ppc32::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 + (ppc32::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/experimentation/later/source/lib/pathnames.lisp =================================================================== --- /branches/experimentation/later/source/lib/pathnames.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/pathnames.lisp (revision 8058) @@ -0,0 +1,506 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + (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) + (preserve-attributes nil)) + (let* ((original (truename source-path)) + (original-namestring (native-translated-namestring original)) + (new-name (merge-pathnames dest-path original)) + (new-namestring (native-translated-namestring new-name)) + (flags (if preserve-attributes "-pf" "-f"))) + (unless new-namestring + (error "~S can't be created." new-name)) + (unless (and (probe-file new-name) + (not (if-exists if-exists new-name))) + (let* ((proc (run-program "/bin/cp" + `(,flags ,original-namestring ,new-namestring) + :wait t)) + (exit-code (external-process-%exit-code proc))) + (unless (zerop exit-code) + (error "Error copying ~s to ~s: ~a" + source-path dest-path (%strerror exit-code))) + (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 + (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, already know 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 (make-directory-pathname :directory (pathname-directory (translate-logical-pathname (merge-pathnames 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 + +(defmacro with-open-dir ((dirent dir) &body body) + `(let ((,dirent (%open-dir ,dir))) + (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. + 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 + :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 ()) (all (getf keys :all)) name subdir) + (with-open-dir (dirent 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 (setq subdir (%str-cat dir name)) t) :directory)) + (let ((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 ((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)) + (result ()) + sub dir-list ans) + (if (not (or name type)) + (when directories + (setq ans (if directory-pathnames + (%cons-pathname (reverse so-far) nil nil) + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil))) + (when (and ans (or (null test) (funcall test ans))) + (setq result (list ans)))) + (with-open-dir (dirent dir) + (while (setq sub (%read-dir dirent)) + (when (and (or all (neq (%schar sub 0) #\.)) + (not (string= sub ".")) + (not (string= sub "..")) + (%file*= name type sub)) + (setq ans + (if (eq (%unix-file-kind (%str-cat 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) + (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil)))) + (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))))) + (when (and ans (or (null test) (funcall test ans))) + (push (if follow-links (or (probe-file ans) ans) ans) result)))))) + result)) + +; now for samson:**:*c*:**: we get samson:ccl:crap:barf: twice because +; it matches in two ways +; 1) **=ccl *c*=crap **=barf +; 2) **= nothing *c*=ccl **=crap:barf +; called to match a ** +(defun %all-directories (dir rest path so-far keys) + (let ((do-files nil) + (do-dirs nil) + (result nil) + (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 subfile 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) + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil))) + (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 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 (setq subfile (%str-cat dir sub)) t) :directory) + (let* ((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) + (%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far)))) + std-sub nil))) + (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)) + (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/experimentation/later/source/lib/ppc-backtrace.lisp =================================================================== --- /branches/experimentation/later/source/lib/ppc-backtrace.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ppc-backtrace.lisp (revision 8058) @@ -0,0 +1,351 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))) Index: /branches/experimentation/later/source/lib/ppc-init-ccl.lisp =================================================================== --- /branches/experimentation/later/source/lib/ppc-init-ccl.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ppc-init-ccl.lisp (revision 8058) @@ -0,0 +1,63 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL 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/experimentation/later/source/lib/ppcenv.lisp =================================================================== --- /branches/experimentation/later/source/lib/ppcenv.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/ppcenv.lisp (revision 8058) @@ -0,0 +1,93 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + +(defmacro make-mask (&rest weights) + `(logior ,@(mapcar #'(lambda (w) `(ash 1 ,w)) weights))) + +(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/experimentation/later/source/lib/pprint.lisp =================================================================== --- /branches/experimentation/later/source/lib/pprint.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/pprint.lisp (revision 8058) @@ -0,0 +1,2105 @@ +;-*-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.") + +;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 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. + +(progn +(eval-when (:compile-toplevel :execute) + (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 + )) + +(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 + (eval-when (:compile-toplevel :execute) + (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) + ) + ) + + (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)) + + (defmacro xp-structure-p (x) + `(istruct-typep ,x 'xp-structure)) + + (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-vector)) + `(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 (char buffer out-point) + (do ((i (%i- out-point 1) (%i- i 1))) + (nil) + (cond ((%i< i 0)(return nil)) + ((neq (schar buffer i) char) + (return i)))))) + (let* ((queue (xp-queue xp)) + (out-point (BP<-TP xp (xpq-pos queue Qentry))) + (last-non-blank (find-not-char-reverse #\space (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))))))) + + + +(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 4) + (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/experimentation/later/source/lib/prepare-mcl-environment.lisp =================================================================== --- /branches/experimentation/later/source/lib/prepare-mcl-environment.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/prepare-mcl-environment.lisp (revision 8058) @@ -0,0 +1,87 @@ +;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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. 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"))) + +(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. 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"))) + + + +(defmacro in-development-mode (&body body) + `(let* ((*package* (find-package "CCL")) + (*warn-if-redefine-kernel* nil)) + ,@body)) + + + + Index: /branches/experimentation/later/source/lib/print-db.lisp =================================================================== --- /branches/experimentation/later/source/lib/print-db.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/print-db.lisp (revision 8058) @@ -0,0 +1,38 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/read.lisp =================================================================== --- /branches/experimentation/later/source/lib/read.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/read.lisp (revision 8058) @@ -0,0 +1,251 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)))))) +|# + +(defun read-internal (input-stream) + (read input-stream t nil t)) + + +(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))) + ((and (integerp dimensions) (> dimensions 0)) + (let ((init-list (read-internal stream))) + (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)) + (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. +(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 not-integer-string-error)) + (when (null end) + (setq end (length string))) + (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/experimentation/later/source/lib/sequences.lisp =================================================================== --- /branches/experimentation/later/source/lib/sequences.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/sequences.lisp (revision 8058) @@ -0,0 +1,2091 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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. + #+ppc32-target + (#.ppc32::subtag-double-float-vector + (%copy-ivector-to-ivector src + (the fixnum (+ (the fixnum (ash start 3)) + (- ppc32::misc-dfloat-offset + ppc32::misc-data-offset))) + dest + (- ppc32::misc-dfloat-offset + ppc32::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)) + (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))))) + + +;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 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 cnt 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-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) most-positive-fixnum) + 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 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 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 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 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)) + +;;; Modified to clear the elements between the old and new fill pointers +;;; so they won't hold on to garbage. +(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 (gvectorp (array-data-and-offset 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) + + +; 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 (length sequence)) 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." + (delete-duplicates (copy-seq sequence) :from-end from-end :test test + :test-not test-not :start start :end end :key key)) + +;;; Delete-Duplicates: + +(defresource *eq-hash-resource* :constructor (make-hash-table :test #'eq) + :destructor #'clrhash) + +(defresource *eql-hash-resource* :constructor (make-hash-table :test #'eql) + :destructor #'clrhash) + +(defresource *equal-hash-resource* :constructor (make-hash-table :test #'equal) + :destructor #'clrhash) + +(defresource *equalp-hash-resource* :constructor (make-hash-table :test #'equalp) + :destructor #'clrhash) + +(defun list-delete-duplicates* (list test test-not key from-end start end) + ;(%print "test:" test "test-not:" test-not "key:" key) + (let (res) + (cond + ((and (> (- end start) 10) (not test-not) ;(eq key #'identity) + (cond ((or (eq test 'eq)(eq test #'eq))(setq res *eq-hash-resource*)) + ((or (eq test 'eql)(eq test #'eql))(setq res *eql-hash-resource*)) + ((or (eq test 'equal)(eq test #'equal)) + (setq res *equal-hash-resource*)) + ((or (eq test 'equalp)(eq test #'equalp)) + (setq res *equalp-hash-resource*)))) + (when (not from-end)(setq list (nreverse list))) ; who cares about which end? + (let* (prev) + (using-resource (table res) + (do* ((rest (nthcdr start list) (%cdr rest)) + (index start (%i+ 1 index))) + ((or (eq index end)(null rest))) + (declare (fixnum index start end)) + (let ((thing (funcall key (%car rest)))) + (cond ((gethash thing table) + (%rplacd prev (%cdr rest))) + (t (setf (gethash thing table) t) + (setq prev rest)))))) + (if from-end list (nreverse list)))) + (T + (let ((handle (cons nil list))) + (do ((current (nthcdr start list) (cdr current)) + (previous (nthcdr start handle)) + (index start (1+ index))) + ((or (= index end) (null current)) + (cdr handle)) + ;(%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))))))))) + +(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)) + (do ((index start (1+ index)) + (jndex start)) + ((= index end) + (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)))) + (aset vector jndex (aref vector index)) + (unless (position (funcall key (aref vector index)) vector :key key + :start (if from-end start (1+ index)) :test test + :end (if from-end jndex end) :test-not test-not) + (setq jndex (1+ jndex))))) + +(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." + (unless end (setq end (length sequence))) + (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 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 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 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 limit)) + (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 limit)) + (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)))))) + Index: /branches/experimentation/later/source/lib/setf-runtime.lisp =================================================================== --- /branches/experimentation/later/source/lib/setf-runtime.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/setf-runtime.lisp (revision 8058) @@ -0,0 +1,133 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/setf.lisp =================================================================== --- /branches/experimentation/later/source/lib/setf.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/setf.lisp (revision 8058) @@ -0,0 +1,881 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + (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) + (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))) + (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) + (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) + (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))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d))) + ,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))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d))) + ,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. + (cond ((and (eq (car (last args)) (car (last vals))) + (eq (car (last getter)) (car (last dummies))) + newval + (null (cdr newval)) + (eq (car (last setter)) (car newval)) + (eq (car (last setter 2)) (car (last dummies)))) + ; (setf (foo ... argn) bar) -> (set-foo ... argn bar) + (values dummies vals newval + `(apply+ (function ,(car setter)) + ,@(butlast dummies) + ,@(last dummies) + ,(car newval)) + `(apply (function ,(car getter)) ,@(cdr getter)))) + ((and (eq (car (last args)) (car (last vals))) + (eq (car (last getter)) (car (last dummies))) + newval + (null (cdr newval)) + (eq (car setter) 'funcall) + (eq (third setter) (car newval)) + (eq (car (last setter)) (car (last dummies)))) + ; (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)) + (setf all-vals (append all-vals vals)) + (setf newvals (append newvals newval)) + (push setter setters) + (push getter getters))) + (values all-dummies all-vals newvals + `(values ,@(nreverse setters)) `(values ,@(nreverse getters))))) Index: /branches/experimentation/later/source/lib/sort.lisp =================================================================== --- /branches/experimentation/later/source/lib/sort.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/sort.lisp (revision 8058) @@ -0,0 +1,504 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/lib/source-files.lisp =================================================================== --- /branches/experimentation/later/source/lib/source-files.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/source-files.lisp (revision 8058) @@ -0,0 +1,269 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 %source-files% (let ((a (make-hash-table :test #'eq + :weak t + :size 7000 + :rehash-threshold .9))) + (do-all-symbols (s) + (let ((f (get s 'bootstrapping-source-files))) + (when f + (setf (gethash s a) f) + (remprop s 'bootstrapping-source-files)))) + a)) + +(%fhave '%source-files (qlfun %source-files (name) + (gethash name %source-files%))) +(%fhave '%set-source-files (qlfun %set-source-files (name value) + (puthash name %source-files% value))) + +;;; 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 specs) t) + (declare (type list specs args cpls)) + (let ((spec (car specs))) + (if (listp spec) + (unless (equal (car args) spec) + (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 (%gf-methods gf)) + (args-length (length args)) + (bits (lfun-bits (closure-function gf))) ; << + arg-count res) + (when methods + (setq arg-count (length (%method-specializers (car methods)))) + (unless (or (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-keys-bit bits) + (<= args-length + (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) + (return-from find-applicable-methods)) + (cond + ((null args) + (dolist (m methods res) + (when (or (eq qualifiers t) + (equal qualifiers (%method-qualifiers m))) + (push m res)))) + ((%i< args-length arg-count) + (let (spectails) + (dolist (m methods) + (let ((mtail (nthcdr args-length (%method-specializers m)))) + (pushnew mtail spectails :test #'equal))) + (dolist (tail spectails) + (setq res + (nconc res (find-applicable-methods + name + (append args (mapcar + #'(lambda (x) (if (consp x) x (class-name x))) + tail)) + qualifiers)))) + (if (%cdr spectails) + (delete-duplicates res :from-end t :test #'eq) + res))) + (t + (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)) + (declare (type list args-tail cpls-tail)) + (let ((arg (car args-tail)) thing) + (if (consp arg) + (setq thing (class-of (cadr arg))) + (setq thing (find-class (or arg t) nil))) + (when thing + (setf (car cpls-tail) + (%class-precedence-list thing))))) + (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 source-files-like-em (classes qualifiers method) + (and (equal (canonicalize-specializers classes) + (%method-specializers method)) + (or (eq qualifiers t) + (equal qualifiers (%method-qualifiers method))))) + +(defun parse-definition-spec (form) + (let ((type t) + name classes qualifiers) + (cond + ((consp form) + (cond ((eq (car form) 'setf) + (setq name form)) + (t (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 (and (consp name)(eq (car name) 'setf)) + (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd + (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))) + +(defun edit-definition-p (name &optional (type t) &aux specializers qualifiers the-method) + (when (consp name) + (multiple-value-setq (type name specializers qualifiers) + (parse-definition-spec name))) + (when (and specializers (consp specializers)) (setq type 'method)) + ; might be a method-function whose name is the method + (when (typep name 'function)(setq name (function-name name))) + (when (typep name 'method) + (setq qualifiers (%method-qualifiers name) + specializers (mapcar #'(lambda (s) + (if (typep s 'class) + (class-name s) + s)) + (%method-specializers name)) + the-method name + name (%method-name name) + type 'method)) + (let (files str newname) + (setq files (or (get-source-files-with-types&classes name type specializers qualifiers the-method) + (and + (not the-method) + (symbolp name) + (or (and + (setq str (symbol-name name)) + (memq (schar str (1- (length str))) '(#\. #\, #\:)) + (setq newname + (find-symbol (%substr str 0 (1- (length str))) + (symbol-package name))) + (get-source-files-with-types&classes newname type specializers qualifiers)) +)))) + (when (and files newname) (setq name newname)) + (values files name type specializers qualifiers))) + + + +;;; sym can be (setf blah) +(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method) + (labels + ((merge-types (l) + (let ((ftype (car l))) + (cond + ((eq ftype 'setf) ; it's (setf (function . file)) + (let ((res (mapcan #'merge-types (cdr l)))) + (if (typep (caar res) 'method) + res + (mapcar #'(lambda (x)(cons 'setf (cdr x))) res)))) + ((or (eq type t)(eq ftype type)) + (let* ((foo #'(lambda (x) + (when x + ; if x is consp it's ( file file ..) + (cond + ((consp x) + (when (or (not (or classes qualifiers)) + (if the-method + (methods-match-p (car x) the-method) + (source-files-like-em classes qualifiers + (car x)))) + (merge-class x))) + (t (list (cons ftype x)))))))) + (declare (dynamic-extent foo)) + (mapcan foo (if (consp (cdr l)) (cdr l)(list (cdr l))))))))) + (merge-class (l) + (if (consp (cdr l)) + (mapcan + #'(lambda (x) + (when x (list (cons (car l) x)))) + (cdr l)) + (list l)))) + (declare (dynamic-extent #'merge-types)(special *direct-methods-only*)) + (let (files) + (when (and (not the-method)(eq type 'method) classes (not *direct-methods-only*)) + (let ((methods (find-applicable-methods sym classes qualifiers))) + (when methods + (setq files (mapcan + #'(lambda (m) + (or (edit-definition-p m)(list (list m)))) + methods))))) + (if files files + (let (setf-p result) + (if (and (consp sym)(eq (car sym) 'setf)) + (setq sym (cadr sym) setf-p t)) + (setq result (%source-files sym)) + (if (not (consp result)) + (setq result + (if (not setf-p) + (if (or (eq type t)(eq type 'function)) + `((function . ,result))))) + (if setf-p (setq result (list (assq 'setf result))))) + (mapcan #'merge-types result)))))) Index: /branches/experimentation/later/source/lib/streams.lisp =================================================================== --- /branches/experimentation/later/source/lib/streams.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/streams.lisp (revision 8058) @@ -0,0 +1,187 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))))) + +(defun read-char (&optional input-stream (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p) + (optimize (speed 3) (space 0))) + (setq input-stream (designated-input-stream input-stream)) + (if (typep input-stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (check-eof + (funcall (ioblock-read-char-function ioblock) ioblock) + input-stream eof-error-p eof-value)) + (check-eof (stream-read-char input-stream) + 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) + (declare (ignore 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/experimentation/later/source/lib/systems.lisp =================================================================== --- /branches/experimentation/later/source/lib/systems.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/systems.lisp (revision 8058) @@ -0,0 +1,201 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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" + "ccl:compiler;nx2a.lisp")) + (nx-base-app "ccl:l1f;nx-base-app" ("ccl:compiler;nx-base-app.lisp" + "ccl:compiler;lambda-list.lisp")) + ; PPC compiler + (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")) + (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")) + (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")) + (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")) + (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-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")) + + (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")) + (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")) + + (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")))) + Index: /branches/experimentation/later/source/lib/time.lisp =================================================================== --- /branches/experimentation/later/source/lib/time.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/time.lisp (revision 8058) @@ -0,0 +1,216 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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))))))) + +(defun get-universal-time () + "Return a single integer for the current time of + day in universal time format." + (rlet ((tv :timeval)) + (#_gettimeofday tv (%null-ptr)) + (+ (pref tv :timeval.tv_sec) unix-to-universal-time))) + +;;; 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. +(defun get-timezone (time) + (let* ((toobig (not (typep time '(unsigned-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 (pref tm :tm.tm_gmtoff) -60) + (unless toobig (not (zerop (pref tm :tm.tm_isdst))))))))))) + + + +(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)))))) + + + +(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 *))) + (multiple-value-bind (secs nanos) + (nanoseconds seconds) + (%nanosleep secs nanos))) + +(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." + (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))) + (+ (* (+ user-seconds system-seconds) internal-time-units-per-second) + (round (+ user-micros system-micros) (floor 1000000 internal-time-units-per-second)))))) + + + + + + Index: /branches/experimentation/later/source/lib/x86-backtrace.lisp =================================================================== --- /branches/experimentation/later/source/lib/x86-backtrace.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/x86-backtrace.lisp (revision 8058) @@ -0,0 +1,235 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006 Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 (null mask) + (values nil nil) + (values (canonicalize-register-mask mask) (if (and at-pc rpc (> 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 x8664::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 x8664::xcf.nominal-function)) + (containing-object (%fixnum-ref xcf x8664::xcf.containing-object))) + (when (typep nominal-function 'function) + (if (eq containing-object (function-to-function-vector nominal-function)) + (- (%fixnum-ref xcf x8664::xcf.relative-pc) + x8664::tag-function) + (let* ((tra (%fixnum-ref xcf x8664::xcf.ra0))) + (if (and (= (lisptag tra) x8664::tag-tra) + (eq nominal-function (%return-address-function tra))) + (%return-address-offset tra))))))) + +(defun cfp-lfun (p) + (if (xcf-p p) + (values + (%fixnum-ref p x8664::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 target::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 target::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)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + + + (return-from %find-register-argument-value + (raw-frame-ref frame context where 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 vsp-limits (frame context) + (let* ((parent (parent-frame frame context))) + (if (xcf-p frame) + (values (+ frame (ash x8664::xcf.size (- x8664::word-shift))) + parent) + (let* ((tra (%fixnum-ref frame x8664::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 target::catch-frame.rbp-cell))) + (when (%stack< fp catch-fp context) (return last-catch)) + (setq last-catch catch + catch (next-catch catch)))))) + +(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)))))))) Index: /branches/experimentation/later/source/lib/x8664env.lisp =================================================================== --- /branches/experimentation/later/source/lib/x8664env.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/x8664env.lisp (revision 8058) @@ -0,0 +1,86 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2005 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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)) + +(defmacro make-mask (&rest weights) + `(logior ,@(mapcar #'(lambda (w) `(ash 1 ,w)) weights))) + +(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/experimentation/later/source/lib/xref.lisp =================================================================== --- /branches/experimentation/later/source/lib/xref.lisp (revision 8058) +++ /branches/experimentation/later/source/lib/xref.lisp (revision 8058) @@ -0,0 +1,609 @@ +;;; -*- Mode: Lisp; Package: CCL; indent-tabs-mode: nil -*- +;;; +;;; Copyright (C) 2003 Oliver Markovic +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-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-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-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))) + (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))))))) + +;; 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)))) + +;; %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))) + +;; edit-definition-p needs this - what is it for? +(defvar *direct-methods-only* nil) + +;; %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 OpenMCL 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/experimentation/later/source/library/.cvsignore =================================================================== --- /branches/experimentation/later/source/library/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/library/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/experimentation/later/source/library/chud-metering.lisp =================================================================== --- /branches/experimentation/later/source/library/chud-metering.lisp (revision 8058) +++ /branches/experimentation/later/source/library/chud-metering.lisp (revision 8058) @@ -0,0 +1,262 @@ +;;;-*-Mode: LISP; Package: (CHUD (:USE CL CCL)) -*- +;;; +;;; Copyright (C) 2005 Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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" "PREPARE-METERING" "*SPATCH-DIRECTORY-PATH*" + "LAUNCH-SHARK" "CLEANUP-SPATCH-FILES" "RESET-METERING")) + +(in-package "CHUD") + + +(defparameter *CHUD-library-path* + "/System/Library/PrivateFrameworks/CHUD.Framework/CHUD" + "This seems to move around with every release.") + +(defparameter *shark-app-path* "/Developer/Applications/Performance\ Tools/Shark.app") + +(defparameter *spatch-directory-path* nil + "If non-NIL, should be a pathname whose directory component matches the +\"Patch FIles\" search path in Shark's Preferences. When this variable +is NIL, USER-HOMEDIR-PATHNAME is used instead.") + +(eval-when (:load-toplevel :execute) + (open-shared-library (namestring *CHUD-library-path*))) + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :chud)) + +;;; CHUD apparently has this notion of global, persistent +;;; "status" (the result returned by the last operation.) +;;; I have not idea whether or not that's thread-specific; +;;; there doesn't seem to be any other way of getting a +;;; string that describes an error code. +(defun chud-get-status-string () + (with-macptrs ((s (#_chudGetStatusStr))) + (if (%null-ptr-p s) + "" + (%get-cstring s)))) + +(defun chud-check-error (result context) + (or (eql result #$chudSuccess) + (error "CHUD error ~d (~a) while ~a. " result (chud-get-status-string) context))) + +(defun chud-is-initialized () + (not (eql (#_chudIsInitialized) 0))) + +(defparameter *chud-supported-major-version* 4) +(defparameter *chud-supported-minor-version* 1) + +;; Don't know if it makes sense to worry about max supported versions +;; as well. + +(defun check-chud-version () + (let* ((version (#_chudFrameworkVersion)) + (major (ldb (byte 8 24) version)) + (minor (ldb (byte 8 12) version))) + (or (and (>= major *chud-supported-major-version*) + (when (= major *chud-supported-major-version*) + (>= minor *chud-supported-minor-version*))) + (warn "The installed CHUD framework is version ~d.~d. ~ +The minimum version supported by this interface is ~d.~d." + major minor *chud-supported-major-version* + *chud-supported-minor-version*)))) + + +(defun initialize-chud () + (or (chud-is-initialized) + (and (check-chud-version) + (chud-check-error (#_chudInitialize) "initializing CHUD")))) + +(defun acquired-remote-access () + (eql #$true (#_chudIsRemoteAccessAcquired))) + +;;; If we've already successfully called (#_chudAcquireRemoteAccess), +;;; we can call it again without error (e.g., it's a no-op in that +;;; case.) However, we can successfully release it at most once. + +(defun acquire-remote-access () + (or (acquired-remote-access) + (chud-check-error (#_chudAcquireRemoteAccess) "acquiring remote access"))) + +(defun release-remote-access () + (chud-check-error (#_chudReleaseRemoteAccess) "releasing remote access")) + +(defun start-remote-perf-monitor (label) + (with-cstrs ((clabel (format nil "~a" label))) + (chud-check-error (#_chudStartRemotePerfMonitor clabel) + "starting performance monitor"))) + +(defun stop-remote-perf-monitor () + (chud-check-error (#_chudStopRemotePerfMonitor) + "stopping performance monitor")) + +(defun setup-timer (duration frequency) + (#_chudSetupTimer frequency + #$chudMicroSeconds + 0 + #$chudMicroSeconds + duration)) + +(defun get-readonly-area-bounds () + (ccl::do-gc-areas (a) + (when (eql(ccl::%fixnum-ref a target::area.code) + #+ppc-target ccl::area-readonly + #+x8664-target ccl::area-managed-static) + (return + (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift) + (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))) + +(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 (uvref fn 0)) + (startaddr (+ (ccl::%address-of code-vector) + target::misc-data-offset)) + (endaddr (+ startaddr (* target::node-size (uvsize code-vector))))) + ;; 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))) + +(defun identify-functions-with-pure-code (pure-low pure-high) + (let* ((hash (make-hash-table :test #'eq))) + (ccl::%map-lfuns #'(lambda (f) + (let* ((code-vector #+ppc-target (ccl:uvref f 0) + #+x8664-target (ccl::function-to-function-vector f)) + (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 (make-array n)) + (i 0)) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (null (cdr v)) + (setf (svref functions i) (car v) + i (1+ i)))) + hash) + (sort functions + #'(lambda (x y) + (< (ccl::%address-of #+ppc-target (uvref x 0) + #+x8664-target x) + (ccl::%address-of #+ppc-target (uvref y 0) + #+x8664-target y)))))))) + + +(defun generate-shark-spatch-file () + (ccl::purify) + (multiple-value-bind (pure-low pure-high) + (get-readonly-area-bounds) + (let* ((functions (identify-functions-with-pure-code pure-low pure-high))) + (with-open-file (f (make-pathname + :host nil + :directory (pathname-directory + (or *spatch-directory-path* + (user-homedir-pathname))) + :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~%") + (dotimes (i (length functions)) + (print-shark-spatch-record (svref functions i) f)) + (format f "!SHARK_SPATCH_END~%"))) t)) + +(defun cleanup-spatch-files () + (dolist (f (directory + (make-pathname + :host nil + :directory + (pathname-directory + (or *spatch-directory-path* + (user-homedir-pathname))) + :name :wild + :type "spatch"))) + (delete-file f))) + + +(defun launch-shark () + (run-program "/usr/bin/open" (list *shark-app-path*))) + + +(defun reset-metering () + (when (acquired-remote-access) + (release-remote-access) + (format t "~&Note: it may be desirable to quit and restart Shark.") + t)) + +(defun prepare-metering () + (launch-shark) + (generate-shark-spatch-file) + (initialize-chud) + (loop + (when (ignore-errors (acquire-remote-access)) + (return)) + ;; Yes, this is lame. + (loop (when (y-or-n-p "Is Shark in Remote mode yet?") + (return))))) + +(defmacro meter (form &key (duration 0) (frequency 1)) + (let* ((started (gensym))) + `(let* ((,started nil)) + (unless (and (chud-is-initialized) + (acquired-remote-access)) + (prepare-metering)) + (setup-timer ,duration ,frequency) + (unwind-protect + (progn + (setq ,started (start-remote-perf-monitor ',form)) + ,form) + (when ,started (stop-remote-perf-monitor)))))) + +(defun chud-cleanup () + (when (chud-is-initialized) + (when (acquired-remote-access) + (ignore-errors (release-remote-access))) + (#_chudCleanup)) + (cleanup-spatch-files)) + +(pushnew 'chud-cleanup *lisp-cleanup-functions*) Index: /branches/experimentation/later/source/library/chud-metering.txt =================================================================== --- /branches/experimentation/later/source/library/chud-metering.txt (revision 8058) +++ /branches/experimentation/later/source/library/chud-metering.txt (revision 8058) @@ -0,0 +1,183 @@ +Using Apple's CHUD metering tools from OpenMCL + + Prerequisites + +Apple's CHUD metering tools are available (as of this writing) from: + +. + +There are also some CHUD packages distributed with some recent +versions of Xcode; the standalone versions available via FTP seem to +work much better with the OpenMCL interface. Both versions 4.1.1 and +4.2.2 of the CHUD tools seem to work reasonably well; earlier versions +provide a different ABI, and it's not known whether any future +versions will be compatible. + +There don't seem to be any versions of CHUD that can deal with 64-bit +processes. + +Ensure that either version 4.1.1 or 4.2.2 of the CHUD tools are +installed. One side-effect of installation is that the folder " +/Developer/Applications/Performance Tools" will have been created and +will contain an application called "Shark". Double-click on Shark; in +its "Preferences" window's "Search Paths" pane, use the "+" button to +add your home directory to the "Patch Files" search path. + + Background + +CHUD's Shark application is a user interface to its low-level +performance monitoring facilities; those facilities provide access to +high-resolution timers, on-chip debugging information, and OS +performance counters. Shark allows the user to run sampling sessions, +which record information about the context in which sampling events +(such as timer interrupts) occur; at the end of the session, Shark +processes the sampled data and presents a browsable interface which +shows the processes, threads, and functions associated with those +events. + +For many processes, Shark can identify functions (the range of +addresses corresponding to the address of the first and last +instructions in the function) by interpreting symbolic information +contained in the executable file. This strategy enables it to identify +C and assembler functions in OpenMCL's lisp kernel, but doesn't help +much in identifying Lisp functions. Fortunately, Shark does have the +ability to read "patch files" , which associate symbolic names to +regions of a process's address space), and fortunately OpenMCL can be +told to move the machine code (the "code vector") associated with a +compiled function to a static memory area (so that the addresses of +the first and last instructions in a compiled lisp function remain +constant); it's possible to assign fixed addresses to the code vectors +of all functions in the lisp at a given time, and to give symbolic +names to the memory regions that delimit those code vectors. + +The process of moving code vectors to a static (and incidentally +read-only) memory area is sometimes referred to as "purification". + + A Sampling Sample + +There's a little bit of flexibility in the order in which these steps +are performed, but for the sake of argument we'll pretend here that +there isn't. + +1) Run Shark, and put it in "remote" mode. + +Run Shark. Ensure that it's in "Programmatic (Remote)" mode by +selecting that option from the "Sampling" menu, or by pressing the key +equivalent "command-shift-R". In the main Shark window, ensure that +the sampling type is set to "Time Profile", select "Process" (instead +of "Everything" ) from the next popup, and doing so should cause the +third popup to select "Remote Client". + +2) Meter some code in OpenMCL. + +In OpenMCL, do: + +? (require "CHUD-METERING") + +and ensure that the code that you want to profile is defined. + +? (defun fact (n) + (if (zerop n) + 1 + (* n (fact (1- n))))) +FACT +? (defun fact-n-m-times (m n) + (dotimes (i m) + (fact n))) +FACT-N-M-TIMES + +Then run something with metering enabled: + +? (CHUD:METER (fact-n-m-times 1000 1000)) + +The first time that CHUD:METER is invoked in a lisp session, it'll: + +1. Ensure that Shark is running + +2. Move the code vectors of all functions to a static + memory area. + +3. Write a Shark "spatch" file to the user's home + directory (which is where we configure Shark to look + for such files back in the "Prerequisites" section.) + See also CHUD:*SPATCH-DIRECTORY-PATH*. + +4. Try to ensure that Shark is running in "remote" mode. + (I don't know of any way in which this can be ensured + programatically, so it'll just keep asking whether or + not Shark's in remote mode until you say "y" and the + lisp metering code detects that that's the case.) + +Those steps may take anywhere from "a few" to "several" seconds; steps +2 and 3 are probably the most expensive and depend on how many +functions are in the lisp image, how big they are, etc. + +On every invocation of CHUD:METER, it'll tell Shark to start a +metering session, execute the form which is its required argument, +tell Shark to stop the session, and return the form's result(s). + +After it's been told to stop the sampling session, Shark will analyze +the sampling data it obtained and display the results. In this +example, it's reasonable to assume that some CCL package functions +related to bignum multiplication dominate the execution time. Lisp +functions that show up in Shark's session window will claim to be +defined in the SPATCH library; their "names" will generally look like +their printed representations. + + Limitations + +It's generally tempting to start redefining functions that have +longer-than-expected execution times. That's possibly the right thing +to do in general, but (because of the way that the spatch mechanism +works) it's hard to get meaningful results: Shark can only give names +to lisp functions that're in its .spatch file, and will continue to +use cached informaton from that .spatch file until it quits. General +(GC-able) lisp functions - whose code-vectors might move around in +memory - tend to confuse Shark (and at least some versions get +confused enough that they may crash while trying to report time spent +in functions that aren't where they used to be ...) + +After things get a little bit out-of-whack (in terms of newly defined +lisp functions), it's often necessary to quit both Shark and OpenMCL, +load the new-and-improved code into the lisp, and try again, hoping +for better results. + +After CHUD:METER has done its first-time setup, it's generally +necessary to quit both Shark and OpenMCL if either quits in order to +get them back in synch again. + +Despite these limitations, it's probably fair to say that this is way, +way better than nothing. + + Reference + +(CHUD:METER form &key (duration 0) (frequency 1)) [Macro] + +Ensures that access to the "remote sampling facility" (Shark, usually) +has been acquired, ensure that code vectors have been purified and +that an spatch file for the current process is writen to the directory +named by CHUD:*SPATCH-DIRECTORY-PATH* (or the user's home directory), +and starts and stops the sampling facility around execution of . +Returns whatever values execution of returns. + +Arguments + an arbitrary lisp expression + sampling frequency in milliseconds + total number of sampling intervals, 0 implies "infinite". + +It seems that the and arguments have no effect; +the sampling frequency and duration can be set via Shark's "configuration +editor" dialog. + +CHUD:*SPATCH-DIRECTORY-PATH* [Special Variable] + +If non-NIL, should be a pathname whose directory component matches the +"Patch FIles" search path in Shark's Preferences. When this variable +is NIL, USER-HOMEDIR-PATHNAME is used instead. + + + 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/experimentation/later/source/library/darwinppc-syscalls.lisp =================================================================== --- /branches/experimentation/later/source/library/darwinppc-syscalls.lisp (revision 8058) +++ /branches/experimentation/later/source/library/darwinppc-syscalls.lisp (revision 8058) @@ -0,0 +1,296 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 ) + +#+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/experimentation/later/source/library/darwinx8664-syscalls.lisp =================================================================== --- /branches/experimentation/later/source/library/darwinx8664-syscalls.lisp (revision 8058) +++ /branches/experimentation/later/source/library/darwinx8664-syscalls.lisp (revision 8058) @@ -0,0 +1,297 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 ) + +#+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/experimentation/later/source/library/elf.lisp =================================================================== --- /branches/experimentation/later/source/library/elf.lisp (revision 8058) +++ /branches/experimentation/later/source/library/elf.lisp (revision 8058) @@ -0,0 +1,310 @@ +(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 (#_elf64_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 :lf64_hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format + (pref ehdr :lf64_hdr.e_machine) machine + (pref ehdr :lf64_hdr.e_type) type + (pref ehdr :lf64_hdr.e_version) *checked-libelf-version*) + (assert-pointer-type ehdr :lf64_hdr))))) + +(defun new-elf-program-header (object &optional (count 1)) + (let* ((phdr (#_elf64_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 :lf64_

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 (#_elf64_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 :lf64_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))) + +(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)) + +(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 'function-vector) + (functions (function-vector-to-function o)))) + ccl::area-dynamic + 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 :lf64_ym))) + (string-table (make-elf-string-table))) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (p (%inc-ptr data (record-length :lf64_ym)) (progn (%incf-ptr p (record-length :lf64_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 :lf64_ym.st_name) (elf-register-string (elf-lisp-function-name f) string-table) + (pref p :lf64_ym.st_info) (logior (ash #$STB_GLOBAL 4) #$STT_FUNC) + (pref p :lf64_ym.st_shndx) section-number + (pref p :lf64_ym.st_value) (%address-of f) + (pref p :lf64_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 :lf64_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 :lf64_hdr) + (shdr :lf64_hdr)) + (fd-read fd fhdr (record-length :lf64_hdr)) + (let* ((pos (+ (pref fhdr :lf64_hdr.e_shoff) + (* sectnum (pref fhdr :lf64_hdr.e_shentsize))))) + (fd-lseek fd pos #$SEEK_SET) + (fd-read fd shdr (record-length :lf64_hdr)) + (setf (pref shdr :lf64_hdr.sh_offset) + (+ #x2000 (logandc2 (+ eof 4095) 4095))) ; #x2000 for nilreg-area + (fd-lseek fd pos #$SEEK_SET) + (fd-write fd shdr (record-length :lf64_hdr)) + t))) + +(defun write-elf-symbols-to-file (pathname) + (let* ((object (create-elf-object pathname)) + (file-header (new-elf-file-header object #$ELFDATA2LSB #$ET_DYN #$EM_X86_64)) + (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 :lf64_hdr.e_shstrndx) (elf-section-index shstrtab-section)) + (setf (pref lisp-section-header :lf64_hdr.sh_name) (elf-register-string ".lisp" section-names) + (pref lisp-section-header :lf64_hdr.sh_type) #$SHT_NOBITS + (pref lisp-section-header :lf64_hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR) + (pref lisp-section-header :lf64_hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift) + (pref lisp-section-header :lf64_hdr.sh_size) (ash (frozen-space-dnodes) target::dnode-shift) + (pref lisp-section-header :lf64_hdr.sh_offset) 0 + (pref lisp-section-header :lf64_hdr.sh_addralign) 1) + (setf (pref symbols-section-header :lf64_hdr.sh_name) (elf-register-string ".symtab" section-names) + (pref symbols-section-header :lf64_hdr.sh_type) #$SHT_SYMTAB + (pref symbols-section-header :lf64_hdr.sh_entsize) (record-length :lf64_ym) + (pref symbols-section-header :lf64_hdr.sh_link) (elf-section-index strings-section)) + (setf (pref strings-section-header :lf64_hdr.sh_name) (elf-register-string ".strtab" section-names) + (pref strings-section-header :lf64_hdr.sh_type) #$SHT_STRTAB + (pref strings-section-header :lf64_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (setf (pref shstrtab-section-header :lf64_hdr.sh_name) (elf-register-string ".shstrtab" section-names) + (pref shstrtab-section-header :lf64_hdr.sh_type) #$SHT_STRTAB + (pref shstrtab-section-header :lf64_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 :lf64_

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

hdr.p_offset) (pref file-header :lf64_hdr.e_phoff) + (pref program-header :lf64_

hdr.p_filesz) (#_elf64_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/experimentation/later/source/library/hash-cons.lisp =================================================================== --- /branches/experimentation/later/source/library/hash-cons.lisp (revision 8058) +++ /branches/experimentation/later/source/library/hash-cons.lisp (revision 8058) @@ -0,0 +1,498 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2005 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 OpenMCL 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 OpenMCL 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/experimentation/later/source/library/lisp-package.lisp =================================================================== --- /branches/experimentation/later/source/library/lisp-package.lisp (revision 8058) +++ /branches/experimentation/later/source/library/lisp-package.lisp (revision 8058) @@ -0,0 +1,1649 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/lispequ.lisp =================================================================== --- /branches/experimentation/later/source/library/lispequ.lisp (revision 8058) +++ /branches/experimentation/later/source/library/lispequ.lisp (revision 8058) @@ -0,0 +1,1323 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 ,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-symmap-bit 23) +(defconstant $lfbits-trampoline-bit 24) +(defconstant $lfbits-evaluated-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-decls ; list of applicable decls + var-inittype + var-binding-info + var-refs +) + +(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) + +(def-accessors (logical-pathname) %svref + () ; 'logical-pathname + %pathname-directory + %pathname-name + %pathname-type + %logical-pathname-host + %logical-pathname-version) + +(defmacro %cons-pathname (directory name type &optional version) + `(%istruct 'pathname ,directory ,name ,type ,version)) + +(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 +) + + +;;;;;;;;;;;;; + +(defconstant $catch.tag 0) +(defconstant $catch.mvflag (+ $catch.tag 4)) +(defconstant $catch.dblink (+ $catch.mvflag 4)) +(defconstant $catch.vsp (+ $catch.dblink 4)) +(defconstant $catch.regs (+ $catch.vsp 4)) +(defconstant $catch.link (+ $catch.regs (* 4 5))) +(defconstant $catch.scgvll (+ $catch.link 4)) +(defconstant $catch.cs_area (+ $catch.scgvll 4)) +(defconstant $catch.pc (+ $catch.cs_area 4)) +(defconstant $catchfsize (+ $catch.pc 4)) + + +;;; 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.seed-1 + random.seed-2) + +;;; 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 +) + +;; 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))) + `(%istruct 'class-wrapper ,hash-index ,class nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing 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 +) + + +(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. + %class.direct-slots ; local slots + %class.slots ; all slots + %class.kernel-p ; true if a non-redefinable class + %class.local-default-initargs ; local default initargs alist + %class.default-initargs ; 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 nil ,name nil nil nil nil nil nil)) + + +(defmacro %cons-standard-class (name &optional + (metaclass-wrapper '*standard-class-wrapper*)) + `(%instance-vector ,metaclass-wrapper + nil nil ,name nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil) + +) + +(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 + ) + +;;; Hash table accessors. +(def-accessors (hash-table) %svref + nil ; 'HASH-TABLE + nhash.rehashF ; function: rehashes if necessary + 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 ; fixnum: bits for grow and rehash + nhash.count ; Number of entries + nhash.owner ; tcr of "owning" thread, else NIL. + nhash.fixnum ; fwdnum kernel-global + nhash.gc-count ; gc-count kernel-global + 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.rehash-lock ; exclusive lock for rehash + nhash.iterator ; current hash-table iterator + nhash.address-based ; hashes based on address + 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 + 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.class ; a class 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)) + + +(provide "LISPEQU") + +;;; End of lispequ.lisp Index: /branches/experimentation/later/source/library/loop.lisp =================================================================== --- /branches/experimentation/later/source/library/loop.lisp (revision 8058) +++ /branches/experimentation/later/source/library/loop.lisp (revision 8058) @@ -0,0 +1,2114 @@ +;;; -*- 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)) + (and (consp (cadr x)) (eq (caadr x) 'setf))) + 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))) + + +(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 (and data-type (subtypep data-type 'number)) + (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) + (coerce 0 data-type) + 0))) + + +(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)) + (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 (or initialization (loop-typed-init dtype))) + *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 'list) + (loop-make-iteration-variable var nil data-type))) + (multiple-value-bind (list-step step-function) (loop-list-step 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 ,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 *loop-real-data-type*) 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 ~S 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 (consp key-var) + (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (consp val-var) + (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/experimentation/later/source/library/mac-file-io.lisp =================================================================== --- /branches/experimentation/later/source/library/mac-file-io.lisp (revision 8058) +++ /branches/experimentation/later/source/library/mac-file-io.lisp (revision 8058) @@ -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/experimentation/later/source/library/macptr-termination.lisp =================================================================== --- /branches/experimentation/later/source/library/macptr-termination.lisp (revision 8058) +++ /branches/experimentation/later/source/library/macptr-termination.lisp (revision 8058) @@ -0,0 +1,479 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/openmcl-gtk-support.lisp =================================================================== --- /branches/experimentation/later/source/library/openmcl-gtk-support.lisp (revision 8058) +++ /branches/experimentation/later/source/library/openmcl-gtk-support.lisp (revision 8058) @@ -0,0 +1,78 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; 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 :GTK)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; I don't know why it's necessary to explicitly open + ;; libgdk.so (which transitively opens half a dozen + ;; other libraries), while opening libgtk.so by itself + ;; would complain about unresolved symbols from libgdk. + (dolist (lib '("libgdk.so" "libgtk.so")) + (open-shared-library lib))) + + +;;; 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* "OpenMCL") + +(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/experimentation/later/source/library/parse-ffi.lisp =================================================================== --- /branches/experimentation/later/source/library/parse-ffi.lisp (revision 8058) +++ /branches/experimentation/later/source/library/parse-ffi.lisp (revision 8058) @@ -0,0 +1,1396 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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-struct-return-explicit* nil) +(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-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) +(defvar *ffi-macros*) +(defvar *ffi-vars*) + +(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-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 (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 (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 b a) b)) + (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) + (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)))) + (: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 (getf (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-word) + (32 '(:signed 32)) + (64 '(:signed 64)))) + (:unsigned '(:unsigned 32)) + (:unsigned-long (ecase (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) + #|(: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-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))) + (: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 *ffi-global-unions* + (setf (gethash (ffi-union-reference u) *ffi-global-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 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 record-global-struct (s) + (when *ffi-global-structs* + (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 :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) 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))) + (when (ffi-record-type-p retval) + (if *ffi-struct-return-explicit* + (format t "~&;; Note: explict struct return in function ~s" (ffi-function-string ffi-function)) + (progn + (push retval args) + (push `(:pointer ,retval) (ffi-function-arglist ffi-function)) + (setf (ffi-function-return-value ffi-function) *ffi-void-reference*) + (setq retval *ffi-void-reference*)))) + (dolist (arg args) (ensure-referenced-type-defined arg)) + (ensure-referenced-type-defined retval) + (record-global-function ffi-function))) + +(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-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 in nil :eof) (read in nil :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))))) + (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-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) + (*ffi-struct-return-explicit* nil) + (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-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-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) '|:|) + (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 `(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)) + +(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/experimentation/later/source/library/pascal-strings.lisp =================================================================== --- /branches/experimentation/later/source/library/pascal-strings.lisp (revision 8058) +++ /branches/experimentation/later/source/library/pascal-strings.lisp (revision 8058) @@ -0,0 +1,107 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/ppc-linux-syscalls.lisp =================================================================== --- /branches/experimentation/later/source/library/ppc-linux-syscalls.lisp (revision 8058) +++ /branches/experimentation/later/source/library/ppc-linux-syscalls.lisp (revision 8058) @@ -0,0 +1,234 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 ) + + + +#+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/experimentation/later/source/library/pty.lisp =================================================================== --- /branches/experimentation/later/source/library/pty.lisp (revision 8058) +++ /branches/experimentation/later/source/library/pty.lisp (revision 8058) @@ -0,0 +1,143 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2002 Clozure Associates. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/sharp-comma.lisp =================================================================== --- /branches/experimentation/later/source/library/sharp-comma.lisp (revision 8058) +++ /branches/experimentation/later/source/library/sharp-comma.lisp (revision 8058) @@ -0,0 +1,32 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/splay-tree.lisp =================================================================== --- /branches/experimentation/later/source/library/splay-tree.lisp (revision 8058) +++ /branches/experimentation/later/source/library/splay-tree.lisp (revision 8058) @@ -0,0 +1,208 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/syscall.lisp =================================================================== --- /branches/experimentation/later/source/library/syscall.lisp (revision 8058) +++ /branches/experimentation/later/source/library/syscall.lisp (revision 8058) @@ -0,0 +1,68 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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/experimentation/later/source/library/x8664-freebsd-syscalls.lisp =================================================================== --- /branches/experimentation/later/source/library/x8664-freebsd-syscalls.lisp (revision 8058) +++ /branches/experimentation/later/source/library/x8664-freebsd-syscalls.lisp (revision 8058) @@ -0,0 +1,272 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 17 (: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 ) + + + +#+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/experimentation/later/source/library/x8664-linux-syscalls.lisp =================================================================== --- /branches/experimentation/later/source/library/x8664-linux-syscalls.lisp (revision 8058) +++ /branches/experimentation/later/source/library/x8664-linux-syscalls.lisp (revision 8058) @@ -0,0 +1,261 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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::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/experimentation/later/source/lisp-kernel/.cvsignore =================================================================== --- /branches/experimentation/later/source/lisp-kernel/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/lisp-kernel/Threads.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/Threads.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/Threads.h (revision 8058) @@ -0,0 +1,199 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include +#include +#include +#include +#include +#include +#include +#undef USE_MACH_SEMAPHORES +#undef USE_POSIX_SEMAPHORES +#ifdef DARWIN +#define USE_MACH_SEMAPHORES 1 +#endif +#ifndef USE_MACH_SEMAPHORES +#define 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 +#include +#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_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 + +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) + + +LispObj create_system_thread(size_t stack_size, + void* stackaddr, + void* (*start_routine)(void *), + 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 +#endif +#endif +#ifdef FREEBSD +#define IMAGE_BASE_ADDRESS 0x300000000000L /* 0x100000000L */ +#endif +#ifdef SOLARIS +#define IMAGE_BASE_ADDRESS 0xfffffc7fff000000L +#endif +#ifdef DARWIN +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#endif +#endif +#endif + +#ifdef X8664 +#define PURESPACE_RESERVE 0x40000000 /* 1GB */ +#else +#define PURESPACE_RESERVE 0x04000000 /* 64MB */ +#endif + +#define STATIC_RESERVE heap_segment_size + +#define STATIC_BASE_ADDRESS 0x00002000 + +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/experimentation/later/source/lisp-kernel/bits.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/bits.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/bits.c (revision 8058) @@ -0,0 +1,69 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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/experimentation/later/source/lisp-kernel/bits.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/bits.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/bits.h (revision 8058) @@ -0,0 +1,173 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 +#else +#define bitmap_shift 5 +#define BIT0_MASK 0x80000000U +#define ALL_ONES 0xFFFFFFFFU +#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) +{ + unsigned + 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 + return _sp; +} +#else +natural +current_stack_pointer(void); +#endif + +#ifdef __GNUC__ +static __inline__ unsigned +count_leading_zeros(natural w) __attribute__((always_inline)); + +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__ ("cntlzd %0,%1" : "=r" (lz) : "r" (w)); +#else + __asm__ ("cntlzw %0,%1" : "=r" (lz) : "r" (w)); +#endif +#endif /* PPC */ +#ifdef X86 +#ifdef X8664 + __asm__ ("bsr %1,%0" : "=r" (lz) : "r" (w)); + __asm__ ("xor $63,%0" : "=r" (lz)); +#else + __asm__ ("bsr %1,%0" : "=r" (lz) : "r" (w)); + __asm__ ("xor $31,%0" : "=r" (lz)); +#endif +#endif + return lz; +#endif +} +#else /* not __GNUC__ */ +unsigned +count_leading_zeros(natural); +#endif + +#endif /* __bits_h__ */ Index: /branches/experimentation/later/source/lisp-kernel/darwinppc/.cvsignore =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinppc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinppc/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/lisp-kernel/darwinppc/.gdbinit =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinppc/.gdbinit (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinppc/.gdbinit (revision 8058) @@ -0,0 +1,139 @@ +define header32 +x/x $arg0-6 +end + +define header64 +x/x $arg0-12 +end + +define lisp_string32 +call print_lisp_object($arg0) +end + +define lisp_string64 +call print_lisp_object($arg0) +end + +define pname32 +lisp_string (*($arg0-2)) +end + +# GDB's expression parser seems to have difficulty +# with this unless the temporary is used. +define pname64 +set $temp=*((long *)((long)($arg0-4))) +lisp_string64 $temp +end + +define ada + p *all_areas->succ +end + +define _TCR + p/x *(TCR *) $arg0 +end + +define tcr32 + _TCR $r13 +end + +define tcr64 + _TCR $r2 +end + +define regs32 + p/x ((ExceptionInformation *)$arg0)->uc_mcontext.ss +end + +define regs64 + p/x ((ExceptionInformation *)$arg0)->uc_mcontext64.ss +end + +define xpGPR32 + p/x ((unsigned long *)&((((ExceptionInformation *)$arg0)->uc_mcontext.ss)))[2+$arg1] +end + +define xpGPR64 + p/x ((unsigned long *)&((((ExceptionInformation *)$arg0)->uc_mcontext64.ss)))[2+$arg1] +end + +define xpPC32 + p/x ((ExceptionInformation *)$arg0)->uc_mcontext.ss.srr0 +end + +define xpPC64 + p/x ((ExceptionInformation *)$arg0)->uc_mcontext64.ss.srr0 +end + +set $ppc64=0 + +define lisp_string + if $ppc64 + lisp_string64 $arg0 + else + lisp_string32 $arg0 + end +end + +define pname + if $ppc64 + pname64 $arg0 + else + pname32 $arg0 + end +end + +define tcr + if $ppc64 + tcr64 + else + tcr32 + end +end + +define regs + if $ppc64 + regs64 $arg0 + else + regs32 $arg0 + end +end + +define xpGPR + if $ppc64 + xpGPR64 $arg0 $arg1 + else + xpGPR32 $arg0 $arg1 + end +end + +define xpPC + if $ppc64 + xpPC64 $arg0 + else + xpPC32 $arg0 + end +end + +define header + if $ppc64 + header64 $arg0 + else + header32 $arg0 + end +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 SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGEMT pass nostop noprint +# Work around apparent Apple GDB bug +handle SIGTTIN nopass nostop noprint Index: /branches/experimentation/later/source/lisp-kernel/darwinppc/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinppc/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinppc/Makefile (revision 8058) @@ -0,0 +1,125 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +# For versions of GCC prior to 3.3, the option "-traditional-cpp" meant +# "don't use precompiled headers", which was good advice since they didn't +# work too well. Beginning with GCC 3.3, the "-traditional-cpp" means +# "use a broken preprocessor", which is (in a sense) the opposite of what +# it used to mean. + +# Try to determine the version of GCC in use. Invoke gcc with the +# -v flag, and look for a line containing the phrase "specs from" in +# the output. Use sed to extract the full pathname of ths specs file +# printed in that line, then strip off the trailing "/specs". +gccdir = $(shell $(CC) -v 2>&1 | grep "specs from" | sed -e 's/.*from //' -e 's|/specs||') +# $(gccdir) is set to the directory containing the specs file, without the +# trailing slash. The make intrinsic 'notdir' will strip a leading directory +# prefix from that pathname, leaving us with a string that should match +# the gcc version number +ifneq ($(gccdir),) +gccversion:=$(notdir $(gccdir)) +oldgcc:=$(shell expr $(gccversion) "<" "3.3") +pregcc4:=$(shell expr $(gccversion) "<" "4.0") +ifeq ($(oldgcc),1) +BROKEN_PREPROCESSOR_WORKAROUND = -traditional-cpp +endif +endif + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + +OPENMCL_MAJOR_VERSION=0 +OPENMCL_MINOR_VERSION=14 + +VPATH = .. +RM = /bin/rm +LD = ld +LDFLAGS = -arch ppc -dynamic -o $@ -e start -pagezero_size 0x1000 -seg1addr 0x00001000 -sectalign __TEXT __text 0x1000 +AS = as +M4 = gm4 +M4FLAGS = -DDARWIN -DPPC +ASFLAGS = -arch ppc -force_cpusubtype_ALL +CDEFINES = -DDARWIN -DPPC $(BROKEN_PREPROCESSOR_WORKAROUND) #-DDEBUG -DGC_INTEGRITY_CHECKING +CDEBUG = -g +COPT = -O2 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c -arch ppc $< $(CDEFINES) $(CDEBUG) $(COPT) -Wno-deprecated-declarations -mmacosx-version-min=10.3.9 $(MDYNAMIC_NO_PIC) -o $@ + +SPOBJ = ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + thread_manager.o lisp-debug.o image.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= imports.o $(COBJ) ppc-asmutils.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants32.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h lisptypes.h ppc-constants32.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dppccl + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem + +# gcc 4.0 and later want to use -lSystemStubs for many of the +# runtime support functions that were in -lgcc in previous +# versions. 'pregcc4' may have been set above. +ifeq ($(pregcc4),1) +OSMIDDLELIBS = -lgcc +else +OSMIDDLELIBS = -lSystemStubs +endif + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dppccl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dppccl + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +strip: ../../dppccl + strip -s retain ../../dppccl Index: /branches/experimentation/later/source/lisp-kernel/darwinppc/retain =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinppc/retain (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinppc/retain (revision 8058) @@ -0,0 +1,3 @@ +#symbols that must be retained in a lisp kernel image +# % strip -s dppccl +_catch_exception_raise Index: /branches/experimentation/later/source/lisp-kernel/darwinppc64/.cvsignore =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinppc64/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinppc64/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/lisp-kernel/darwinppc64/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinppc64/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinppc64/Makefile (revision 8058) @@ -0,0 +1,129 @@ +# +# Copyright (C) 2005 Clozure Associates and contributors. +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +# For versions of GCC prior to 3.3, the option "-traditional-cpp" meant +# "don't use precompiled headers", which was good advice since they didn't +# work too well. Beginning with GCC 3.3, the "-traditional-cpp" means +# "use a broken preprocessor", which is (in a sense) the opposite of what +# it used to mean. + +# Try to determine the version of GCC in use. Invoke gcc with the +# -v flag, and look for a line containing the phrase "specs from" in +# the output. Use sed to extract the full pathname of ths specs file +# printed in that line, then strip off the trailing "/specs". +gccdir = $(shell $(CC) -v 2>&1 | grep "specs from" | sed -e 's/.*from //' -e 's|/specs||') +# $(gccdir) is set to the directory containing the specs file, without the +# trailing slash. The make intrinsic 'notdir' will strip a leading directory +# prefix from that pathname, leaving us with a string that should match +# the gcc version number +#gccversion:=$(notdir $(gccdir)) +#oldgcc:=$(shell expr $(gccversion) "<" "3.3") +#ifeq ($(oldgcc),1) +#BROKEN_PREPROCESSOR_WORKAROUND = -traditional-cpp +#endif + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + +OPENMCL_MAJOR_VERSION=0 +OPENMCL_MINOR_VERSION=14 + +VPATH = .. +RM = /bin/rm +LD = ld64 + +### The -pagezero_size/-seg1addr args are an attempt to work around a +### bug (#4057702) in ld64. + +### The -seg1addr and -pagezero_size arguments below are nonsense; +### early versions of ld64 were/are broken. +LDFLAGS = -M -arch ppc64 -dynamic -o $@ -e start -pagezero_size 0x1000 -seg1addr 0x1000 -sectalign __TEXT __text 0x1000 +AS = as +M4 = gm4 +M4FLAGS = -DDARWIN -DPPC -DPPC64 +ASFLAGS = -arch ppc64 +CDEFINES = -DDARWIN -DPPC -DPPC64 $(BROKEN_PREPROCESSOR_WORKAROUND) +CDEBUG = -g +COPT = #-O2 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< -arch ppc64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.3.9 -o $@ + +SPOBJ = ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + thread_manager.o lisp-debug.o image.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= imports.o $(COBJ) ppc-asmutils.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s \ + ppc-constants64.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h lisptypes.h ppc-constants64.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dppccl64 + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem -lmx + +# If the linker can find an absolute path to -lSystemStubs, use +# -lSystemStubs; otherwise, just use libgcc.a +SYSTEMSTUBSPATH = $(shell $(CC) --print-file-name=libSystemStubs.a) +SYSTEMSTUBSABSOLUTE = $(shell expr $(SYSTEMSTUBSPATH) : "^/*") +ifeq ($(SYSTEMSTUBSABSOLUTE),1) +OSMIDDLELIBS = -lSystemStubs +else +OSMIDDLELIBS = -lgcc +endif + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dppccl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dppccl64 + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +strip: ../../dppccl64 + strip -s retain ../../dppccl64 Index: /branches/experimentation/later/source/lisp-kernel/darwinx8664/.gdbinit =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinx8664/.gdbinit (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinx8664/.gdbinit (revision 8058) @@ -0,0 +1,85 @@ +define x86_lisp_string +x/s $arg0-5 +end + +define x86pname +set $temp=*((long *)((long)($arg0-6))) +x86_lisp_string $temp +end + +define gtra +br *$r10 +cont +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 SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGEMT pass nostop noprint +# Work around apparent Apple GDB bug +handle SIGTTIN nopass nostop noprint +# Work around Leopard bug du jour +handle SIGSYS pass nostop noprint + Index: /branches/experimentation/later/source/lisp-kernel/darwinx8664/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/darwinx8664/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/darwinx8664/Makefile (revision 8058) @@ -0,0 +1,115 @@ +# +# Copyright (C) 2005 Clozure Associates and contributors. +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + + + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + + +VPATH = .. +RM = /bin/rm +LD = ld64 + + +### Current ld64 bugs include the claim that 0x1000 isn't a power of 2. +### Gosh. I always thought that it was. Go know, right ? +LDFLAGS = -arch x86_64 -dynamic -o $@ -e start -pagezero_size 0x1000 -seg1addr 0x00001000 + + +AS = as +M4 = gm4 +### +### DARWIN_GS_HACK enables some awful, dangerous, and slow workarounds +### for the fact that early versions of x86-64 Darwin don't provide +### working mechanisms for threads to address thread-local-data +### relative to a spare segment register. We instead use the +### undocumented mechanism which the pthreads library uses to +### keep pthread data in %gs, and switch %gs between pthread data +### when running foreign code and lisp tcr data when running lisp +### code. Hopefully, we won't have to do this for very long. +### +### (Things like i386_set_ldt() are defined, but not implemented +### correctly on the libc side and not implemented at all on the +### Mach kernel side.) +### +M4FLAGS = -DDARWIN -DX86 -DX8664 -DDARWIN_GS_HACK +ASFLAGS = -arch x86_64 -g +CDEFINES = -DDARWIN -DX86 -DX8664 -DDARWIN_GS_HACK +CDEBUG = -g +COPT = -O2 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< -arch x86_64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.4 -isysroot /Developer/SDKs/MacOSX10.4u.sdk -o $@ + +SPOBJ = 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 \ + thread_manager.o lisp-debug.o image.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= imports.o $(COBJ) x86-asmutils64.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 lisptypes.h x86-constants64.h x86-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dx86cl64 + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem + +OSMIDDLELIBS = + + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dx86cl64 + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +strip: ../../dx86cl64 + strip -s retain ../../dx86cl64 Index: /branches/experimentation/later/source/lisp-kernel/errors.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/errors.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/errors.s (revision 8058) @@ -0,0 +1,216 @@ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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_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) + + +/* These are the "old" error constants that %ERR-DISP understands */ + +define([deferr],[ +$1 = $2<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 SIGEMT pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint Index: /branches/experimentation/later/source/lisp-kernel/freebsdx8664/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/freebsdx8664/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/freebsdx8664/Makefile (revision 8058) @@ -0,0 +1,78 @@ +# +# Copyright (C) 2005-2006 Clozure Associates +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL 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 = -DFREEBSD -DX86 -DX8664 -DHAVE_TLS +CDEFINES = -DFREEBSD -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS +CDEBUG = -g +COPT = #-O2 + + + + +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 + +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 + + +KSPOBJ = $(SPOBJ) +all: ../../fx86cl64 + + +OSLIBS = -lm -lthr + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m64 -o $@ + +LINKSCRIPTFILE = # ./elf_x86_64.x +LINKSCRIPT = # -T $(LINKSCRIPTFILE) + +../../fx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(LINKSCRIPTFILE) + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(LINKSCRIPT) -o $@ $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../fx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../fx86cl64 + strip -g ../../fx86cl64 Index: /branches/experimentation/later/source/lisp-kernel/gc-common.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/gc-common.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/gc-common.c (revision 8058) @@ -0,0 +1,1162 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 + + + +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 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 = 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, + npairs = (header_element_count(hashp->header) - + ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1; + LispObj *pairp = (LispObj*) (hashp+1), weakelement; + Boolean + weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); + bitvector markbits = GCmarkbits; + int tag; + + while (npairs--) { + if (weak_on_value) { + weakelement = pairp[1]; + } else { + weakelement = pairp[0]; + } + 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; + pairp[1] = lisp_nil; + hashp->weak_deletions_count += (1<flags, key_dnode, val_dnode; + Boolean + marked_new = false, + key_marked, + val_marked, + weak_value = ((flags & nhash_weak_value_mask) != 0); + int + skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1, + key_tag, + val_tag, + i; + LispObj + *pairp = (LispObj*) (hashp+1), + key, + val; + + /* Mark everything in the header */ + + for (i = 2; i<= skip; i++) { + mark_root(deref(ptr_to_lispobj(hashp),i)); + } + + elements -= skip; + + for (i = 0; i> 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 +markhtabvs() +{ + LispObj this, header, pending; + int subtag; + bitvector markbits = GCmarkbits; + hash_table_vector_header *hashp; + Boolean marked_new; + + do { + pending = (LispObj) NULL; + marked_new = false; + + while (GCweakvll) { + this = GCweakvll; + GCweakvll = deref(this,1); + + header = header_of(this); + subtag = header_subtag(header); + + if (subtag == subtag_weak) { + natural weak_type = deref(this,2); + deref(this,1) = pending; + pending = this; + 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), i; + + hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this)); + if (hashp->flags & nhash_weak_mask) { + deref(this,1) = pending; + pending = this; + if (mark_weak_hash_vector(hashp, elements)) { + marked_new = true; + } + } else { + deref(this,1) = (LispObj)NULL; + for (i = 2; i <= elements; i++) { + mark_root(deref(this,i)); + } + } + } else { + Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this); + } + } + + 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) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + + subtag = header_subtag(header_of(this)); + if (subtag == subtag_weak) { + reapweakv(this); + } else { + reaphashv(this); + } + } + + /* Finally, mark the termination lists in all terminatable weak vectors + They are now linked together on GCweakvll. + This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, + but it will force terminatable popualations to hold on to each other + (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). + */ + pending = GCweakvll; + GCweakvll = (LispObj)NULL; + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + mark_root(deref(this,1+3)); + } +} + +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) { + mark_xp(xp); + } + + for (xframes = (xframe_list *) tcr->xframe; + xframes; + xframes = xframes->prev) { + mark_xp(xframes->curr); + } +} + + +void *postGCptrs = NULL; + +void +postGCfree(void *p) +{ + *(void **)p = postGCptrs; + postGCptrs = p; +} + +void +freeGCptrs() +{ + void *p, *next; + + for (p = postGCptrs; p; p = next) { + next = *((void **)p); + free(p); + } + postGCptrs = NULL; +} + +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: + /* (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 + +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; + + while ((next = *prev) != (LispObj)NULL) { + *prev = node_forwarding_address(next); + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + +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) { + 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, mask, 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) +{ + xframe_list *xframes = (tcr->xframe); + struct timeval start, stop; + area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; + unsigned timeidx = 1; + xframe_list *x; + LispObj + pkg, + itabvec = 0; + BytePtr oldfree = a->active; + TCR *other_tcr; + natural static_dnodes; + +#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; + } + + if (GCverbose) { + if (GCephemeral_low) { + fprintf(stderr, + "\n\n;;; Starting Ephemeral GC of generation %d", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); + } else { + fprintf(stderr,"\n\n;;; Starting full GC"); + } + fprintf(stderr, ", %ld bytes allocated.\n", area_dnode(oldfree,a->low) << dnode_shift); + } + + get_time(start); + 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); + GCweakvll = (LispObj)NULL; + + 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); + } + } + } + } + + { + 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_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 (lisp_global(OLDEST_EPHEMERAL)) { + 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)) { + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + *raw = unbound_marker; + } + } + } + } + + reap_gcable_ptrs(); + + 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_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()); + 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) { + if (justfreed <= heap_segment_size) { + justfreed = 0; + } + if (note == tenured_area) { + fprintf(stderr,";;; Finished full GC. Freed %lld bytes in %d.%06d s\n\n", justfreed, elapsed.tv_sec, elapsed.tv_usec); + } else { + fprintf(stderr,";;; Finished Ephemeral GC of generation %d. Freed %lld bytes in %d.%06d s\n\n", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, + justfreed, + elapsed.tv_sec, elapsed.tv_usec); + } + } + } + } +} Index: /branches/experimentation/later/source/lisp-kernel/gc.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/gc.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/gc.h (revision 8058) @@ -0,0 +1,193 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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) + +#ifdef PPC64 +#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 + + +#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_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; +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 markhtabvs(void); +void mark_tcr_tlb(TCR *); +void mark_tcr_xframes(TCR *); +void postGCfree(void *); +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 */ + +void mark_root(LispObj); +void mark_xp(ExceptionInformation *); +LispObj dnode_forwarding_address(natural, int); +LispObj locative_forwarding_address(LispObj); +void check_refmap_consistency(LispObj *, LispObj *, bitvector); +void check_all_areas(void); +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); +LispObj * skip_over_ivector(natural, LispObj); +int purify(TCR *, signed_natural); +int impurify(TCR *, signed_natural); + +#endif /* __GC_H__ */ Index: /branches/experimentation/later/source/lisp-kernel/image.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/image.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/image.c (revision 8058) @@ -0,0 +1,528 @@ +/* + Copyright (C) 2002 Clozure Associates + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 +#include +#include + + + +#ifdef PPC64 +#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 X8664 + if (header_subtag(w0) == subtag_function) { + int skip = (int) start[1]; + + start += skip; + if (((LispObj) start) & node_size) { + --start; + } + w0 = *start; + fulltag = fulltag_of(w0); + } +#endif + + if ((w0 >= low) && (w0 < high) && + ((1<= low) && (w0 < high) && + ((1<= 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(stderr, "Heap image is too old for this kernel.\n"); + return false; + } + if (version > ABI_VERSION_MAX) { + fprintf(stderr, "Heap image is too new for this kernel.\n"); + return false; + } + flags = header->flags; + if (flags != PLATFORM) { + fprintf(stderr, "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; + int + mem_size = sect->memory_size; + void *addr; + area *a; + + advance = mem_size; + switch(sect->code) { + case AREA_READONLY: + addr = mmap(pure_space_active, + align_to_power_of_2(mem_size,log2_page_size), + PROT_READ | PROT_EXEC, + MAP_PRIVATE | MAP_FIXED, + fd, + pos); + if (addr != pure_space_active) { + 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: + addr = mmap(static_space_active, + align_to_power_of_2(mem_size,log2_page_size), + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_FIXED, + fd, + pos); + if (addr != static_space_active) { + 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); + addr = mmap(a->low, + align_to_power_of_2(mem_size,log2_page_size), + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_FIXED, + fd, + pos); + if (addr != a->low) { + 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 X8664 + image_nil = (LispObj)(a->low) + (1024*4) + fulltag_nil; +#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: + lisp_global(HEAP_START) = ptr_to_lispobj(a->low); + lisp_global(HEAP_END) = ptr_to_lispobj(a->high); + 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 + (tenured_area->static_dnodes << dnode_shift)), + *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]) { + /* Leave NULL 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; + } + } +} + +OSErr +write_area_pages(int fd, area *a) +{ + natural total = a->active - a->low, count, done=0; + signed_natural n; + char buffer[32768]; + + while (total) { + if (total > 32768) { + count = 32768; + } else { + count = total; + } + memmove(buffer,a->low+done,count); + n = write(fd, buffer, count); + if (n < 0) { + return n; + } + total -= n; + done += n; + } + return 0; +} + + +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; +} + + +OSErr +save_application(unsigned fd) +{ + 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); + + /* + 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: + break; + default: + lisp_global(i) = 0; + } + } + + for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { + natural n, nstatic; + a = areas[i]; + seek_to_next_page(fd); + n = sections[i].memory_size; + nstatic = sections[i].static_dnodes; + if (a->code == AREA_READONLY) { + /* + Darwin seems to have problems writing the readonly area for + some reason. It seems to work better to write a page at a + time. + */ + if (write_area_pages(fd, a) != 0) { + return errno; + } + } else { + if (write(fd, a->low, n) != 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)) { + fsync(fd); + close(fd); + return 0; + } + i = errno; + close(fd); + return i; +} + + + + Index: /branches/experimentation/later/source/lisp-kernel/image.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/image.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/image.h (revision 8058) @@ -0,0 +1,96 @@ +/* + Copyright (C) 2002 Clozure Associates + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 { + unsigned long code; + area *area; + unsigned long memory_size; + unsigned long 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 1018 +#define ABI_VERSION_CURRENT 1018 +#define ABI_VERSION_MAX 1018 + +#define NUM_IMAGE_SECTIONS 4 /* used to be 3 */ Index: /branches/experimentation/later/source/lisp-kernel/imports.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/imports.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/imports.s (revision 8058) @@ -0,0 +1,103 @@ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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(allocate_tstack_holding_area_lock) + defimport(allocate_vstack_holding_area_lock) + defimport(register_cstack_holding_area_lock) + defimport(raise_thread_interrupt) + defimport(get_r_debug) + defimport(restore_soft_stack_limit) + defimport(lisp_egc_control) + defimport(lisp_bug) + defimport(xNewThread) + defimport(xYieldToThread) + 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) + + .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/experimentation/later/source/lisp-kernel/kernel-globals.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/kernel-globals.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/kernel-globals.h (revision 8058) @@ -0,0 +1,32 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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/experimentation/later/source/lisp-kernel/linuxppc/.cvsignore =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/lisp-kernel/linuxppc/.gdbinit =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc/.gdbinit (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc/.gdbinit (revision 8058) @@ -0,0 +1,120 @@ +directory lisp-kernel + +define header32 +x/x $arg0-6 +end + +define header64 +x/x $arg0-12 +end + +define lisp_string32 +x/s ($arg0-2) +end + +define lisp_string64 +x/s (($arg0)-4) +end + +define pname32 +lisp_string32 (*($arg0-2)) +end + +# GDB's expression parser seems to have difficulty +# with this unless the temporary is used. +define pname64 +set $temp=*((long *)((long)($arg0-4))) +lisp_string64 $temp +end + +define ada + p *all_areas->succ +end + +define _TCR + p/x *(TCR *) $arg0 +end + +define tcr32 + _TCR $r13 +end + +define tcr64 + _TCR $r2 +end + +define regs32 + p/x *(((struct pt_regs **)$arg0)[12]) +end + +define regs64 + p/x * (((ExceptionInformation *)$arg0)->uc_mcontext.regs) +end + +define xpGPR + p/x (((struct pt_regs **)$arg0)[12])->gpr[$arg1] +end + +define xpPC + p/x ((ExceptionInformation *)$arg0)->uc_mcontext.regs->nip +end + +define lisp_string + if $ppc64 + lisp_string64 $arg0 + else + lisp_string32 $arg0 + end +end + +define pname + if $ppc64 + pname64 $arg0 + else + pname32 $arg0 + end +end + +define tcr + if $ppc64 + tcr64 + else + tcr32 + end +end + +define regs + if $ppc64 + regs64 $arg0 + else + regs32 $arg0 + end +end + +define xpGPR + if $ppc64 + xpGPR64 $arg0 $arg1 + else + xpGPR32 $arg0 $arg1 + end +end + +define lisp + call print_lisp_object($arg0) +end + +set $ppc64=0 + + +break Bug + +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 + +display/i $pc Index: /branches/experimentation/later/source/lisp-kernel/linuxppc/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc/Makefile (revision 8058) @@ -0,0 +1,104 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL 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 +# Versions of GNU as >= 2.9.1 all seem to work +# AS = gas-2.9.1 +AS = as +M4 = m4 +ASFLAGS = -mregnames -mppc32 -maltivec +M4FLAGS = -DLINUX -DPPC +CDEFINES = -DLINUX -DPPC -D_REENTRANT -D_GNU_SOURCE +CDEBUG = -g +COPT = -O2 + +# 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 + +# The only version of GCC I have that supports both ppc32 and ppc64 +# compilation uses the -m32 option to target ppc32. This may not be +# definitive; there seem to be a bewildering array of similar options +# in other GCC versions. It's assumed here that if "-m32" is recognized, +# it's required as well. + +PPC32 = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-m32 ") && /bin/echo "-m32") + +# Likewise, some versions of GAS may need a "-a32" flag, to force the +# output file to be 32-bit compatible. + +A32 = $(shell ($(AS) --help -v 2>&1 | grep -q -e "-a32") && /bin/echo "-a32") + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(A32) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(PPC32) -o $@ + +SPOBJ = pad.o ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= $(COBJ) ppc-asmutils.o imports.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants32.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h ppc-constants32.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ = $(SPOBJ) +all: ../../ppccl + + +# No: + +# KSPOBJ= +# all: ../../ppccl ../../subprims.so + +OSLIBS = -ldl -lm -lpthread + + +../../ppccl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) + $(CC) $(PPC32) $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ -T ./elf32ppclinux.x $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../ppccl + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../ppccl + strip -g ../../ppccl Index: /branches/experimentation/later/source/lisp-kernel/linuxppc/elf32ppclinux.x =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc/elf32ppclinux.x (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc/elf32ppclinux.x (revision 8058) @@ -0,0 +1,253 @@ +OUTPUT_FORMAT("elf32-powerpc", "elf32-powerpc", + "elf32-powerpc") +OUTPUT_ARCH(powerpc:common) +ENTRY(_start) +SEARCH_DIR(/lib); SEARCH_DIR(/usr/lib); SEARCH_DIR(/usr/local/lib); SEARCH_DIR(/usr/powerpc-linux/lib); +/* Do we need any of these for elf? + __DYNAMIC = 0; */ +VERSION {default { global : __trampoline_setup ; } ;} +SECTIONS +{ + PROVIDE (__executable_start = 0x00001000); + . = 0x00001000; + .pad : { pad.o(.text) } + .subprims ALIGN(0x1000) : + { + ppc-spjump.o(.text) + ppc-spentry.o(.text) + ppc-subprims.o(.text) + } + /* Read-only sections, merged into text segment: */ +/* . = 0x10000000; */ + .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.init : { *(.rel.init) } + .rela.init : { *(.rela.init) } + .rel.text : + { + *(.rel.text) + *(.rel.text.*) + *(.rel.gnu.linkonce.t*) + } + .rela.text : + { + *(.rela.text) + *(.rela.text.*) + *(.rela.gnu.linkonce.t*) + } + .rel.fini : { *(.rel.fini) } + .rela.fini : { *(.rela.fini) } + .rel.rodata : + { + *(.rel.rodata) + *(.rel.rodata.*) + *(.rel.gnu.linkonce.r*) + } + .rela.rodata : + { + *(.rela.rodata) + *(.rela.rodata.*) + *(.rela.gnu.linkonce.r*) + } + .rel.data : + { + *(.rel.data) + *(.rel.data.*) + *(.rel.gnu.linkonce.d*) + } + .rela.data : + { + *(.rela.data) + *(.rela.data.*) + *(.rela.gnu.linkonce.d*) + } + .rel.ctors : { *(.rel.ctors) } + .rela.ctors : { *(.rela.ctors) } + .rel.dtors : { *(.rel.dtors) } + .rela.dtors : { *(.rela.dtors) } + .rel.got : { *(.rel.got) } + .rela.got : { *(.rela.got) } + .rel.sdata : + { + *(.rel.sdata) + *(.rel.sdata.*) + *(.rel.gnu.linkonce.s*) + } + .rela.sdata : + { + *(.rela.sdata) + *(.rela.sdata.*) + *(.rela.gnu.linkonce.s*) + } + .rel.sbss : { *(.rel.sbss) } + .rela.sbss : { *(.rela.sbss) } + .rel.sdata2 : { *(.rel.sdata2) } + .rela.sdata2 : { *(.rela.sdata2) } + .rel.sbss2 : { *(.rel.sbss2) } + .rela.sbss2 : { *(.rela.sbss2) } + .rel.bss : { *(.rel.bss) } + .rela.bss : { *(.rela.bss) } + .rel.plt : { *(.rel.plt) } + .rela.plt : { *(.rela.plt) } + .init : + { + KEEP (*(.init)) + } =0 + .text : + { + *(.text) + *(.text.*) + *(.stub) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + *(.gnu.linkonce.t*) + } =0 + .fini : + { + KEEP (*(.fini)) + } =0 + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata) *(.rodata.*) *(.gnu.linkonce.r*) } + .rodata1 : { *(.rodata1) } + .sdata2 : { *(.sdata2) } + .sbss2 : { *(.sbss2) } + /* 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(0x10000) + (. & (0x10000 - 1)); + /* 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(32 / 8); + PROVIDE (__preinit_array_start = .); + .preinit_array : { *(.preinit_array) } + PROVIDE (__preinit_array_end = .); + PROVIDE (__init_array_start = .); + .init_array : { *(.init_array) } + PROVIDE (__init_array_end = .); + PROVIDE (__fini_array_start = .); + .fini_array : { *(.fini_array) } + PROVIDE (__fini_array_end = .); + .data : + { + *(.data) + *(.data.*) + *(.gnu.linkonce.d*) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + .eh_frame : { *(.eh_frame) } + .gcc_except_table : { *(.gcc_except_table) } + .got1 : { *(.got1) } + .got2 : { *(.got2) } + .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)) + } + .got : { *(.got.plt) *(.got) } + .dynamic : { *(.dynamic) } + /* We want the small data sections together, so single-instruction offsets + can access them all, and initialized data all before uninitialized, so + we can shorten the on-disk segment size. */ + .sdata : + { + PROVIDE (_SDA_BASE_ = .); + *(.sdata) + *(.sdata.*) + *(.gnu.linkonce.s.*) + } + _edata = .; + PROVIDE (edata = .); + __bss_start = .; + .sbss : + { + PROVIDE (__sbss_start = .); + PROVIDE (___sbss_start = .); + *(.dynsbss) + *(.sbss) + *(.sbss.*) + *(.scommon) + PROVIDE (__sbss_end = .); + PROVIDE (___sbss_end = .); + } + .plt : { *(.plt) } + .bss : + { + *(.dynbss) + *(.bss) + *(.bss.*) + *(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(32 / 8); + } + . = ALIGN(32 / 8); + _end = .; + PROVIDE (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) } + .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/ : { *(.fixup) } + /* These must appear regardless of . */ +} Index: /branches/experimentation/later/source/lisp-kernel/linuxppc64/.cvsignore =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc64/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc64/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/lisp-kernel/linuxppc64/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc64/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc64/Makefile (revision 8058) @@ -0,0 +1,92 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL 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 +# Versions of GNU as >= 2.9.1 all seem to work +# AS = gas-2.9.1 +AS = as +M4 = m4 +ASFLAGS = -mregnames -mppc64 -a64 -maltivec +M4FLAGS = -DLINUX -DPPC -DPPC64 +CDEFINES = -DLINUX -D_REENTRANT -DPPC -DPPC64 -D_GNU_SOURCE +CDEBUG = -g +COPT = #-O2 + +# 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) -m64 -o $@ + +SPOBJ = pad.o ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= $(COBJ) ppc-asmutils.o imports.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants64.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h ppc-constants64.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ = $(SPOBJ) +all: ../../ppccl64 + + +# No: + +# KSPOBJ= +# all: ../../ppccl64 ../../subprims.so + +OSLIBS = -ldl -lm -lpthread + + +../../ppccl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ -T ./elf64ppc.x $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../ppccl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../ppccl64 + strip -g ../../ppccl64 Index: /branches/experimentation/later/source/lisp-kernel/linuxppc64/elf64ppc.x =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxppc64/elf64ppc.x (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxppc64/elf64ppc.x (revision 8058) @@ -0,0 +1,229 @@ +/* Script for -z combreloc: combine and sort reloc sections */ +OUTPUT_FORMAT("elf64-powerpc", "elf64-powerpc", + "elf64-powerpc") +OUTPUT_ARCH(powerpc:common64) +ENTRY(_start) +SEARCH_DIR("/usr/local/lib64"); SEARCH_DIR("/lib64"); SEARCH_DIR("/usr/lib64"); 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 = 0x00001000); . = 0x00001000 + SIZEOF_HEADERS; + .pad : { pad.o(.text) } + .subprims ALIGN(0x1000) : + { + ppc-spjump.o(.text) + ppc-spentry.o(.text) + ppc-subprims.o(.text) + } + .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.sdata .rel.sdata.* .rel.gnu.linkonce.s.*) + *(.rel.sbss .rel.sbss.* .rel.gnu.linkonce.sb.*) + *(.rel.sdata2 .rel.sdata2.* .rel.gnu.linkonce.s2.*) + *(.rel.sbss2 .rel.sbss2.* .rel.gnu.linkonce.sb2.*) + *(.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.toc) + *(.rela.opd) + *(.rela.sdata .rela.sdata.* .rela.gnu.linkonce.s.*) + *(.rela.sbss .rela.sbss.* .rela.gnu.linkonce.sb.*) + *(.rela.sdata2 .rela.sdata2.* .rela.gnu.linkonce.s2.*) + *(.rela.sbss2 .rela.sbss2.* .rela.gnu.linkonce.sb2.*) + *(.rela.bss .rela.bss.* .rela.gnu.linkonce.b.*) + } + .rel.plt : { *(.rel.plt) } + .rela.plt : { *(.rela.plt) } + .rela.tocbss : { *(.rela.tocbss) } + .init : + { + KEEP (*(.init)) + } =0x60000000 + .text : + { + *(.text .stub .text.* .gnu.linkonce.t.*) + KEEP (*(.text.*personality*)) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + *(.sfpr .glink) + } =0x60000000 + .fini : + { + KEEP (*(.fini)) + } =0x60000000 + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.*) } + .rodata1 : { *(.rodata1) } + .sdata2 : { *(.sdata2 .sdata2.* .gnu.linkonce.s2.*) } + .sbss2 : { *(.sbss2 .sbss2.* .gnu.linkonce.sb2.*) } + .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 (0x10000) - ((0x10000 - .) & (0x10000 - 1)); . = DATA_SEGMENT_ALIGN (0x10000, 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) } +/* . = DATA_SEGMENT_RELRO_END (0, .); */ + .data : + { + *(.data .data.* .gnu.linkonce.d.*) + KEEP (*(.gnu.linkonce.d.*personality*)) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + .toc1 ALIGN(8) : { *(.toc1) } + .opd ALIGN(8) : { KEEP (*(.opd)) } + .got ALIGN(8) : { *(.got .toc) } + /* We want the small data sections together, so single-instruction offsets + can access them all, and initialized data all before uninitialized, so + we can shorten the on-disk segment size. */ + .sdata : + { + *(.sdata .sdata.* .gnu.linkonce.s.*) + } + _edata = .; + PROVIDE (edata = .); + __bss_start = .; + .tocbss ALIGN(8) : { *(.tocbss)} + .sbss : + { + PROVIDE (__sbss_start = .); + PROVIDE (___sbss_start = .); + *(.dynsbss) + *(.sbss .sbss.* .gnu.linkonce.sb.*) + *(.scommon) + PROVIDE (__sbss_end = .); + PROVIDE (___sbss_end = .); + } + .plt : { *(.plt) } + .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/experimentation/later/source/lisp-kernel/linuxx8664/.gdbinit =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxx8664/.gdbinit (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxx8664/.gdbinit (revision 8058) @@ -0,0 +1,81 @@ +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 Index: /branches/experimentation/later/source/lisp-kernel/linuxx8664/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxx8664/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxx8664/Makefile (revision 8058) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2005 Clozure Associates +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL 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 + +# 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) -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 + +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/experimentation/later/source/lisp-kernel/linuxx8664/elf_x86_64.x =================================================================== --- /branches/experimentation/later/source/lisp-kernel/linuxx8664/elf_x86_64.x (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/linuxx8664/elf_x86_64.x (revision 8058) @@ -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/experimentation/later/source/lisp-kernel/lisp-debug.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/lisp-debug.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/lisp-debug.c (revision 8058) @@ -0,0 +1,928 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 + +#include +#include + + +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; + + + +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[]; + + +#if defined(LINUX) || defined(SOLARIS) +#define fpurge __fpurge +#endif + +int +readc() +{ + int c; + while (1) { + c = getchar(); + switch(c) { + case '\n': + continue; + case EOF: + if (ferror(stdin)) { + if (errno == EINTR) { + continue; + } + } + /* fall through */ + default: + return c; + } + } +} + +#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 +#endif + +void +show_lisp_register(ExceptionInformation *xp, char *label, int r) +{ + + LispObj val = xpGPR(xp, r); + +#ifdef PPC + fprintf(stderr, "r%02d (%s) = %s\n", r, label, print_lisp_object(val)); +#endif +#ifdef X86 + fprintf(stderr, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val)); +#endif + +} + + +void +describe_memfault(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef PPC + void *addr = (void *)xpDAR(xp); + natural dsisr = xpDSISR(xp); + + fprintf(stderr, "%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, instr2; + Boolean described = false; + + if (IS_UUO(the_uuo)) { + unsigned + minor = UUO_MINOR(the_uuo), + rt = 0x1f & (the_uuo >> 21), + ra = 0x1f & (the_uuo >> 16), + rb = 0x1f & (the_uuo >> 11), + errnum = 0x3ff & (the_uuo >> 16); + + switch(minor) { + case UUO_INTERR: + switch (errnum) { + case error_udf_call: + fprintf(stderr, "ERROR: undefined function call: %s\n", + print_lisp_object(xpGPR(xp,fname))); + described = true; + break; + + default: + fprintf(stderr, "ERROR: lisp error %d\n", errnum); + described = true; + break; + } + break; + + default: + break; + } + } + if (!described) { + fprintf(stderr, "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_arg1, err_arg2, ra, rs; + char *name = NULL; + 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(stderr, "Too few arguments (no opt/rest)\n"); + } else { + fprintf(stderr, "Too many arguments (no opt/rest)\n"); + } + identified = true; + break; + + case TO_GT: + fprintf(stderr, "Event poll !\n"); + identified = true; + break; + + case TO_HI: + fprintf(stderr, "Too many arguments (with opt)\n"); + identified = true; + break; + + case TO_LT: + fprintf(stderr, "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(stderr, "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(stderr, "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(stderr, "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(stderr, "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(stderr, "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(stderr, "Unknown trap: 0x%08x\n", the_trap); + } + + +} +#endif + +debug_command_return +debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg) +{ +#ifdef PPC + TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext)); + + fprintf(stderr, "rcontext = 0x%lX ", xpcontext); + if (!active_tcr_p(xpcontext)) { + fprintf(stderr, "(INVALID)\n"); + } else { + fprintf(stderr, "\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(stderr,"------\n"); + show_lisp_register(xp, "fn", Ifn); + fprintf(stderr,"------\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(stderr,"------\n"); + show_lisp_register(xp, "temp0", Itemp0); + show_lisp_register(xp, "temp1", Itemp1); + show_lisp_register(xp, "temp2", Itemp2); + fprintf(stderr,"------\n"); + if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) { + fprintf(stderr,"%%cx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff)); + } +#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; + + do { + fpurge(stdin); + fprintf(stderr, "\n %s :",prompt); + buf[0] = 0; + fgets(buf, sizeof(buf)-1, stdin); + } while (0); + p = strchr(buf, '\n'); + if (p) { + *p = 0; + return buf; + } + return NULL; +} + +natural +debug_get_natural_value(char *prompt) +{ + char s[32]; + int n; + natural val; + + do { + fpurge(stdin); + fprintf(stderr, "\n %s :", prompt); + fgets(s, 24, stdin); + n = sscanf(s, "%lu", &val); + } while (n != 1); + return val; +} + +unsigned +debug_get_u5_value(char *prompt) +{ + char s[32]; + int n; + unsigned val; + + do { + fpurge(stdin); + fprintf(stderr, "\n %s :", prompt); + fgets(s, 24, stdin); + n = sscanf(s, "%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"); + + 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(stderr, "Current Thread Context Record (tcr) = 0x%lx\n", tcr); + fprintf(stderr, "Control (C) stack area: low = 0x%lx, high = 0x%lx\n", + cs_area->low, cs_area->high); + fprintf(stderr, "Value (lisp) stack area: low = 0x%lx, high = 0x%lx\n", + vs_area->low, vs_area->high); + fprintf(stderr, "Exception stack pointer = 0x%lx\n", +#ifdef PPC + xpGPR(xp,1) +#endif +#ifdef X86 + 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); + set_xpGPR(xp, arg, val); + return debug_continue; +} + + +debug_command_return +debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + int a, b, c, d, i; + +#ifdef PPC +#ifdef PPC64 + for (a = 0, b = 16; a < 16; a++, b++) { + fprintf(stderr,"r%02d = 0x%016lX r%02d = 0x%016lX\n", + a, xpGPR(xp, a), + b, xpGPR(xp, b)); + } + + fprintf(stderr, "\n PC = 0x%016lX LR = 0x%016lX\n", + xpPC(xp), xpLR(xp)); + fprintf(stderr, "CTR = 0x%016lX CCR = 0x%08X\n", + xpCTR(xp), xpCCR(xp)); + fprintf(stderr, "XER = 0x%08X MSR = 0x%016lX\n", + xpXER(xp), xpMSR(xp)); + fprintf(stderr,"DAR = 0x%016lX DSISR = 0x%08X\n", + xpDAR(xp), xpDSISR(xp)); +#else + for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) { + fprintf(stderr,"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(stderr, "\n PC = 0x%08X LR = 0x%08X CTR = 0x%08X CCR = 0x%08X\n", + xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp)); + fprintf(stderr, "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(stderr,"%rax = 0x%016lX %r8 = 0x%016lX\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8)); + fprintf(stderr,"%rcx = 0x%016lX %r9 = 0x%016lX\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9)); + fprintf(stderr,"%rdx = 0x%016lX %r10 = 0x%016lX\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10)); + fprintf(stderr,"%rbx = 0x%016lX %r11 = 0x%016lX\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11)); + fprintf(stderr,"%rsp = 0x%016lX %r12 = 0x%016lX\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12)); + fprintf(stderr,"%rbp = 0x%016lX %r13 = 0x%016lX\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13)); + fprintf(stderr,"%rsi = 0x%016lX %r14 = 0x%016lX\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14)); + fprintf(stderr,"%rdi = 0x%016lX %r15 = 0x%016lX\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15)); + fprintf(stderr,"%rip = 0x%016lX %rflags = 0x%016lX\n", + xpGPR(xp, Iip), xpGPR(xp, Iflags)); +#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++) { + fprintf(stderr, "f%02d : 0x%08X%08X (%f)\n", i, *np++, *np++, *dp++); + } + fprintf(stderr, "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 FREEBSD + struct xmmacc *xmmp = xpXMMregs(xp); +#endif + float *sp; + + + for (i = 0; i < 16; i++, xmmp++) { + sp = (float *) xmmp; + dp = (double *) xmmp; + np = (int *) xmmp; + fprintf(stderr, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp); + } + fprintf(stderr, "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 + ); +#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(stderr, "(%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 OpenMCL 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; 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(stderr, " While executing: %s\n", print_lisp_object(f)); + } + } else { + fprintf(stderr, " In foreign code at address 0x%08lx\n", xpPC(xp)); + } + } +#endif +} + +extern pid_t main_thread_pid; + +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 (threads_initialized) { + suspend_other_threads(false); + } + + va_start(args,message); + vfprintf(stderr, message, args); + fprintf(stderr, "\n"); + va_end(args); + if (in_foreign_code) { + fprintf(stderr, "Exception occurred while executing foreign code\n"); + } + + if (lisp_global(BATCH_FLAG)) { + abort(); + } + if (xp) { + if (why > debug_entry_exception) { + debug_identify_exception(xp, info, why); + } + debug_identify_function(xp, info); + } + fprintf(stderr, "? for help\n"); + while (state == debug_continue) { + fprintf(stderr, "[%d] OpenMCL kernel debugger: ", main_thread_pid); + 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(); + } +} + +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 OpenMCL system code:\n%s", string); +} + Index: /branches/experimentation/later/source/lisp-kernel/lisp-errors.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/lisp-errors.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/lisp-errors.h (revision 8058) @@ -0,0 +1,155 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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_cant_call 17 + +#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/experimentation/later/source/lisp-kernel/lisp-exceptions.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/lisp-exceptions.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/lisp-exceptions.h (revision 8058) @@ -0,0 +1,158 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 + +#define ALLOW_EXCEPTIONS(context) \ + pthread_sigmask(SIG_SETMASK, &context->uc_sigmask, NULL); + + +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, ...); +int gc_from_xp(ExceptionInformation *, signed_natural); +int purify_from_xp(ExceptionInformation *, signed_natural); +int impurify_from_xp(ExceptionInformation *, signed_natural); +int change_hons_area_size_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 ); + +/* Need to define this here */ +#ifdef DARWIN +#define USE_MACH_EXCEPTION_LOCK 0 +#endif + + +#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/experimentation/later/source/lisp-kernel/lisp.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/lisp.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/lisp.h (revision 8058) @@ -0,0 +1,110 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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" + +#ifdef PPC +#include "ppc-constants.h" +#endif +#ifdef X86 +#include "x86-constants.h" +#endif +#include "macros.h" + +extern Boolean use_mach_exception_handling; +#ifdef DARWIN +extern Boolean running_under_rosetta; +#endif + +extern int page_size, log2_page_size; + +static inline unsigned long +_align_to_power_of_2(unsigned long n, unsigned power) +{ + unsigned long align = (1<= 0) { + display_buffer(buf); + } + return res; +} + Index: /branches/experimentation/later/source/lisp-kernel/lispdcmd.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/lispdcmd.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/lispdcmd.h (revision 8058) @@ -0,0 +1,30 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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/experimentation/later/source/lisp-kernel/lisptypes.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/lisptypes.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/lisptypes.h (revision 8058) @@ -0,0 +1,197 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 + + +#include + +#ifdef WIN64 +#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 +#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 + +#ifdef PPC +#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 */ +#ifndef __DARWIN_UNIX03 +#define __DARWIN_UNIX03 0 +#endif +#if !__DARWIN_UNIX03 +#define __ss ss +#define __es es +#define __fs fs +#define __vs vs + +#define __r0 r0 +#define __r1 r1 +#define __r3 r3 +#define __r4 r4 +#define __r5 r5 +#define __r6 r6 +#define __r13 r13 +#define __srr0 srr0 +#define __srr1 srr1 +#define __lr lr +#define __ctr ctr +#define __xer xer +#define __cr cr +#define __dsisr dsisr +#define __dar dar +#define __exception exception +#define __fpscr fpscr +#define __fpregs fpregs +#endif +#endif /* PPC */ + +#ifdef X8664 +/* Broken in xcode 2.4 */ +#ifndef _STRUCT_MCONTEXT64 /* A guess at what'll be defined when this is fixed */ +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 __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 +typedef mcontext_t MCONTEXT_T; +typedef ucontext_t ExceptionInformation; +#define UC_MCONTEXT(UC) UC->uc_mcontext +#endif /* _STRUCT_MCONTEXT64 */ +#endif /* X86_64 */ +#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 WIN64 +typedef EXCEPTION_POINTERS 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/experimentation/later/source/lisp-kernel/m4macros.m4 =================================================================== --- /branches/experimentation/later/source/lisp-kernel/m4macros.m4 (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/m4macros.m4 (revision 8058) @@ -0,0 +1,348 @@ +changequote([,]) +changecom([/* ],[*/]) + + + +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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],[])]) +]) + +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([WIN64],[define([SYSstabs],[COFFstabs]) + define([CNamesNeedUnderscores],[]) + define([LocalLabelPrefix],[L])]) + + +/* 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],[ + .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],[ + .loc 1 $1 0 +]) + + +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],[ifdef([WIN64],[ + .file 1 "__file__" + .text +],[ + .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],[ +ifdef([WIN64],[ +],[ + .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([WIN64],[ + .def $1; .scl 2; .type 32; .endef +],[ + .stabd 68,0,__line__ + .stabs "$1:F1",36,0,__line__,$1 +]) + .set func_start,$1 + +]) + + + +define([_exportfn],[ + .globl $1 + _startfn($1) +ifdef([PPC64],[ +ifdef([LINUX],[ + .global [.]$1 +[.]$1: +])]) +# __line__ +]) + + +define([_endfn],[ +LocalLabelPrefix[]__func_name[999]: +ifdef([WIN64],[ +],[ + .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__) +# __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([WIN64]) +equate_if_defined([PPC64]) +equate_if_defined([X8664]) + +equate_if_defined([HAVE_TLS]) +/* DARWIN_GS_HACK is hopefully short-lived */ +equate_if_defined([DARWIN_GS_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/experimentation/later/source/lisp-kernel/macros.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/macros.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/macros.h (revision 8058) @@ -0,0 +1,86 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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)((unsigned_of_pointer_size)(p))) +#define ptr_from_lispobj(o) ((LispObj*)((unsigned_of_pointer_size)(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*) (ptr_from_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 Index: /branches/experimentation/later/source/lisp-kernel/memory.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/memory.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/memory.c (revision 8058) @@ -0,0 +1,612 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 +#ifdef LINUX +#include +#include +#include +#endif + + +#include + +void +allocation_failure(Boolean pointerp, natural size) +{ + char buf[64]; + sprintf(buf, "Can't allocate %s of size %d 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; +} + +int +ProtectMemory(LogicalAddress addr, int nbytes) +{ + int status = mprotect(addr, nbytes, PROT_READ | PROT_EXEC); + + if (status) { + status = errno; + Bug(NULL, "couldn't protect %d bytes at %x, errno = %d", nbytes, addr, status); + } + return status; +} + +int +UnProtectMemory(LogicalAddress addr, int nbytes) +{ + return mprotect(addr, nbytes, PROT_READ|PROT_WRITE|PROT_EXEC); +} + +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) +{ + bzero(start,end-start); +} + + + + +/* + 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) { + LispObj *heap_start = ptr_from_lispobj(lisp_global(HEAP_START)); + + 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); +} + Index: /branches/experimentation/later/source/lisp-kernel/memprotect.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/memprotect.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/memprotect.h (revision 8058) @@ -0,0 +1,83 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 +#include +#endif + +int +ProtectMemory(LogicalAddress, int); + +int +UnProtectMemory(LogicalAddress, int); + +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/experimentation/later/source/lisp-kernel/pad.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/pad.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/pad.s (revision 8058) @@ -0,0 +1,6 @@ + .globl openmcl_low_address +openmcl_low_address: + nop + + + Index: /branches/experimentation/later/source/lisp-kernel/plbt.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/plbt.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/plbt.c (revision 8058) @@ -0,0 +1,343 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 +#ifndef PPC64 +#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(stderr,"%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 +#ifdef PPC64 + if (spname[-1] != '_') { + --spname; + } +#endif +#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(stderr, "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; + + if (lisp_nil == (LispObj) NULL) { + fprintf(stderr, "can't find lisp NIL; lisp process not active process ?\n"); + } else { + 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(stderr, "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)); +} + +const char * +foreign_name_and_offset(void *frame, unsigned *delta) +{ + Dl_info info; +#if defined(LINUX) && !defined(PPC64) + void *pc = (void *) (((eabi_c_frame *)frame)->savelr); +#else + void *pc = (void *) (((c_frame *)frame)->savelr); +#endif +#ifndef STATIC + if (dladdr(pc, &info)) { + if (delta) { + *delta = (unsigned long )pc - (unsigned long)info.dli_saddr; + } + return info.dli_sname; + } +#endif + if (delta) { + *delta = 0; + } + return NULL; +} Index: /branches/experimentation/later/source/lisp-kernel/plprint.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/plprint.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/plprint.c (revision 8058) @@ -0,0 +1,29 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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(stderr,"can't find lisp NIL; lisp process not active process ?\n"); + } else { + Dprintf("\n%s", print_lisp_object(obj)); + } +} + Index: /branches/experimentation/later/source/lisp-kernel/plsym.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/plsym.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/plsym.c (revision 8058) @@ -0,0 +1,127 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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%lX", print_lisp_object(sym), 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; + + 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(stderr, "Not a symbol.\n"); + } + return; +} + Index: /branches/experimentation/later/source/lisp-kernel/pmcl-kernel.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/pmcl-kernel.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/pmcl-kernel.c (revision 8058) @@ -0,0 +1,1881 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 +#include +#include +#include +#include +#include +#include + +#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 + +Boolean running_under_rosetta = false; + +#if WORD_SIZE == 64 +/* Assume that if the OS is new enough to support PPC64/X8664, it has + a reasonable dlfcn.h +*/ +#include +#endif +#endif + +#if defined(FREEBSD) || defined(SOLARIS) +#include +#include +#include +#include +#include +#endif + +#include +#include +#include "Threads.h" + +#ifndef MAP_NORESERVE +#define MAP_NORESERVE (0) +#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; +#ifdef X86 +extern LispObj bad_funcall; +#endif + +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; + unsigned long ncacheflush = (unsigned long) q - (unsigned long) p; + + xMakeDataExecutable(cache_start, ncacheflush); +} + +size_t +ensure_stack_limit(size_t stack_size) +{ + 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(stderr, "errno = %d\n", e); + Fatal(": Stack resource limit too small", ""); + } + } + 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(unsigned 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(unsigned); + void free_stack(void *); + unsigned size = useable+softsize+hardsize; + unsigned overhead; + BytePtr base, softlimit, hardlimit; + OSErr err; + 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) ((unsigned long)(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, + unsigned useable, + 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(useable, + 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) (((((unsigned long)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(unsigned 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(unsigned 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 (1024L<<30L) +#endif +#ifdef LINUX +#ifdef X8664 +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef PPC +#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L) +#endif +#endif +#else +#ifdef DARWIN +#define MAXIMUM_MAPPABLE_MEMORY ((1U<<31)-2*heap_segment_size) +#endif +#ifdef LINUX +#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 + +#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) +{ + if (len) { + madvise(start, len, MADV_DONTNEED); + if (mmap(start, + len, + PROT_NONE, + MAP_PRIVATE | MAP_FIXED | MAP_ANON, + -1, + 0) != start) { + int err = errno; + Fatal("mmap error", ""); + fprintf(stderr, "errno = %d", err); + } + } +} + +#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) { + int i, err; + void *addr; + + for (i = 0; i < 3; i++) { + addr = mmap(start, + len, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_FIXED | MAP_ANON, + -1, + 0); + if (addr == start) { + if (touch_all_pages(start, len)) { + return true; + } + else { + mmap(start, + len, + PROT_NONE, + MAP_PRIVATE | MAP_FIXED | MAP_ANON, + -1, + 0); + } + } + } + return false; + } +} + +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()) { + if ((a->active + more) > a->high) { + return NULL; + } + mask = ((unsigned long)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 (mmap(new_start, + new_end-new_start, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_FIXED, + -1, + 0) != 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; + +#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 + +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(unsigned long totalsize) +{ + OSErr err; + Ptr h; + natural base, n; + BytePtr + end, + lastbyte, + start, + protstart, + p, + want = (BytePtr)IMAGE_BASE_ADDRESS, + try2; + area *reserved; + Boolean fixed_map_ok = false; + + /* + 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. + */ + + totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size); + +#ifdef DARWIN + fixed_map_ok = address_unmapped_p(want,totalsize); +#endif +#ifdef SOLARIS + fixed_map_ok = true; +#endif + raise_limit(); + 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) { + perror("Initial mmap"); + return NULL; + } + + if (start != want) { + munmap(start, totalsize+heap_segment_size); + start = (void *)((((unsigned long)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); + + h = (Ptr) start; + base = (unsigned long) 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) ((unsigned long)((((unsigned long)end) - ((totalsize+63)>>6)) & ~4095)); + + global_mark_ref_bits = (bitvector)end; + end = (BytePtr) ((unsigned long)((((unsigned long)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)), + npages = (lisp_global(HEAP_END)-lisp_global(HEAP_START)) >> log2_page_size, + markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3), + reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<>bitmap_shift)+1)); + BytePtr + new_reloctab_limit = ((BytePtr)global_reloctab)+reloctab_size, + new_markbits_limit = ((BytePtr)global_mark_ref_bits)+markbits_size; + + if (new_reloctab_limit > reloctab_limit) { + UnProtectMemory(global_reloctab, reloctab_size); + reloctab_limit = new_reloctab_limit; + } + + if (new_markbits_limit > markbits_limit) { + UnProtectMemory(global_mark_ref_bits, markbits_size); + 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) { + return NULL; + } + 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; + UnProtectMemory(start, end-start); + a->h = start; + a->softprot = NULL; + a->hardprot = NULL; + 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; +} + + + + +void +sigint_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ + if (signum == SIGINT) { + lisp_global(INTFLAG) = (1 << fixnumshift); + } +#ifdef DARWIN + DarwinSigReturn(context); +#endif +} + + +void +register_sigint_handler() +{ + install_signal_handler(SIGINT, (void *)sigint_handler); +} + + + +BytePtr +initial_stack_bottom() +{ + extern char **environ; + char *p = *environ; + while (*p) { + p += (1+strlen(p)); + } + return (BytePtr)((((unsigned long) p) +4095) & ~4095); +} + + + + +Ptr fatal_spare_ptr = NULL; + + +void +Fatal(StringPtr param0, StringPtr param1) +{ + + if (fatal_spare_ptr) { + deallocate(fatal_spare_ptr); + fatal_spare_ptr = NULL; + } + fprintf(stderr, "Fatal error: %s\n%s\n", param0, param1); + _exit(-1); +} + +OSErr application_load_err = noErr; + +area * +set_nil(LispObj); + + +#ifdef DARWIN +/* + 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 ... +*/ +char * +default_image_name(char *orig) +{ + int len = strlen(orig) + strlen(".image") + 1; + char *copy = (char *) malloc(len); + + if (copy) { + strcpy(copy, orig); + strcat(copy, ".image"); + } + return copy; +} + +#else +char * +default_image_name(char *orig) +{ + char *copy = strdup(orig), *base = copy, *work = copy, c; + if (copy == NULL) { + return NULL; + } + while(*work) { + if (*work++ == '/') { + base = work; + } + } + work = base; + while (c = *work) { + if (islower(c)) { + *work++ = toupper(c); + } else { + *work++ = tolower(c); + } + } + return copy; +} +#endif + + +char *program_name = NULL; +char *real_executable_name = NULL; + +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 p; + } + return 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 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 argv0; +#endif +} + +void +usage_exit(char *herald, int exit_status, char* other_args) +{ + if (herald && *herald) { + fprintf(stderr, "%s\n", herald); + } + fprintf(stderr, "usage: %s \n", program_name); + fprintf(stderr, "\t or %s \n", program_name); + fprintf(stderr, "\t where are one or more of:\n"); + if (other_args && *other_args) { + fputs(other_args, stderr); + } + fprintf(stderr, "\t-R, --heap-reserve : reserve (default: %ld)\n", + reserved_area_size); + fprintf(stderr, "\t\t bytes for heap expansion\n"); + fprintf(stderr, "\t-S, --stack-size : set size of initial thread's control stack to \n"); + fprintf(stderr, "\t-Z, --thread-stack-size : set default size of first (listener) thread's stacks based on \n"); + fprintf(stderr, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n"); + fprintf(stderr, "\t--no-sigtrap : obscure option for running under GDB\n"); + fprintf(stderr, "\t-I, --image-name \n"); + fprintf(stderr, "\t and defaults to %s\n", + default_image_name(program_name)); + fprintf(stderr, "\n"); + _exit(exit_status); +} + +int no_sigtrap = 0; +char *image_name = NULL; +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(stderr, "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[]) +{ + int i, j, k, num_elide, flag, arg_error; + char *arg, *val; +#ifdef DARWIN + extern int NXArgc; +#endif + + for (i = 1; i < argc;) { + arg = argv[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; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + if (val) { + image_name = val; + } + } else if ((flag = (strncmp(arg, "-R", 2) == 0)) || + (strcmp(arg, "--heap-reserve") == 0)) { + natural reserved_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 >= (1L<<((WORD_SIZE-fixnumshift)-1))) { + thread_stack_size = (1L<<((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]; + } + argc -= num_elide; +#ifdef DARWIN + NXArgc -= num_elide; +#endif + argv[argc] = NULL; + } + } + } +} + +pid_t main_thread_pid = (pid_t)0; + +void +terminate_lisp() +{ + kill(main_thread_pid, SIGKILL); + _exit(-1); +} + +#ifdef DARWIN +#ifdef PPC64 +#define min_os_version "8.0" /* aka Tiger */ +#else +#define min_os_version "7.0" /* aka Panther */ +#endif +#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 DARWIN +#ifdef PPC64 +/* 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)0x5000) { + new = mmap((pc) 0x5000, + 0x1000, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_FIXED, + -1, + 0); + if (new != (pc) 0x5000) { + _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); + mprotect(new, 0x1000, PROT_READ | PROT_EXEC); + } +} +#endif +#endif + +#ifdef X8664 +void +remap_spjump() +{ + extern opcode spjump_start; + pc new = mmap((pc) 0x5000, + 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 + +void +check_os_version(char *progname) +{ + struct utsname uts; + + uname(&uts); + if (strcmp(uts.release, min_os_version) < 0) { + fprintf(stderr, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release); + exit(1); + } +#ifdef PPC +#ifdef DARWIN + { + char *hosttype = getenv("HOSTTYPE"); + if (hosttype && !strncmp("intel", hosttype, 5)) { + running_under_rosetta = true; + use_mach_exception_handling = false; + reserved_area_size = 1U << 30; + } + } +#endif +#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(int, int*, int*, int*); + +#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_CLFLUSH|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2) + +Boolean +check_x86_cpu() +{ + int 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; + } + } + 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(stderr, "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 + +main(int argc, char *argv[], char *envp[], void *aux) +{ + extern int page_size; + +#ifdef PPC + extern int altivec_present; +#endif + extern LispObj load_image(char *); + long resp; + BytePtr stack_end; + area *a; + BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer(); + TCR *tcr; + int i; + + check_os_version(argv[0]); + real_executable_name = determine_executable_name(argv[0]); + page_size = getpagesize(); + +#ifdef LINUX +#ifdef X8664 + ensure_gs_available(real_executable_name); +#endif +#endif +#if (defined(DARWIN) && defined(PPC64)) || defined(X8664) + 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(stderr, "CPU doesn't support required features\n"); + exit(1); + } +#endif + + main_thread_pid = getpid(); + tcr_area_lock = (void *)new_recursive_lock(); + + program_name = argv[0]; + if ((argc == 2) && (*argv[1] != '-')) { + image_name = argv[1]; + argv[1] = NULL; + } else { + process_options(argc,argv); + } + 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); + } + } + + + if (!create_reserved_area(reserved_area_size)) { + exit(-1); + } + gc_init(); + + set_nil(load_image(image_name)); + lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock); + + lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10); + 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); +#ifdef X86 + lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall); +#endif + 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 = G2_AREA_THRESHOLD; + g1_area->threshold = G1_AREA_THRESHOLD; + a->threshold = G0_AREA_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_sigint_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; + lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT); + 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 +#ifndef DISABLE_EGC + egc_control(true, NULL); +#endif + 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) +{ + extern void flush_cache_lines(); + unsigned long ustart = (unsigned long) start, base, end; + + base = (ustart) & ~(cache_block_size-1); + end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1); +#ifdef DARWIN + if (running_under_rosetta) { + /* We probably need to flush something's cache even if running + under Rosetta, but (a) this is agonizingly slow and (b) we're + dying before we get to the point where this would matter. + */ + return; + } +#endif +#ifndef X86 + flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size); +#endif +} + +int +xStackSpace() +{ + return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT; +} + +#ifndef DARWIN +void * +xGetSharedLibrary(char *path, int mode) +{ + return dlopen(path, mode); +} +#else +void * +xGetSharedLibrary(char *path, int *resultType) +{ +#if WORD_SIZE == 32 + NSObjectFileImageReturnCode code; + NSObjectFileImage moduleImage; + NSModule module; + const struct mach_header * header; + const char * error; + void * result; + /* not thread safe */ + /* + static struct { + const struct mach_header *header; + NSModule *module; + const char *error; + } results; + */ + result = NULL; + error = NULL; + + /* first try to open this as a bundle */ + code = NSCreateObjectFileImageFromFile(path,&moduleImage); + if (code != NSObjectFileImageSuccess && + code != NSObjectFileImageInappropriateFile && + code != NSObjectFileImageAccess) + { + /* compute error strings */ + switch (code) + { + case NSObjectFileImageFailure: + error = "NSObjectFileImageFailure"; + break; + case NSObjectFileImageArch: + error = "NSObjectFileImageArch"; + break; + case NSObjectFileImageFormat: + error = "NSObjectFileImageFormat"; + break; + case NSObjectFileImageAccess: + /* can't find the file */ + error = "NSObjectFileImageAccess"; + break; + default: + error = "unknown error"; + } + *resultType = 0; + return (void *)error; + } + if (code == NSObjectFileImageInappropriateFile || + code == NSObjectFileImageAccess ) { + /* the pathname might be a partial pathane (hence the access error) + or it might be something other than a bundle, if so perhaps + it is a .dylib so now try to open it as a .dylib */ + + /* protect against redundant loads, Gary Byers noticed possible + heap corruption if this isn't done */ + header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR | + NSADDIMAGE_OPTION_WITH_SEARCHING | + NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED); + if (!header) + header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR | + NSADDIMAGE_OPTION_WITH_SEARCHING); + result = (void *)header; + *resultType = 1; + } + else if (code == NSObjectFileImageSuccess) { + /* we have a sucessful module image + try to link it, don't bind symbols privately */ + + module = NSLinkModule(moduleImage, path, + NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW); + NSDestroyObjectFileImage(moduleImage); + result = (void *)module; + *resultType = 2; + } + if (!result) + { + /* compute error string */ + NSLinkEditErrors ler; + int lerno; + const char* file; + NSLinkEditError(&ler,&lerno,&file,&error); + if (error) { + result = (void *)error; + *resultType = 0; + } + } + return result; +#else + 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 +} +#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 (char *path) +{ + int fd = open(path, O_RDONLY); + 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(char *path) +{ + int fd = open(path, O_RDONLY, 0666); + LispObj image_nil = 0; + if (fd > 0) { + openmcl_image_file_header ih; + 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. + */ + if (!image_nil) { + close(fd); + } + } + if (image_nil == 0) { + fprintf(stderr, "Couldn't load lisp heap image from %s\n", path); + exit(-1); + } + return image_nil; +} + +int +set_errno(int val) +{ + errno = val; + return -1; +} + + + + +void * +xFindSymbol(void* handle, char *name) +{ +#if defined(LINUX) || defined(FREEBSD) + return dlsym(handle, name); +#endif +#ifdef DARWIN +#if defined(PPC64) || defined(X8664) + if (handle == NULL) { + handle = RTLD_DEFAULT; + } + if (*name == '_') { + name++; + } + return dlsym(handle, name); +#else + natural address = 0; + + if (handle == NULL) { + if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */ + _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL); + } + return (void *)address; + } + Bug(NULL, "How did this happen ?"); +#endif +#endif +} + +void * +get_r_debug() +{ +#if defined(LINUX) || defined(FREEBSD) +#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; +} + + Index: /branches/experimentation/later/source/lisp-kernel/ppc-asmutils.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-asmutils.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-asmutils.s (revision 8058) @@ -0,0 +1,457 @@ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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/experimentation/later/source/lisp-kernel/ppc-constants.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-constants.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-constants.h (revision 8058) @@ -0,0 +1,91 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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/experimentation/later/source/lisp-kernel/ppc-constants.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-constants.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-constants.s (revision 8058) @@ -0,0 +1,238 @@ +/* Copyright (C) 2004 Clozure Associates */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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 = 48 /* MUST UPDATE THIS !!! */ + + _struct(lisp_globals,lisp_globals_limit-(num_lisp_globals*node_size)) + _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(BADfpscr_save) /* saved FPSCR */ + _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(doh_head) /* creole objects header */ + _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(BAD_cs_overflow_limit) /* limit for control-stack overflow check */ + _node(BAD_current_ts) /* current temp-stack area */ + _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(tcr_lock) /* this thread]s exception frame chain */ + _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/experimentation/later/source/lisp-kernel/ppc-constants32.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-constants32.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-constants32.h (revision 8058) @@ -0,0 +1,479 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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/experimentation/later/source/lisp-kernel/ppc-constants32.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-constants32.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-constants32.s (revision 8058) @@ -0,0 +1,686 @@ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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 +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 + +INTERRUPT_LEVEL_BINDING_INDEX = fixnumone Index: /branches/experimentation/later/source/lisp-kernel/ppc-constants64.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-constants64.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-constants64.h (revision 8058) @@ -0,0 +1,460 @@ +/* + Copyright (C) 2003-2005, Clozure Associates. + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 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 */ + LispObj cache_idx; /* index of last cached pair */ + LispObj cache_key; /* value of last cached key */ + LispObj cache_value; /* last cached value */ +} 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) + + +/* 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) + +/* + known values of an "extended" (gcable) macptr's flags word: +*/ + +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; + +/* 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/experimentation/later/source/lisp-kernel/ppc-constants64.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-constants64.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-constants64.s (revision 8058) @@ -0,0 +1,596 @@ +/* Copyright (C) 2003-2005, Clozure Associates. */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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) + _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 + +define([RESERVATION_DISCHARGE],0x2008) + +lisp_globals_limit = 0x3000 + +INTERRUPT_LEVEL_BINDING_INDEX = fixnumone + + Index: /branches/experimentation/later/source/lisp-kernel/ppc-exceptions.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-exceptions.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-exceptions.c (revision 8058) @@ -0,0 +1,3159 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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(stderr, "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(stderr, "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; +} + +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(stderr, "alloc_trap in 0x%lx, new allocptr = 0x%lx\n", + tcr, xpGPR(xp, allocptr)); +#endif + adjust_exception_pc(xp,4); + return 0; + } + /* 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)); + return -1; + } + return -1; +} + +natural gc_deferred = 0, full_gc_deferred = 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; + + 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); + } + 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); + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *vsarea = tcr->vs_area; + + nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1); + err = save_application(arg); + 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; + } +} + +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(stderr, "TCR 0x%x in lisp code, vsp = 0x%lx, tsp = 0x%lx\n", + tcr, xpGPR(xp, vsp), xpGPR(xp, tsp)); + fprintf(stderr, "TCR 0x%x, allocbase/allocptr were 0x%x/0x%x at #x%x\n", + tcr, + xpGPR(xp, allocbase), + xpGPR(xp, allocptr), + xpPC(xp)); + fprintf(stderr, "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(stderr, "TCR 0x%x in foreign code, vsp = 0x%lx, tsp = 0x%lx\n", + tcr, tcr->save_vsp, tcr->save_tsp); + fprintf(stderr, "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 */ + +int +gc_like_from_xp(ExceptionInformation *xp, + int(*fun)(TCR *, signed_natural), + signed_natural param) +{ + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)), *other_tcr; + ExceptionInformation* other_xp; + 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 */ + +int +gc_from_tcr(TCR *tcr, signed_natural param) +{ + area *a; + BytePtr oldfree, newfree; + BytePtr oldend, newend; + +#ifdef DEBUG + fprintf(stderr, "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(stderr, "End GC in 0x%lx\n", tcr); +#endif + return ((oldfree-newfree)+(newend-oldend)); +} + +int +gc_from_xp(ExceptionInformation *xp, signed_natural param) +{ + int status = gc_like_from_xp(xp, gc_from_tcr, param); + + freeGCptrs(); + return status; +} + +int +purify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, purify, param); +} + +int +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); + } + } + 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. OpenMCL 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) +{ + unsigned oldMQ; + 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; + 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), + rt = 0x1f & (the_uuo >> 21), + ra = 0x1f & (the_uuo >> 16), + 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: + if (errnum == error_propagate_suspend) { + status = 0; + } else { + status = handle_error(xp, errnum, rb, 0, where); + } + 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) +{ + sigset_t mask; + natural callback_ptr, i; + 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(stderr, "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(stderr, "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) +{ + unsigned instr, err_arg1 = 0, err_arg2 = 0, err_arg3 = 0; + int ra, rs, fn_reg = 0; + char * error_msg = NULL; + char name[kNameBufLen]; + LispObj cmain = nrs_CMAIN.vcell; + Boolean event_poll_p = false; + int old_interrupt_level = 0; + 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(stderr, "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( stderr, "Non-fatal error: %s.\n", msg ); + fflush( stderr ); +} + +/* 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 pname; + 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(stderr, "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(stderr, "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; + +#ifdef DARWIN + if (running_under_rosetta) { + fprintf(stderr, "signal handler: signal = %d, pc = 0x%08x\n", signum, xpPC(context)); + } +#endif + 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_set_hash_key, + egc_gvset, + egc_rplaca, + egc_rplacd; + + +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, root; + bitvector refbits = (bitvector)(lisp_global(REFBITS)); + Boolean need_store = true, need_check_memo = true, need_memoize_root = false; + + if (program_counter >= &egc_store_node_conditional) { + if ((program_counter == &egc_store_node_conditional) || ! (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; + } + val = xpGPR(xp,arg_z); + 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); + 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(stderr, "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(stderr, "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(stderr, "finish allocating cons in TCR = #x%x\n", + tcr); +#endif + } else { + if (allocptr_tag == fulltag_misc) { +#ifdef DEBUG + fprintf(stderr, "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(stderr, "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(stderr, "[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(stderr, "[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 = + 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 +quit_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_resume_signal = SIG_RESUME_THREAD; + + install_signal_handler(thread_suspend_signal, (void *) suspend_resume_handler); + install_signal_handler(thread_resume_signal, (void *) suspend_resume_handler); + install_signal_handler(SIGQUIT, (void *)quit_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))) + + +#if USE_MACH_EXCEPTION_LOCK +pthread_mutex_t _mach_exception_lock, *mach_exception_lock; +#endif + +#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) +{ + int i, j; + 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(stderr, "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(stderr, "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; + int i,j; + 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 + mach_msg_type_number_t thread_state_count; + ExceptionInformation *pseudosigcontext; + int i, j, old_valence = tcr->valence; + kern_return_t result; + natural stackp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(stderr,"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(stderr,"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(stderr, "obtaining Mach exception lock in exception thread\n"); +#endif + + if ( +#if USE_MACH_EXCEPTION_LOCK + pthread_mutex_trylock(mach_exception_lock) == 0 +#else + 1 +#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) { +#if USE_MACH_EXCEPTION_LOCK + mach_exception_lock = &_mach_exception_lock; + pthread_mutex_init(mach_exception_lock, NULL); +#endif + 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), + target_thread = pthread_mach_thread_np((pthread_t)ptr_from_lispobj(tcr->osid)), + 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(stderr, "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(stderr, "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(stderr, "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(stderr, "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 USE_MACH_EXCEPTION_LOCK + pthread_mutex_lock(mach_exception_lock); +#endif + + 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); + + } +#if USE_MACH_EXCEPTION_LOCK + pthread_mutex_unlock(mach_exception_lock); +#endif + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return 0; +} + +#endif Index: /branches/experimentation/later/source/lisp-kernel/ppc-exceptions.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-exceptions.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-exceptions.h (revision 8058) @@ -0,0 +1,437 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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) +#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 +#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 + +#if USE_MACH_EXCEPTION_LOCK +pthread_mutex_t *mach_exception_lock; +#endif +#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 SIGEMT +#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/experimentation/later/source/lisp-kernel/ppc-gc.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-gc.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-gc.c (revision 8058) @@ -0,0 +1,2403 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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; + 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() +{ + 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; + } + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = 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(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = 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 & ~4); + dnode < GCndnodes_in_area; + program_counter-=2, --dnode) { + if (*program_counter == PPC64_CODE_VECTOR_PREFIX) { + headerP = ((LispObj *)program_counter)-1; + header = *headerP; + 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!"); + } + } +} +#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_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + } + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = 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 = 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; + } + + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = this; + goto Climb; + } + + 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 = 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); + 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; + } + + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + } else { + + 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 = (LispObj) (((natural) start) + fulltag_misc); + } + + 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(stderr, "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(stderr,"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 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 + subtag = header_subtag(header), + element_count = header_element_count(header), + physbytes; + + switch(subtag) { + case subtag_simple_base_string: + physbytes = node_size + (element_count << 2); + break; + + case subtag_code_vector: + physbytes = node_size + (element_count << 2); + break; + + default: + Bug(NULL, "Can't purify object at 0x%08x", obj); + return obj; + } + physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1); + 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)); + } + + +#define FORWARD_ONLY 0 +#define COPY_CODE (1<<0) +#define COPY_STRINGS (1<<1) + + void + copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy) + { + LispObj obj = *ref, header; + natural tag = fulltag_of(obj), header_tag, header_subtag; + + 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)) { + header_subtag = header_subtag(header); + if (((header_subtag == subtag_code_vector) && (what_to_copy & COPY_CODE)) || + ((what_to_copy & COPY_STRINGS) && + ((header_subtag == subtag_simple_base_string)))) { + *ref = purify_object(obj, dest); + } + } + } + } + } + + void + purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to, int what) + { +#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, what); + break; +#endif + } + } +#endif +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) +{ + 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, what); + } + start++; + copy_ivector_reference(start, low, high, to, what); + start++; + } + } + } +} + +/* Purify references from tstack areas */ +void +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + 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, what); + } + } +} + +/* Purify a vstack area */ +void +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + if (((natural)p) & sizeof(natural)) { + copy_ivector_reference(p, low, high, to, what); + p++; + } + purify_range(p, q, low, high, to, what); +} + +#ifdef PPC +void +purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + 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, what); + } else { + /* Clear low bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1)); + } + } +} +#endif + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what) +{ + unsigned long *regs = (unsigned long *) 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++) { + copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to, what); + }; + + purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to, what); + + purify_locref((LispObj*) (&(xpPC(xp))), low, high, to, what); + purify_locref((LispObj*) (&(xpLR(xp))), low, high, to, what); + purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to, what); +#endif + +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + purify_range(start, end, low, high, to, what); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + purify_xp(xp, low, high, to, what); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + purify_xp(xframes->curr, low, high, to, what); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target, int what) +{ + 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, what); + break; + + case AREA_VSTACK: + purify_vstack_area(next_area, low, high, target, what); + break; + + case AREA_CSTACK: +#ifdef PPC + purify_cstack_area(next_area, low, high, target, what); +#endif + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what); + 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. + +*/ + + +int +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; + OSErr err; + 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<vcell, htab, obj; + package *p; + cons *c; + natural elements, i; + + while (fulltag_of(pkg_list) == fulltag_cons) { + c = (cons *) ptr_from_lispobj(untag(pkg_list)); + p = (package *) ptr_from_lispobj(untag(c->car)); + pkg_list = c->cdr; + c = (cons *) ptr_from_lispobj(untag(p->itab)); + htab = c->car; + elements = header_element_count(header_of(htab)); + for (i = 1; i<= elements; i++) { + obj = deref(htab,i); + if (fulltag_of(obj) == fulltag_misc) { + rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); + copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); + } + } + c = (cons *) ptr_from_lispobj(untag(p->etab)); + htab = c->car; + elements = header_element_count(header_of(htab)); + for (i = 1; i<= elements; i++) { + obj = deref(htab,i); + if (fulltag_of(obj) == fulltag_misc) { + rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); + copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); + } + } + } + } + + purify_areas(a->low, a->active, new_pure_area, COPY_CODE); + + other_tcr = tcr; + do { + purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, COPY_CODE); + purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, COPY_CODE); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + { + 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; + } + } +} + +int +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; + 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); + lisp_global(IN_GC) = 0; + } + return 0; + } + return -1; +} + Index: /branches/experimentation/later/source/lisp-kernel/ppc-macros.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/ppc-macros.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/ppc-macros.s (revision 8058) @@ -0,0 +1,830 @@ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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 the keyword is :ALLOW-OTHER-KEYS and the value is non-nil, */ + /* set imm1 to a non-zero value to indicate that unknown keywords */ + /* are acceptable. */ + /* c) If the keyword is not found (and isn't :ALLOW-OTHER-KEYS), increment */ + /* the count of unknown keywords in imm0. */ + /* 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))) + __(cmpri(cr0,arg_y,nil_value)) + __(cmpr(cr4,imm0,nargs)) + __(ldr(arg_reg,cons.cdr(arg_reg))) + __(bne cr3,match_test) + __(beq cr0,match_test) + __(ori imm1,imm1,1) + __(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,4) + __(bne cr0,match_test) + /* Got a hit. Unless this keyword's been seen already, set it. */ + __(slwi imm0,imm0,3) + __(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))) + __(b match_keys_loop) +match_test: + __(bne cr4,match_loop) + __(oris imm1,imm1,0x8000) + __(b match_keys_loop) +matched_keys: + __(cmpri(cr1,imm1,0)) + __(add imm1,imm1,imm1) + __(cmpri(cr0,imm1,0)) + __(bgelr cr1) + __(bnelr cr0) + /* 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) + _endsubp(eabi_ff_call) + + _startfn(FF_call_return_common) + /* 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))) + .globl C(ffcall_return_window) +C(ffcall_return_window): + __(vpop_saveregs()) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + .globl C(ffcall_return_window_end) +C(ffcall_return_window_end): + __(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, + pname_header = header_of(pname); + +#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/experimentation/later/source/lisp-kernel/solarisx64/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/solarisx64/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/solarisx64/Makefile (revision 8058) @@ -0,0 +1,80 @@ +# +# Copyright (C) 2006 Clozure Associates and contributors +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL 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 = /usr/sfw/bin/gas +# As of this writing, /usr/sfw/bin/gm4 is both more recent (1.4.2 vs 1.4) +# and more buggy than /opt/sfw/bin/gm4, which is available on the +# "Solaris companion" disk. Do you get the impression that the people +# who put this stuff together aren't paying much attention ? +M4 = /opt/sfw/bin/gm4 +CC = /usr/sfw/bin/gcc +ASFLAGS = --64 +M4FLAGS = -DSOLARIS -DX86 -DX8664 +CDEFINES = -DSOLARIS -D_REENTRANT -DX86 -DX8664 -D__EXTENSIONS__ -DHAVE_TLS -DDISABLE_EGC +CDEBUG = -g +COPT = #-O2 + + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m64 -o $@ + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.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: ../../sx86cl64 + + +OSLIBS = -ldl -lm -lpthread -lsocket -lnsl -lrt + + +../../sx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(CC) -m64 $(CDEBUG) -o $@ $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../sx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../sx86cl64 + strip -g ../../sx86cl64 Index: /branches/experimentation/later/source/lisp-kernel/static-linuxppc/.cvsignore =================================================================== --- /branches/experimentation/later/source/lisp-kernel/static-linuxppc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/static-linuxppc/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +external-functions.h +*~.* Index: /branches/experimentation/later/source/lisp-kernel/static-linuxppc/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/static-linuxppc/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/static-linuxppc/Makefile (revision 8058) @@ -0,0 +1,103 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + +OPENMCL_MAJOR_VERSION=0 +OPENMCL_MINOR_VERSION=14 + +VPATH = ../ +RM = /bin/rm +# Versions of GNU as >= 2.9.1 all seem to work +# AS = gas-2.9.1 +AS = as +M4 = m4 +ASFLAGS = -mregnames -mppc32 +M4FLAGS = -DLINUX -DPPC +CDEFINES = -DLINUX -DPPC -D_REENTRANT -DSTATIC -D_GNU_SOURCE +CDEBUG = -g +COPT = -O2 + +# The only version of GCC I have that supports both ppc32 and ppc64 +# compilation uses the -m32 option to target ppc32. This may not be +# definitive; there seem to be a bewildering array of similar options +# in other GCC versions. It's assumed here that if "-m32" is recognized, +# it's required as well. + +PPC32 = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-m32 ") && /bin/echo "-m32") + +# Likewise, some versions of GAS may need a "-a32" flag, to force the +# output file to be 32-bit compatible. + +A32 = $(shell ($(AS) --help -v 2>&1 | grep -q -e "-a32") && /bin/echo "-a32") + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(A32) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(PPC32) -o $@ + +SPOBJ = pad.o ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o ppc-gc.o bits.o ppc-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= $(COBJ) ppc-asmutils.o imports.o +STATICOBJ= staticlib.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants32.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h ppc-constants32.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ = $(SPOBJ) +all: ../../static-ppccl + + +# No: + +# KSPOBJ= +# all: ../../static-ppccl ../../subprims.so + +OSLIBS = -lm -lpthread + + +../../static-ppccl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(STATICOBJ) + $(CC) $(PPC32) $(CDEBUG) -static -o $@ -T ../linux//elf32ppclinux.x $(KSPOBJ) $(KERNELOBJ) $(STATICOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h +staticlib.o: external-functions.h staticlib.c + $(CC) -c staticlib.c -fno-builtin $(CDEFINES) $(CDEBUG) $(COPT) $(PPC32) -o $@ + + +external-functions.h: + echo "Must generate external-functions.h from running lisp" + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../ppccl + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../ppccl + strip -g ../../ppccl Index: /branches/experimentation/later/source/lisp-kernel/static-linuxppc/staticlib.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/static-linuxppc/staticlib.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/static-linuxppc/staticlib.c (revision 8058) @@ -0,0 +1,53 @@ +typedef struct { + char *name; + void *(*func)(); +} external_function; + +#define NULL ((void *)0) +#include "external-functions.h" + +int +string_compare(char *a, char *b) +{ + char ch; + + while (ch = *a++) { + if (*b++ != ch) { + return 1; + } + } + return !!*b; +} + + +void * +dlsym(void *handle, char *name) +{ + external_function *p; + char *fname; + + for (p = external_functions; fname = p->name; p++) { + if (!string_compare(name, fname)) { + return (void *)(p->func); + } + } + return NULL; +} + +void * +dlopen(char *path, int mode) +{ + return NULL; +} + +void * +dlerror() +{ + return (void *)"No shared library support\n"; +} + +void * +dlclose() +{ + return NULL; +} Index: /branches/experimentation/later/source/lisp-kernel/thread_manager.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/thread_manager.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/thread_manager.c (revision 8058) @@ -0,0 +1,1823 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#include "Threads.h" + +/* + If we suspend via signals - and if the "suspend" signal is maked + in the handler for that signal - then it's not possible to suspend + a thread that's still waiting to be resumed (which is what + WAIT_FOR_RESUME_ACK is all about.) +*/ +#define WAIT_FOR_RESUME_ACK 0 +#define RESUME_VIA_RESUME_SEMAPHORE 1 +#define SUSPEND_RESUME_VERBOSE 0 + +typedef struct { + TCR *tcr; + natural vsize, tsize; + void *created; +} thread_activation; + +#ifdef HAVE_TLS +__thread TCR current_tcr; +#endif + +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 + +int +raise_thread_interrupt(TCR *target) +{ +#ifdef DARWIN_not_yet + if (use_mach_exception_handling) { + return mach_raise_thread_interrupt(target); + } +#endif + return pthread_kill((pthread_t)target->osid, SIGNAL_FOR_PROCESS_INTERRUPT); +} + +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; + } + } + sched_yield(); + } +} +#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(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(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) +{ + natural val; + 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, pending; + + 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 + } while (status != 0); +} + +int +wait_on_semaphore(void *s, int seconds, int millis) +{ + int nanos = (millis % 1000) * 1000000; +#ifdef USE_POSIX_SEMAPHORES + 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 + 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 +} + + +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); +} + + +LispObj +current_thread_osid() +{ + return (LispObj)ptr_to_lispobj(pthread_self()); +} + + + +int thread_suspend_signal = 0, thread_resume_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_INTERRUPT_LEVEL(tcr) <= (-2<suspend_context = context; +#if 0 + sigfillset(&wait_for); +#endif + SEM_RAISE(tcr->suspend); +#if 0 + sigdelset(&wait_for, thread_resume_signal); +#endif +#if 1 +#if RESUME_VIA_RESUME_SEMAPHORE + SEM_WAIT_FOREVER(tcr->resume); +#if SUSPEND_RESUME_VERBOSE + fprintf(stderr, "got resume in 0x%x\n",tcr); +#endif + tcr->suspend_context = NULL; +#else + sigsuspend(&wait_for); +#endif +#else + do { + sigsuspend(&wait_for); + } while (tcr->suspend_context); +#endif + } else { + tcr->suspend_context = NULL; +#if SUSEPEND_RESUME_VERBOSE + fprintf(stderr,"got resume in in 0x%x\n",tcr); +#endif + } +#if WAIT_FOR_RESUME_ACK + SEM_RAISE(tcr->suspend); +#endif + } +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif +#ifdef DARWIN + DarwinSigReturn(context); +#endif +#ifdef FREEBSD + freebsd_sigreturn(context); +#endif +} + + + +/* + 'base' should be set to the bottom (origin) of the stack, e.g., the + end from which it grows. +*/ + +void +os_get_stack_bounds(LispObj q,void **base, natural *size) +{ + pthread_t p = (pthread_t)(q); +#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); + *(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; +#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 +} + +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); +#endif +#ifdef USE_MACH_SEMAPHORES + semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s)); +#endif + *s=NULL; + } +} + +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); +} + +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); +} + +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 (next = chain; next;) { + next = next->next; + free(chain); + } + return tcr; + } +} + +#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 +} + +#endif + + + +/* + Caller must hold the area_lock. +*/ +TCR * +new_tcr(natural vstack_size, natural tstack_size) +{ + extern area + *allocate_vstack_holding_area_lock(unsigned), + *allocate_tstack_holding_area_lock(unsigned); + area *a; + int i; + sigset_t sigmask; + + sigemptyset(&sigmask); + pthread_sigmask(SIG_SETMASK,&sigmask, NULL); +#ifdef HAVE_TLS + TCR *tcr = ¤t_tcr; +#else + TCR *tcr = allocate_tcr(); +#endif + +#ifdef X8664 + setup_tcr_extra_segment(tcr); + tcr->linear = tcr; +#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; + return tcr; +} + +void +shutdown_thread_tcr(void *arg) +{ + TCR *tcr = TCR_FROM_TSD(arg); + + area *vs, *ts, *cs; + void *termination_semaphore; + + 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),tcr); + 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); + free(tcr->tlb_pointer); + tcr->tlb_pointer = NULL; + tcr->tlb_limit = 0; + tcr->osid = 0; + tcr->interrupt_pending = 0; + termination_semaphore = tcr->termination_semaphore; + tcr->termination_semaphore = NULL; +#ifdef HAVE_TLS + dequeue_tcr(tcr); +#endif + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); + if (termination_semaphore) { + SEM_RAISE(termination_semaphore); + } + } 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 + getpid() +#endif +#ifdef DARWIN + mach_thread_self() +#endif +#ifdef FREEBSD + pthread_self() +#endif +#ifdef SOLARIS + pthread_self() +#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 + 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_stack_bounds(current_thread_osid(),&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(int size) +{ + Ptr p; + size=align_to_power_of_2(size, log2_page_size); + p = (Ptr) mmap(NULL, + (size_t)size, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_GROWSDOWN, + -1, /* Darwin insists on this when not mmap()ing + a real fd */ + 0); + if (p != (Ptr)(-1)) { + *((size_t *)p) = size; + return p; + } + allocation_failure(true, size); + +} + +void * +allocate_stack(unsigned size) +{ + return create_stack(size); +} + +void +free_stack(void *s) +{ + size_t size = *((size_t *)s); + munmap(s, size); +} + +Boolean threads_initialized = false; + +#ifndef USE_FUTEX +void +count_cpus() +{ +#ifdef DARWIN + /* As of OSX 10.4, Darwin doesn't define _SC_NPROCESSORS_ONLN */ +#include + + struct host_basic_info info; + mach_msg_type_number_t count = HOST_BASIC_INFO_COUNT; + + if (KERN_SUCCESS == host_info(mach_host_self(), HOST_BASIC_INFO,(host_info_t)(&info),&count)) { + if (info.max_cpus > 1) { + spin_lock_tries = 1024; + } + } +#else + 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); + pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr); + thread_signal_setup(); + +#ifndef USE_FUTEX + count_cpus(); +#endif + threads_initialized = true; +} + + +void * +lisp_thread_entry(void *param) +{ + thread_activation *activation = (thread_activation *)param; + TCR *tcr = new_tcr(activation->vsize, activation->vsize); + sigset_t mask, old_mask; + + sigemptyset(&mask); + pthread_sigmask(SIG_SETMASK, &mask, &old_mask); + + register_thread_tcr(tcr); + + pthread_cleanup_push(tcr_cleanup,(void *)tcr); + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = lisp_nil; + 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); + } while (tcr->flags & (1<next; + } while (p != head); + return false; +} + + +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; +} + +OSErr +xYieldToThread(TCR *target) +{ + Bug(NULL, "xYieldToThread ?"); + return 0; +} + +OSErr +xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP) +{ + Bug(NULL, "xThreadCurrentStackSpace ?"); + return 0; +} + + + +LispObj +create_system_thread(size_t stack_size, + void* stackaddr, + void* (*start_routine)(void *), + void* param) +{ + pthread_attr_t attr; + pthread_t returned_thread = (pthread_t) 0; + + 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 ... */ +#ifdef DARWIN + Fatal("no pthread_attr_setsetstack. "," Which end of stack does address refer to?"); +#else + pthread_attr_setstack(&attr, stackaddr, stack_size); +#endif + } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) { + pthread_attr_setstacksize(&attr,stack_size); + } + + /* + I think that's just about enough ... create the thread. + */ + pthread_create(&returned_thread, &attr, start_routine, param); + return (LispObj) ptr_to_lispobj(returned_thread); +} + +TCR * +get_tcr(Boolean create) +{ +#ifdef HAVE_TLS + TCR *current = current_tcr.linear; +#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 unsigned 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 + fprintf(stderr, "\ncreating TCR for pthread 0x%x", pthread_self()); +#endif + current->vs_area->active -= node_size; + *(--current->save_vsp) = lisp_nil; +#ifdef PPC +#define NSAVEREGS 8 +#endif +#ifdef X8664 +#define NSAVEREGS 4 +#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; +} + + +Boolean +suspend_tcr(TCR *tcr) +{ + int suspend_count = atomic_incf(&(tcr->suspend_count)); + if (suspend_count == 1) { +#if SUSPEND_RESUME_VERBOSE + fprintf(stderr,"Suspending 0x%x\n", tcr); +#endif +#ifdef DARWIN_nope + if (mach_suspend_tcr(tcr)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_ALT_SUSPEND); + return true; + } +#endif + if (pthread_kill((pthread_t)(tcr->osid), 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; +} + +Boolean +tcr_suspend_ack(TCR *tcr) +{ + if (tcr->flags & (1<suspend); + tcr->flags &= ~(1<suspend_count)), err; + if (suspend_count == 0) { +#ifdef DARWIN + if (tcr->flags & (1<resume); +#else + if ((err = (pthread_kill((pthread_t)(tcr->osid), thread_resume_signal))) != 0) { + Bug(NULL, "pthread_kill returned %d on thread #x%x", err, tcr->osid); + } +#endif +#if SUSPEND_RESUME_VERBOSE + fprintf(stderr, "Sent resume to 0x%x\n", tcr); +#endif + return true; + } + return false; +} + +void +wait_for_resumption(TCR *tcr) +{ + if (tcr->suspend_count == 0) { +#ifdef DARWIN + if (tcr->flags & (1<flags &= ~(1<suspend); +#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); + wait_for_resumption(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 + free(current); +#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); +#ifdef DARWIN +#if USE_MACH_EXCEPTION_LOCK + if (for_gc && use_mach_exception_handling) { +#if SUSPEND_RESUME_VERBOSE + fprintf(stderr, "obtaining Mach exception lock in GC thread 0x%x\n", current); +#endif + pthread_mutex_lock(mach_exception_lock); + } +#endif +#endif + 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); + } + } + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + wait_for_resumption(other); + } + } + free_freed_tcrs(); +#ifdef DARWIN +#if USE_MACH_EXCEPTION_LOCK + if (for_gc && use_mach_exception_handling) { +#if SUSPEND_RESUME_VERBOSE + fprintf(stderr, "releasing Mach exception lock in GC thread 0x%x\n", current); +#endif + pthread_mutex_unlock(mach_exception_lock); + } +#endif +#endif + + 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; + + 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/experimentation/later/source/lisp-kernel/win64/Makefile =================================================================== --- /branches/experimentation/later/source/lisp-kernel/win64/Makefile (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/win64/Makefile (revision 8058) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2005 Clozure Associates +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL 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 +CC = x86_64-pc-mingw32-gcc +AS = x86_64-pc-mingw32-as +M4 = m4 +ASFLAGS = --64 +M4FLAGS = -DWIN64 -DWINDOWS -DX86 -DX8664 -DHAVE_TLS -DEMUTLS +CDEFINES = -DWIN64 -DWINDOWS -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DEMUTLS #-DDISABLE_EGC +CDEBUG = -g +COPT = -O2 + +# 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) -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 + +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: ../../wx86cl64 + + +OSLIBS = -ldl -lm -lpthread + + +../../wx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(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) ../../wx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../wx86cl64 + strip -g ../../wx86cl64 Index: /branches/experimentation/later/source/lisp-kernel/x86-asmutils64.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-asmutils64.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-asmutils64.s (revision 8058) @@ -0,0 +1,201 @@ +/* Copyright (C) 2005 Clozure Associates */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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 %rsi cache lines, starting at address in %rdi. Each line is */ +/* assumed to be %rdx bytes wide. */ +_exportfn(C(flush_cache_lines)) + __(cmpq $0,%rsi) + __(jmp 2f) +1: __(clflush (%rdi)) + __(addq %rdx,%rdi) + __(subq $1,%rsi) +2: __(jg 1b) + __(repret) +_endfn + +_exportfn(C(current_stack_pointer)) + __(movq %rsp,%rax) + __(ret) +_endfn + +_exportfn(C(touch_page)) + __(movq %rdi,(%rdi)) + __(movq $0,(%rdi)) + __(movl $1,%eax) + .globl C(touch_page_end) +C(touch_page_end): + __(ret) + +_exportfn(C(count_leading_zeros)) + __(bsrq %rdi,%rax) + __(xorq $63,%rax) + __(ret) +_endfn + +_exportfn(C(noop)) + __(retq) +_endfn + +_exportfn(C(set_mxcsr)) + __(pushq %rdi) + __(ldmxcsr (%rsp)) + __(addq $8,%rsp) + __(ret) +_endfn + +_exportfn(C(get_mxcsr)) + __(pushq $0) + __(stmxcsr (%rsp)) + __(popq %rax) + __(ret) +_endfn + +_exportfn(C(save_fp_context)) +_endfn + +_exportfn(C(restore_fp_context)) +_endfn + +/* Atomically store new value (%rdx) in *%rdi, if old value == %rsi. */ +/* Return actual old value. */ +_exportfn(C(store_conditional)) + __(mov %rsi,%rax) + __(lock) + __(cmpxchgq %rdx,(%rdi)) + __(cmovne %rdx,%rax) + __(ret) +_endfn + +/* Atomically store new_value(%rsi) in *%rdi ; return previous contents */ +/* of *%rdi. */ + +_exportfn(C(atomic_swap)) + __(lock) + __(xchg %rsi,(%rdi)) + __(mov %rsi,%rax) + __(ret) +_endfn + +/* Logior the value in *%rdi with the value in %rsi (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 (%rdi), %rax) + __(movq %rax,%rcx) + __(orq %rsi,%rcx) + __(lock) + __(cmpxchg %rcx,(%rdi)) + __(jnz 0b) + __(andq %rsi,%rax) + __(ret) +_endfn + + +/* Logand the value in *rdi with the value in rsi (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *rdi (for some value of "now" */ + +_exportfn(C(atomic_and)) +0: __(movq (%rdi), %rax) + __(movq %rax,%rcx) + __(and %rsi,%rcx) + __(lock) + __(cmpxchg %rcx,(%rdi)) + __(jnz 0b) + __(movq %rcx,%rax) + __(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) */ +/* %rdi, %rsi, %rdx, %rcx */ +_exportfn(C(cpuid)) + __(pushq %rdx) /* pecx */ + __(pushq %rcx) /* pedx */ + __(pushq %rbx) /* %rbx is non-volatile */ + __(movq %rdi,%rax) + __(xorl %ecx,%ecx) + __(cpuid) + __(movl %ebx,(%rsi)) + __(popq %rbx) + __(popq %rsi) /* recover pedx */ + __(movl %edx,(%rsi)) + __(popq %rsi) /* recover pecx */ + __(movl %ecx,(%rsi)) + __(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 */ +_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 + +_exportfn(C(freebsd_sigreturn)) + __(movl $417,%eax) /* SYS_sigreturn */ + __(syscall) +_exportfn(C(get_vector_registers)) +_endfn + +_exportfn(C(put_vector_registers)) +_endfn + + + __ifdef([DARWIN_GS_HACK]) +/* Check (in and 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 + _endfile Index: /branches/experimentation/later/source/lisp-kernel/x86-constants.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-constants.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-constants.h (revision 8058) @@ -0,0 +1,63 @@ +/* + Copyright (C) 2005 Clozure Associates + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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/experimentation/later/source/lisp-kernel/x86-constants.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-constants.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-constants.s (revision 8058) @@ -0,0 +1,133 @@ +/* Copyright (C) 2005 Clozure Associates */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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 destrucuring-bind/macro-bind */ + +define([whole_reg],[temp1]) +define([arg_reg],[temp0]) +define([keyvect_reg],[arg_x]) +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 = 48 /* MUST UPDATE THIS !!! */ + + _struct(lisp_globals,lisp_globals_limit-(num_lisp_globals*node_size)) + _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(bad_funcall) /* pseudo-funcall target for cmove */ + _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<> 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; +} TCR; + +#define t_offset (t_value-nil_value) + +/* + 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/experimentation/later/source/lisp-kernel/x86-constants64.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-constants64.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-constants64.s (revision 8058) @@ -0,0 +1,767 @@ +/* Copyright (C) 2005 Clozure Associates */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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. */ + + + +/* 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]) + +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]) + +/* The TCR can be accessed relative to %gs */ +define([rcontext],[gs]) +define([fname],[temp0]) +define([next_method_context],[temp0]) +define([nargs_b],[imm2_b]) +define([nargs],[imm2_w]) +define([nargs_q],[imm2]) +define([nargs_l],[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]) + + +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,0x3020) + _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 +#include + + +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; + +Boolean +handle_gc_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj + selector = xpGPR(xp,Iimm0), + arg = xpGPR(xp,Iimm1); + 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: + a->threshold = unbox_fixnum(xpGPR(xp, Iarg_x)); + 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; + + 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_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); + area *vsarea = tcr->vs_area; + + nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1); + err = save_application(arg); + 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)&0xffff)>> fixnumshift; + signed_natural disp = nargs-3; + LispObj *vsp = (LispObj *) xpGPR(xp,Isp), ra = *vsp++; + + + if (disp > 0) { /* implies that nargs > 3 */ + vsp[disp] = xpGPR(xp,Irbp); + vsp[disp+1] = ra; + xpGPR(xp,Irbp) = (LispObj)(vsp+disp); + xpGPR(xp,Isp) = (LispObj)vsp; + push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); + 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,Irbp)); + xpGPR(xp,Irbp) = xpGPR(xp,Isp); + if (nargs == 3) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); + } + 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) +{ + 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)); + 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; + } + + abs_pc = (LispObj)xpPC(xp); + + if (fulltag_of(f) == fulltag_function) { + 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,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,Irbp)); + xpGPR(xp,Irbp) = xpGPR(xp,Isp); + return xpGPR(xp,Isp); +} + +#ifndef XMEMFULL +#define XMEMFULL (76) +#endif + +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) { + disp = xpGPR(xp,Iimm1); + } 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; + } + + { + LispObj xcf = create_exception_callback_frame(xp), + 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; + } + + return true; +} + +extern unsigned get_mxcsr(); +extern void set_mxcsr(unsigned); + +int +callback_to_lisp (TCR * tcr, LispObj callback_macptr, ExceptionInformation *xp, + natural arg1, natural arg2, natural arg3, natural arg4, natural arg5) +{ + sigset_t mask; + natural callback_ptr, i; + int delta; + unsigned old_mxcsr = get_mxcsr(); + + set_mxcsr(0x1f80); + + /* Put the active stack pointers where .SPcallback expects them */ + tcr->save_vsp = (LispObj *) xpGPR(xp, Isp); + tcr->save_rbp = (LispObj *) xpGPR(xp, Irbp); + + + /* 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); + set_mxcsr(old_mxcsr); + return delta; +} + +void +callback_for_interrupt(TCR *tcr, ExceptionInformation *xp) +{ + LispObj save_rbp = xpGPR(xp,Irbp), + *save_vsp = (LispObj *)xpGPR(xp,Isp), + word_beyond_vsp = save_vsp[-1], + xcf = create_exception_callback_frame(xp); + int save_errno = errno; + + callback_to_lisp(tcr, nrs_CMAIN.vcell,xp, xcf, 0, 0, 0, 0); + xpGPR(xp,Irbp) = save_rbp; + 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_rbp = xpGPR(xp,Irbp), save_vsp = xpGPR(xp,Isp), xcf0; + 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); + 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,1)))+rpc; + } + + skip = 0; + } + xpGPR(xp,Irbp) = save_rbp; + 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) & 0xffff)>>fixnumshift; + + if (nargs > 3) { + xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3))); + push_on_lisp_stack(xp,ra); + } + xpPC(xp) = xpGPR(xp,Ifn); + xpGPR(xp,Inargs) = 1<why; + Boolean on_TSP = (which == kTSPsoftguard); + LispObj save_rbp = xpGPR(xp,Irbp), + 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); + skip = callback_to_lisp(tcr, nrs_CMAIN.vcell, xp, xcf, SIGSEGV, on_TSP, 0, 0); + xpGPR(xp,Irbp) = save_rbp; + 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 +#ifdef LINUX + return (xpGPR(xp,REG_ERR) & 0x2) != 0; +#endif +#ifdef FREEBSD + return (xp->uc_mcontext.mc_err & 0x2) != 0; +#endif +} + +Boolean +handle_fault(TCR *tcr, ExceptionInformation *xp, siginfo_t *info, int old_valence) +{ +#ifdef FREEBSD + BytePtr addr = (BytePtr) xp->uc_mcontext.mc_addr; +#else + BytePtr addr = (BytePtr) info->si_addr; +#endif + + if (addr && (addr == tcr->safe_ref_address)) { + xpGPR(xp,Iimm0) = 0; + xpPC(xp) = xpGPR(xp,Ira0); + return true; + } else { + protected_area *a = find_protected_area(addr); + protection_handler *handler; + + if (a) { + handler = protection_handlers[a->why]; + return handler(xp, a, addr); + } + } + 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); + callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, is_write_fault(xp,info), (natural)addr, 0); + } + } + return false; +} + +Boolean +handle_floating_point_exception(TCR *tcr, ExceptionInformation *xp, siginfo_t *info) +{ + int code = info->si_code, rfn = 0, skip; + pc program_counter = (pc)xpPC(xp); + LispObj rpc = (LispObj) program_counter, xcf, cmain = nrs_CMAIN.vcell, + + save_rbp = xpGPR(xp,Irbp), save_vsp = xpGPR(xp,Isp); + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + xcf = create_exception_callback_frame(xp); + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0); + xpPC(xp) += skip; + xpGPR(xp,Irbp) = save_rbp; + 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) { + struct savefpu *fpu = (struct savefpu *) &(xp->uc_mcontext.mc_fpstate); + 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 == 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_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)) { + 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; + + 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; + + 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); +#if 0 + fprintf(stderr, "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; + UNLOCK(lisp_global(EXCEPTION_LOCK),tcr); +#if 0 + fprintf(stderr, "0x%x 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. +*/ +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); + + 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) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + xframe_list xframe_link; +#ifndef DARWIN + tcr = get_tcr(false); + + old_valence = prepare_to_wait_for_exception_lock(tcr, context); +#endif + if (tcr->flags & (1<regs at #x%lx", 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 +} + +#ifdef DARWIN +void +pseudo_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + sigset_t mask; + + sigfillset(&mask); + + pthread_sigmask(SIG_SETMASK,&mask,&(context->uc_sigmask)); + signal_handler(signum, info, context, tcr, old_valence); +} +#endif + + + +#ifdef LINUX +LispObj * +copy_fpregs(ExceptionInformation *xp, LispObj *current, fpregset_t *destptr) +{ + fpregset_t src = xp->uc_mcontext.fpregs, dest; + + if (src) { + dest = ((fpregset_t)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; + dest = (siginfo_t *) (((LispObj)dest)&~15); + *dest = *info; + return (LispObj *)dest; +} + +#ifdef LINUX +typedef fpregset_t copy_ucontext_last_arg_t; +#else +typedef void * copy_ucontext_last_arg_t; +#endif + +LispObj * +copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp) +{ + ExceptionInformation *dest = ((ExceptionInformation *)current)-1; + dest = (ExceptionInformation *) (((LispObj)dest) & ~15); + + *dest = *context; + /* Fix it up a little; where's the signal mask allocated, if indeed + it is "allocated" ? */ +#ifdef LINUX + dest->uc_mcontext.fpregs = 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; +} + +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 DARWIN +void +bogus_signal_handler(int signum, siginfo_t *info, ExceptionInformation *xp) +{ + if (signum == SIGSYS) { + return; /* Leopard lossage */ + } +} +#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 + fpregset_t 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 + 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; +#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); +} + + +#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 + +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)); +} + +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); + 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,Irbp), tcr)) { + tcr->interrupt_pending = (1L << (nbits_in_word - 1L)); + } 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; + int old_valence; + 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); + exit_signal_handler(tcr, old_valence); + } + } + } +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + SIGRETURN(context); +} + +#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 + + +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,SIGNUM_FOR_INTN_TRAP); + sigdelset(&sa.sa_mask,SIGTRAP); /* let GDB work */ + sigdelset(&sa.sa_mask,SIGILL); + sigdelset(&sa.sa_mask,SIGFPE); + sigdelset(&sa.sa_mask,SIGSEGV); +#endif + sa.sa_flags = + 0 /* SA_RESTART */ +#ifdef USE_SIGALTSTACK + | SA_ONSTACK +#endif + | SA_SIGINFO; + + sigaction(signo, &sa, NULL); +} + + +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); +#else + install_signal_handler(SIGTRAP,bogus_signal_handler); + install_signal_handler(SIGILL, bogus_signal_handler); + + install_signal_handler(SIGBUS, bogus_signal_handler); + install_signal_handler(SIGSEGV,bogus_signal_handler); + install_signal_handler(SIGFPE, bogus_signal_handler); + /* 9.0.0d8 generates spurious SIGSYS from mach_msg_trap */ + install_signal_handler(SIGSYS, bogus_signal_handler); +#endif + + install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, +#ifdef USE_SIGALTSTACK + altstack_interrupt_handler +#else + arbstack_interrupt_handler +#endif +); + signal(SIGPIPE, SIG_IGN); +} + +#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); + 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, + 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 + +void +quit_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); +} + +#ifndef USE_SIGALTSTACK +arbstack_quit_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, + quit_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 + quit_handler(signum, info, context); + } +} + + +#else +void +altstack_quit_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, + quit_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} +#endif + +#ifdef USE_SIGALTSTACK +#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler +#define QUIT_HANDLER altstack_quit_handler +#else +#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler +#define QUIT_HANDLER arbstack_quit_handler +#endif + +void +thread_signal_setup() +{ + thread_suspend_signal = SIG_SUSPEND_THREAD; + thread_resume_signal = SIG_RESUME_THREAD; + + install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER); + install_signal_handler(thread_resume_signal, (void *)SUSPEND_RESUME_HANDLER); + install_signal_handler(SIGQUIT, (void *)QUIT_HANDLER); +} + + +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_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. +*/ + +opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] = + {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}; +opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] = + {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}; +opcode branch_around_alloc_trap_instruction[] = + {0x7f,0x02}; +opcode alloc_trap_instruction[] = + {0xcd,0xc5}; +opcode clear_tcr_save_allocptr_tag_instruction[] = + {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}; +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; + case 0x7f: return ID_branch_around_alloc_trap_instruction; + case 0x48: return ID_set_allocptr_header_instruction; + 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; + } + } + } + return ID_unrecognized_alloc_instruction; +} + + +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 : + xpGPR(xp,Iimm1); + 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%lx, 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 and skip over this + instruction, then fall into the next case. */ + new_vector = xpGPR(xp,Iallocptr); + deref(new_vector,0) = xpGPR(xp,Iimm0); + + 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); + 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; + 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)); + } + break; + case ID_branch_around_alloc_trap_instruction: + /* If we'd take the branch - which is a 'jg" - around the alloc trap, + we might as well finish the allocation. Otherwise, back out of the + attempt. */ + { + int flags = (int)xpGPR(xp,Iflags); + + if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) && + ((flags & (1 << X86_SIGN_FLAG_BIT)) == + (flags & (1 << X86_CARRY_FLAG_BIT)))) { + /* The branch (jg) 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); + 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)); + 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); + /* 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; + } + return; + } + if ((program_counter >= &egc_write_barrier_start) && + (program_counter < &egc_write_barrier_end)) { + LispObj *ea = 0, val, root; + bitvector refbits = (bitvector)(lisp_global(REFBITS)); + Boolean need_store = true, need_check_memo = true, need_memoize_root = false; + + if (program_counter >= &egc_store_node_conditional) { + if ((program_counter < &egc_store_node_conditional_success_test) || + ((program_counter == &egc_store_node_conditional_success_test) && + !(xpGPR(xp, Iflags) & (1 << X86_ZERO_FLAG_BIT)))) { + /* Back up the PC, try again */ + xpPC(xp) = (LispObj) &egc_store_node_conditional; + return; + } + /* The conditional store succeeded. Set the refbit, return to ra0 */ + val = xpGPR(xp,Iarg_z); + ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural) + xpGPR(xp,Itemp0)))); + xpGPR(xp,Iarg_z) = t_value; + need_store = false; + } else if (program_counter >= &egc_set_hash_key) { + root = xpGPR(xp,Iarg_x); + 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) { + ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset); + 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 *rsp = (LispObj *)xpGPR(xp,Isp), ra = *rsp++; + xpPC(xp) = ra; + xpGPR(xp,Isp)=(LispObj)rsp; + } + return; + } +} + +void +normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr) +{ + void *cur_allocptr = (void *)(tcr->save_allocptr); + LispObj lisprsp, lisptsp; + 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; + + +int +gc_like_from_xp(ExceptionInformation *xp, + int(*fun)(TCR *, signed_natural), + signed_natural param) +{ + TCR *tcr = get_tcr(false), *other_tcr; + ExceptionInformation* other_xp; + 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; + +} + +int +purify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, purify, param); +} + +int +impurify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, impurify, param); +} + +/* Returns #bytes freed by invoking GC */ + +int +gc_from_tcr(TCR *tcr, signed_natural param) +{ + area *a; + BytePtr oldfree, newfree; + BytePtr oldend, newend; + +#if 0 + fprintf(stderr, "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(stderr, "End GC in 0x%lx\n", tcr); +#endif + return ((oldfree-newfree)+(newend-oldend)); +} + +int +gc_from_xp(ExceptionInformation *xp, signed_natural param) +{ + int 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))) + +#if USE_MACH_EXCEPTION_LOCK +pthread_mutex_t _mach_exception_lock, *mach_exception_lock; +#endif +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) +{ + int i, j; + kern_return_t kret; +#if WORD_SIZE == 64 + MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext); +#else + struct mcontext * mc = UC_MCONTEXT(pseudosigcontext); +#endif + + /* Set the thread's FP state from the pseudosigcontext */ + kret = thread_set_state(thread, + x86_FLOAT_STATE64, + (thread_state_t)&(mc->__fs), + x86_FLOAT_STATE64_COUNT); + + 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(stderr, "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(stderr, "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_state_t *ts +#endif + ) +{ + mach_msg_type_number_t thread_state_count; + kern_return_t result; + int i,j; + ExceptionInformation *pseudosigcontext; +#ifdef X8664 + MCONTEXT_T mc; +#else + struct mcontext *mc; +#endif + natural stackp, backlink; + + + stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr); + stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN); + 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); +#ifdef X8664 + mc = (MCONTEXT_T) ptr_from_lispobj(stackp); +#else + mc = (struct mcontext *) ptr_from_lispobj(stackp); +#endif + + memmove(&(mc->__ss),ts,sizeof(*ts)); + + thread_state_count = x86_FLOAT_STATE64_COUNT; + thread_get_state(thread, + x86_FLOAT_STATE64, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + +#ifdef X8664 + thread_state_count = x86_EXCEPTION_STATE64_COUNT; +#else + thread_state_count = x86_EXCEPTION_STATE_COUNT; +#endif + thread_get_state(thread, +#ifdef X8664 + x86_EXCEPTION_STATE64, +#else + x86_EXCEPTION_STATE, +#endif + (thread_state_t)&(mc->__es), + &thread_state_count); + + + 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_state_t *ts +#endif + ) +{ +#ifdef X8664 + x86_thread_state64_t new_ts; +#else + x86_thread_state_t new_ts; +#endif + ExceptionInformation *pseudosigcontext; + int i, j, old_valence = tcr->valence; + kern_return_t result; + natural stackp, *stackpp; + siginfo_t *info; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(stderr,"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. + */ + + 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; + + +#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_STATE, + (thread_state_t)&new_ts, + x86_THREAD_STATE_COUNT); +#endif +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(stderr,"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 + +#ifdef DARWIN_USE_PSEUDO_SIGRETURN +#define DARWIN_EXCEPTION_HANDLER signal_handler +#else +#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler +#endif + + +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, call_kret; +#ifdef X8664 + x86_thread_state64_t ts; +#else + x86_thread_state_t ts; +#endif + mach_msg_type_number_t thread_state_count; + + + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(stderr, "obtaining Mach exception lock in exception thread\n"); +#endif + + + if ( +#if USE_MACH_EXCEPTION_LOCK + pthread_mutex_trylock(mach_exception_lock) == 0 +#else + 1 +#endif + ) { +#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_STATE_COUNT; + thread_get_state(thread, + x86_THREAD_STATE, + (thread_state_t)&ts, + &thread_state_count); +#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), + target_thread = pthread_mach_thread_np((pthread_t)ptr_from_lispobj(tcr->osid)), + 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(stderr, "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(stderr, "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_state_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(stderr, "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(stderr, "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 Index: /branches/experimentation/later/source/lisp-kernel/x86-exceptions.h =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-exceptions.h (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-exceptions.h (revision 8058) @@ -0,0 +1,169 @@ +/* + Copyright (C) 2005 Clozure Associates + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +typedef u8_t opcode, *pc; + +#ifdef LINUX +#ifdef X8664 +#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]))) +#endif +#endif + +#ifdef DARWIN +#define DARWIN_USE_PSEUDO_SIGRETURN 1 +#include +#define DarwinSigReturn(context) syscall(0x2000000|SYS_sigreturn,context,0x1e) +#ifdef X8664 +#define xpGPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__ss.__rax))) +#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 xpFPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__fs.__fpu_xmm0))) +#define xpMMXreg(x,n) (xpFPRvector(x)[n]) +#endif +#include +#include +#include +#include + +pthread_mutex_t *mach_exception_lock; + +#endif + +#ifdef FREEBSD +#ifdef X8664 +#include +#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 xpPC(x) xpGPR(x,Iip) +#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])) +#endif +#endif + +#ifdef SOLARIS +#ifdef X8664 +#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 xpMMXreg(x,n) *((natural *)(&(x)->uc_mcontext.fpregs.fp_reg_set.fpchip_state.st[n])) +#endif +#endif + +#ifdef WIN64 +#define xpGPRvector(x) ((DWORD64 *)((x)->ContextRecord)) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define xpPC(x) xpGPR(x,Iip); +#endif + +#ifdef DARWIN +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGEMT +#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 SIGEMT +#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 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 + +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) (((info->si_code) &0x7f) == 0) +#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) +#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) (info->si_code == EXC_I386_GPFLT) +/* 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 + +/* 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 +#define USE_SIGALTSTACK 1 +/* #undef USE_SIGALTSTACK */ +#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 */ Index: /branches/experimentation/later/source/lisp-kernel/x86-gc.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-gc.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-gc.c (revision 8058) @@ -0,0 +1,2379 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL 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 + +#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 + + +/* 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: + case fulltag_imm_0: + case fulltag_imm_1: + return; + + case fulltag_nil: + if (n != lisp_nil) { + Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n); + } + return; + + + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: + Bug(NULL, "Header not expected : 0x%lx", n); + return; + + case fulltag_tra_0: + case fulltag_tra_1: + 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%lx", n); + } + return; + } + /* tra points into the heap. Check displacement, then + check the function it (should) identify. + */ + { + 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%lx has bad displacement %d\n", n, disp); + } + } + /* Otherwise, fall through and check the header on the function + that the tra references */ + + case fulltag_misc: + case fulltag_cons: + case fulltag_symbol: + case fulltag_function: + 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_all_mark_bits(LispObj *nodepointer) +{ +} + + + + + +void +check_range(LispObj *start, LispObj *end, Boolean header_allowed) +{ + LispObj node, *current = start, *prev; + 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; + if (header_subtag(node) == subtag_function) { + int skip = *(int *)current; + 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); + } +} + +void +check_all_areas() +{ + 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; + 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; + } + + 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; + } + else { + 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; + natural prefix_nodes = 0; + + 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 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); + } + } + + 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; + } + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = 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; + } + } + + if (subtag == subtag_function) { + prefix_nodes = (natural) ((int) deref(base,1)); + if (prefix_nodes > element_count) { + Bug(NULL, "Function 0x%lx trashed",n); + } + } + base += (1+element_count); + + element_count -= prefix_nodes; + + while(element_count--) { + rmark(*--base); + } + if (subtag == subtag_weak) { + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = 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_nil + node_size. Coincidence ? I think not. */ +#else +#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, original_n = n; + + if (!is_node_fulltag(tag_n)) { + return; + } + + 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; + } else { + 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, + nmark; + + 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); + } + } + 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; + } + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = 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) { + if ((int)base[1] >= nmark) { + Bug(NULL,"Bad function at 0x%lx",n); + } + nmark -= (int)base[1]; + } + + while (nmark--) { + rmark(deref(n,element_count)); + element_count--; + } + + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = 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: + case tag_symbol: + case fulltag_symbol: + case tag_function: + case fulltag_function: + 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: + 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); + } + } + 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; + } + + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = this; + goto Climb; + } + + 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); + if ((tag_of(this) == tag_function) && + (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; + 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 = this; + } + goto Climb; + + MarkFunctionDone: + boundary = (LispObj *)(node_aligned(this)); + this = ((LispObj)boundary) + (((int *)boundary)[1]); + (((int *)boundary)[1]) = 0; + goto Climb; + } +} + +LispObj * +skip_over_ivector(natural start, LispObj header) +{ + natural + element_count = header_element_count(header), + subtag = header_subtag(header), + nbytes; + + + + 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))); + +} + + +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) { + int skip = (int) deref(start,1); + 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%08X", 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; + + 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); + 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_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; + } + + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + } else { + + 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 = (LispObj) (((natural) start) + fulltag_misc); + } + + base = start + element_count + 1; + if (subtag == subtag_function) { + element_count -= (int)start[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; + 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(stderr, "mark VSP range: 0x%lx:0x%lx\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 */ +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); + } + } +} + + + + + + + + +/* 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 + +/* 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 + +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 = (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 { + if (header_subtag(node) == subtag_function) { + int skip = (int)(p[1]); + 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) +{ +} + + +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])); +} + + +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) { + 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, *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; + /* 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_function) { + int skip = *((int *)src); + *dest++ = node; + elements -= skip; + while(skip--) { + *dest++ = *src++; + } + 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); + + + 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); + } + } + 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); + + 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); + } + } + 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 + subtag = header_subtag(header), + element_count = header_element_count(header), + physbytes; + + switch(subtag) { + case subtag_simple_base_string: + physbytes = node_size + (element_count << 2); + break; + +#ifndef X86 + case subtag_code_vector: + physbytes = node_size + (element_count << 2); + break; +#endif + + default: + Bug(NULL, "Can't purify object at 0x%08x", obj); + return obj; + } + physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1); + 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)); +} + + +#define FORWARD_ONLY 0 +#define COPY_CODE (1<<0) +#define COPY_STRINGS (1<<1) + + +/* + This may overestimate a bit, if the same symbol is accessible from multiple + packages. +*/ +natural +interned_pname_bytes_in_range(LispObj *start, LispObj *end) +{ + lispsymbol *rawsym = (lispsymbol *)(&(nrs_ALL_PACKAGES)); + LispObj pkg_list = rawsym->vcell, htab, obj, pname, pname_header; + package *p; + cons *c; + natural elements, i, nbytes = 0; + + while (fulltag_of(pkg_list) == fulltag_cons) { + c = (cons *) ptr_from_lispobj(untag(pkg_list)); + p = (package *) ptr_from_lispobj(untag(c->car)); + pkg_list = c->cdr; + c = (cons *) ptr_from_lispobj(untag(p->itab)); + htab = c->car; + elements = header_element_count(header_of(htab)); + for (i = 1; i<= elements; i++) { + obj = deref(htab,i); + if (fulltag_of(obj) == fulltag_symbol) { + rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); + pname = rawsym->pname; + + if ((pname >= (LispObj)start) && (pname < (LispObj)end)) { + pname_header = header_of(pname); + nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15); + } + } + } + c = (cons *) ptr_from_lispobj(untag(p->etab)); + htab = c->car; + elements = header_element_count(header_of(htab)); + for (i = 1; i<= elements; i++) { + obj = deref(htab,i); + if (fulltag_of(obj) == fulltag_symbol) { + rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); + pname = rawsym->pname; + + if ((pname >= (LispObj)start) && (pname < (LispObj)end)) { + pname_header = header_of(pname); + nbytes += ((8 + (header_element_count(pname_header)<<2) + 15) &~15); + } + } + } + } + return nbytes; +} + +Boolean +copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy) +{ + LispObj obj = *ref, header, new; + natural tag = fulltag_of(obj), header_tag, header_subtag; + 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)) { + header_subtag = header_subtag(header); + if ((what_to_copy & COPY_STRINGS) && + ((header_subtag == subtag_simple_base_string))) { + new = purify_object(obj, dest); + *ref = new; + changed = (new != obj); + } + } + } + } + return changed; +} + + +void purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) +{ + while (start < end) { + copy_ivector_reference(start, low, high, to, what); + start++; + } +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) +{ + 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, what); + 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, what) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + start++; + copy_ivector_reference(start, low, high, to, what); + start++; + } + *start++ = 0; + } else { + if (header_subtag(header) == subtag_function) { + int skip = (int)(start[1]); + start += skip; + nwords -= skip; + } + start++; + while(nwords--) { + copy_ivector_reference(start, low, high, to, what); + start++; + } + } + } else { + /* Not a header, just a cons cell */ + copy_ivector_reference(start, low, high, to, what); + start++; + copy_ivector_reference(start, low, high, to, what); + start++; + } + } + } +} + +/* Purify references from tstack areas */ +void +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + 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, what); + } + } +} + +/* Purify a vstack area */ +void +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + purify_headerless_range(p, q, low, high, to, what); +} + + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what) +{ + natural *regs = (natural *) xpGPRvector(xp); + + +#ifdef X8664 + copy_ivector_reference(&(regs[Iarg_z]), low, high, to, what); + copy_ivector_reference(&(regs[Iarg_y]), low, high, to, what); + copy_ivector_reference(&(regs[Iarg_x]), low, high, to, what); + copy_ivector_reference(&(regs[Isave3]), low, high, to, what); + copy_ivector_reference(&(regs[Isave2]), low, high, to, what); + copy_ivector_reference(&(regs[Isave1]), low, high, to, what); + copy_ivector_reference(&(regs[Isave0]), low, high, to, what); + copy_ivector_reference(&(regs[Ifn]), low, high, to, what); + copy_ivector_reference(&(regs[Itemp0]), low, high, to, what); + copy_ivector_reference(&(regs[Itemp1]), low, high, to, what); + copy_ivector_reference(&(regs[Itemp2]), low, high, to, what); +#if 0 + purify_locref(&(regs[Iip]), low, high, to, what); +#endif +#else +#endif +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + purify_range(start, end, low, high, to, what); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + purify_xp(xp, low, high, to, what); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + purify_xp(xframes->curr, low, high, to, what); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target, int what) +{ + 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, what); + break; + + case AREA_VSTACK: + purify_vstack_area(next_area, low, high, target, what); + break; + + case AREA_CSTACK: +#ifdef PPC + purify_cstack_area(next_area, low, high, target, what); +#endif + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what); + 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. + +*/ + + +int +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; + OSErr err; + BytePtr new_pure_start; + + + + max_pure_size = interned_pname_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<vcell, htab, obj; + package *p; + cons *c; + natural elements, i; + + while (fulltag_of(pkg_list) == fulltag_cons) { + c = (cons *) ptr_from_lispobj(untag(pkg_list)); + p = (package *) ptr_from_lispobj(untag(c->car)); + pkg_list = c->cdr; + c = (cons *) ptr_from_lispobj(untag(p->itab)); + htab = c->car; + elements = header_element_count(header_of(htab)); + for (i = 1; i<= elements; i++) { + obj = deref(htab,i); + if (fulltag_of(obj) == fulltag_symbol) { + rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); + copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); + } + } + c = (cons *) ptr_from_lispobj(untag(p->etab)); + htab = c->car; + elements = header_element_count(header_of(htab)); + for (i = 1; i<= elements; i++) { + obj = deref(htab,i); + if (fulltag_of(obj) == fulltag_symbol) { + rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); + copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); + } + } + } + } + + purify_areas(a->low, a->active, new_pure_area, FORWARD_ONLY); + + other_tcr = tcr; + do { + purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY); + purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, FORWARD_ONLY); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + { + 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_xp(ExceptionInformation *xp, LispObj low, LispObj high, int 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); + impurify_noderef(&(regs[Isave3]), low, high, delta); + 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, int delta) +{ + while (start < end) { + impurify_noderef(start, low, high, delta); + start++; + } +} + + +void +impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int 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) { + int skip = (int)(start[1]); + 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, 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; + + impurify_headerless_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; + } + } +} + +int +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; + 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((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); + lisp_global(IN_GC) = 0; + } + return 0; + } + return -1; +} Index: /branches/experimentation/later/source/lisp-kernel/x86-macros.s =================================================================== --- /branches/experimentation/later/source/lisp-kernel/x86-macros.s (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/x86-macros.s (revision 8058) @@ -0,0 +1,516 @@ +/* Copyright (C) 2005 Clozure Associates */ +/* This file is part of OpenMCL. */ + +/* OpenMCL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with OpenMCL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with OpenMCL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* OpenMCL 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],[ + imulq [$]fixnumone,$1,$2 +]) + + +/* box_fixnum, with no effect on flags */ +define([box_fixnum_no_flags],[ + leaq (,$1,8),$2 +]) + +define([save_node_regs],[ + push %arg_z + push %arg_y + push %arg_x + push %temp0 + push %temp1 + push %temp2 + push %save0 + push %save1 + push %save2 + push %save3 + push %ra0 + push %fn +]) + +/* This needs to be done before we transition back to the lisp stack */ +/* from the foreign stack. */ + +define([zero_node_regs],[ + xor %fn,%fn + mov %fn,%ra0 + mov %fn,%save3 + mov %fn,%save2 + mov %fn,%save1 + mov %fn,%save0 + mov %fn,%temp2 + mov %fn,%temp1 + mov %fn,%temp0 + mov %fn,%arg_x + mov %fn,%arg_y + mov %fn,arg_z +]) +define([restore_node_regs],[ + pop %fn + pop %ra0 + pop %save3 + pop %save2 + pop %save1 + pop %save0 + pop %temp2 + pop %temp1 + pop %temp0 + pop %arg_x + pop %arg_y + pop %arg_z +]) + +/* Zero $3 bytes worth of dnodes, starting at offset $2 relative */ +/* to the base register $1. */ + + +ifdef([DarwinAssembler],[ + .macro zero_dnodes + .if $2 + movapd %fpzero,$1($0) + zero_dnodes $0,$1+dnode_size,$2-dnode_size + .endif + .endmacro +],[ + .macro zero_dnodes base,disp,nbytes + .ifgt \nbytes + movapd %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. */ + +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 $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 */ + +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 $2,%rcontext:tcr.save_tsp + addq $dnode_size,$2 +]) + + + +define([Allocate_Catch_Frame],[ + TSP_Alloc_Fixed(catch_frame.size,$1) + movq [$](catch_frame.element_count< %arg_y %arg_z). */ +_spentry(builtin_gt) + __(movb %arg_z_b,%imm0_b) + __(orb %arg_y_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpq(%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) + __(movb %arg_z_b,%imm0_b) + __(orb %arg_y_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpq(%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) + __(movb %arg_z_b,%imm0_b) + __(orb %arg_y_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpq(%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) + __(movb %arg_z_b,%imm0_b) + __(orb %arg_y_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpq(%arg_y,%arg_z)) + __(condition_to_boolean(le,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_le,2)) +_endsubp(builtin_le) + +_spentry(builtin_eql) + __(cmpq %arg_y,%arg_z) + __(je 1f) + /* Not EQ. Could only possibly be EQL if both are tag-misc */ + /* and both have the same subtag */ + __(extract_lisptag(%arg_y,%imm0)) + __(extract_lisptag(%arg_z,%imm1)) + __(cmpb $tag_misc,%imm0_b) + __(jne 2f) + __(cmpb %imm0_b,%imm1_b) + __(jne 2f) + __(extract_subtag(%arg_y,%imm0_b)) + __(extract_subtag(%arg_z,%imm1_b)) + __(cmpb %imm0_b,%imm1_b) + __(jne 2f) + __(jump_builtin(_builtin_eql,2)) +1: __(movl $t_value,%arg_z_l) + __(ret) +2: __(movl $nil_value,%arg_z_l) + __(ret) +_endsubp(builtin_eql) + +_spentry(builtin_length) + __(extract_lisptag(%arg_z,%imm0)) + __(cmpb $tag_list,%imm0_b) + __(jz 2f) + __(cmpb $tag_misc,%imm0_b) + __(jnz 8f) + __(extract_subtag(%arg_z,%imm0_b)) + __(rcmpb(%imm0_b,$min_vector_subtag)) + __(jb 8f) + __(je 1f) + /* (simple-array * (*)) */ + __(movq %arg_z,%arg_y) + __(vector_length(%arg_y,%arg_z)) + __(ret) +1: /* vector header */ + __(movq vectorH.logsize(%arg_z),%arg_z) + __(ret) +2: /* list. Maybe null, maybe dotted or circular. */ + __(movq $-fixnumone,%imm2) + __(movq %arg_z,%temp0) /* fast pointer */ + __(movq %arg_z,%temp1) /* slow pointer */ +3: __(extract_lisptag(%temp0,%imm0)) + __(compare_reg_to_nil(%temp0)) + __(leaq fixnumone(%imm2),%imm2) + __(je 9f) + __(cmpb $tag_list,%imm0_b) + __(jne 8f) + __(extract_lisptag(%temp1,%imm1)) + __(testb $fixnumone,%imm2_b) + __(_cdr(%temp0,%temp0)) + __(je 3b) + __(cmpb $tag_list,%imm1_b) + __(jne 8f) + __(_cdr(%temp1,%temp1)) + __(cmpq %temp0,%temp1) + __(jne 3b) +8: + __(jump_builtin(_builtin_length,1)) +9: + __(movq %imm2,%arg_z) + __(ret) +_endsubp(builtin_length) + + +_spentry(builtin_seqtype) + __(extract_lisptag(%arg_z,%imm0)) + __(cmpb $tag_list,%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_l) + __(ret) +1: __(movl $t_value,%arg_z_l) + __(ret) +2: + __(jump_builtin(_builtin_seqtype,1)) +_endsubp(builtin_seqtype) + +_spentry(builtin_assq) + __(cmpb $fulltag_nil,%arg_z_b) + __(jz 5f) +1: __(movb $tagmask,%imm0_b) + __(andb %arg_z_b,%imm0_b) + __(cmpb $tag_list,%imm0_b) + __(jnz 2f) + __(_car(%arg_z,%arg_x)) + __(_cdr(%arg_z,%arg_z)) + __(cmpb $fulltag_nil,%arg_x_b) + __(jz 4f) + __(movb $tagmask,%imm0_b) + __(andb %arg_x_b,%imm0_b) + __(cmpb $tag_list,%imm0_b) + __(jnz 3f) + __(_car(%arg_x,%temp0)) + __(cmpq %temp0,%arg_y) + __(jnz 4f) + __(movq %arg_x,%arg_z) + __(ret) +4: __(cmpb $fulltag_nil,%arg_z_b) +5: __(jnz 1b) + __(repret) +2: __(uuo_error_reg_not_list(Rarg_z)) +3: __(uuo_error_reg_not_list(Rarg_x)) +_endsubp(builtin_assq) + +_spentry(builtin_memq) + __(cmpb $fulltag_nil,%arg_z_b) + __(jmp 3f) +1: __(movb $tagmask,%imm0_b) + __(andb %arg_z_b,%imm0_b) + __(cmpb $tag_list,%imm0_b) + __(jnz 2f) + __(_car(%arg_z,%arg_x)) + __(_cdr(%arg_z,%temp0)) + __(cmpq %arg_x,%arg_y) + __(jz 4f) + __(cmpb $fulltag_nil,%temp0_b) + __(movq %temp0,%arg_z) +3: __(jnz 1b) +4: __(repret) +2: __(uuo_error_reg_not_list(Rarg_z)) +_endsubp(builtin_memq) + + __ifdef([X8664]) +logbitp_max_bit = 61 + __else +logbitp_max_bit = 30 + __endif + +_spentry(builtin_logbitp) + __(movb %arg_z_b,%imm0_b) + __(orb %arg_y_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jnz 1f) + __(unbox_fixnum(%arg_y,%imm0)) + __(movl $logbitp_max_bit-1+fixnumshift,%imm1_l) + __(js 1f) /* bit number negative */ + __(addb $fixnumshift,%imm0_b) + __(cmpq $logbitp_max_bit< aligned on 16-byte boundary */ +/* *backlink <- foreign %rsp */ +/* unused */ +/* scalar arg 0 passed in %rdi */ +/* scalar arg 1 passed in %rsi */ +/* scalar arg 2 passed in %rdx */ +/* scalar arg 3 passed in %rcx */ +/* scalar arg 4 passed in %r8 */ +/* scalar arg 5 passed in %r9 */ +/* *address of first memory arg */ +/* ... */ +/* possible scratch space */ +/* *previous %rsp value */ + +/* Any floating-point args will have been loaded into %xmm0-%xmm7 by the caller. */ +/* When this returns, the foreign %rsp will contain its previous value, and */ +/* the function result will be in %rax (and possibly %rdx) or %xmm0 (+ %xmm1). */ + +_spentry(ffcall) +LocalLabelPrefix[]ffcall: + /* Unbox %arg_z. It's either a fixnum or macptr (or bignum) ; + if not a fixnum, get the first word */ + __(unbox_fixnum(%arg_z,%imm1)) + __(testb $fixnummask,%arg_z_b) + __(je 0f) + __(movq macptr.address(%arg_z),%imm1) +0: + /* Save lisp registers */ + __(push %rbp) + __(movq %rsp,%rbp) + __(push %temp0) + __(push %temp1) + __(push %temp2) + __(push %arg_x) + __(push %arg_y) + __(push %arg_z) + __(push %fn) + __(push %save0) + __(push %save1) + __(push %save2) + __(push %save3) /* 10 registers pushed after %rbp */ + __(movq %rsp,%rcontext:tcr.save_vsp) + __(movq %rbp,%rcontext:tcr.save_rbp) + __(movq $TCR_STATE_FOREIGN,%rcontext:tcr.valence) + __(movq %rcontext:tcr.foreign_sp,%rsp) + __(stmxcsr %rcontext:tcr.lisp_mxcsr) + __(emms) + __(ldmxcsr %rcontext:tcr.foreign_mxcsr) + __(movq (%rsp),%rbp) + __ifdef([DARWIN_GS_HACK]) + /* At this point, %imm1=%rdx is live (contains + the entrypoint) and %imm0.b=%al contains + info about xmm register arguments; the lisp registers are + all saved, and the foreign arguments are + on the foreign stack (about to be popped + off). Save the linear TCR address in %save0/%r15 + so that we can restore it later, and preserve + the entrypoint somewhere where C won't bash it. + Note that dereferencing the entrypoint from + foreign code has never been safe (unless it's + a fixnum */ + __(save_tcr_linear(%save0)) + __(movq %imm1,%save1) + __(movq %imm0,%save2) + __(set_foreign_gs_base()) + __(movq %save1,%imm1) + __(movq %save2,%imm0) + __endif +LocalLabelPrefix[]ffcall_setup: + __(addq $2*node_size,%rsp) + __(movq %imm1,%r11) + __(pop %rdi) + __(pop %rsi) + __(pop %rdx) + __(pop %rcx) + __(pop %r8) + __(pop %r9) +LocalLabelPrefix[]ffcall_setup_end: +LocalLabelPrefix[]ffcall_call: + __(call *%r11) +LocalLabelPrefix[]ffcall_call_end: + __(movq %rbp,%rsp) + __ifdef([DARWIN_GS_HACK]) + /* %rax/%rdx contains the return value (maybe), %save0 still + contains the linear tcr address. Preserve %rax/%rdx here. */ + __(movq %rax,%save1) + __(movq %rdx,%save2) + __(set_gs_base(%save0)) + __(movq %save1,%rax) + __(movq %save2,%rdx) + __endif + __(movq %rsp,%rcontext:tcr.foreign_sp) + __(clr %save3) + __(clr %save2) + __(clr %save1) + __(clr %save0) + __(clr %arg_z) + __(clr %arg_y) + __(clr %arg_x) + __(clr %temp2) + __(clr %temp1) + __(clr %temp0) + __(clr %fn) + __(pxor %fpzero,%fpzero) + /* Darwin's math library seems to be pretty casual + about causing spurious FP exceptions */ + __ifdef([DARWIN]) + __(movl %arg_x_l,%rcontext:tcr.ffi_exception) + __else + __(stmxcsr %rcontext:tcr.ffi_exception) + __endif + __(movq %rcontext:tcr.save_vsp,%rsp) + __(movq %rcontext:tcr.save_rbp,%rbp) + __(movq $TCR_STATE_LISP,%rcontext:tcr.valence) + __(pop %save3) + __(pop %save2) + __(pop %save1) + __(pop %save0) + __(pop %fn) + __(pop %arg_z) + __(pop %arg_y) + __(pop %arg_x) + __(pop %temp2) + __(pop %temp1) + __(ldmxcsr %rcontext:tcr.lisp_mxcsr) + __(check_pending_interrupt(%temp0)) + __(pop %temp0) + __(leave) + __ifdef([DARWIN]) + __(btrq $TCR_FLAG_BIT_FOREIGN_EXCEPTION,%rcontext:tcr.flags) + __(jc,pn 0f) + __endif + __(ret) + __ifdef([DARWIN]) +0: + /* Unboxed foreign exception (likely an NSException) in %imm0. */ + /* Box it, then signal a lisp error. */ + __(movq %imm0,%imm2) + __(movq $macptr_header,%rax) + __(Misc_Alloc_Fixed(%arg_z,macptr.size)) + __(movq %imm2,macptr.address(%arg_z)) + __(movq $XFOREIGNEXCEPTION,%arg_y) + __(set_nargs(2)) + __(jmp _SPksignalerr) + __endif + __ifdef([DARWIN]) + /* Handle exceptions, for ObjC 2.0 */ +LocalLabelPrefix[]ffcallLandingPad: + __(movq %rax,%save1) + __(cmpq $1,%rdx) + __(je 1f) + __(movq %rax,%rdi) +LocalLabelPrefix[]ffcallUnwindResume: + __(call *lisp_global(unwind_resume)) +LocalLabelPrefix[]ffcallUnwindResume_end: +1: __(movq %save1,%rdi) +LocalLabelPrefix[]ffcallBeginCatch: + __(call *lisp_global(objc2_begin_catch)) +LocalLabelPrefix[]ffcallBeginCatch_end: + __(movq (%rax),%save1) /* indirection is necessary because we don't provide type info in lsda */ +LocalLabelPrefix[]ffcallEndCatch: + __(call *lisp_global(objc2_end_catch)) +LocalLabelPrefix[]ffcallEndCatch_end: + __(ref_global(get_tcr,%rax)) + __(movq $1,%rdi) + __(call *%rax) + __(btsq $TCR_FLAG_BIT_FOREIGN_EXCEPTION,tcr.flags(%rax)) + __(movq %save1,%rax) + __(jmp LocalLabelPrefix[]ffcall_call_end) +LocalLabelPrefix[]ffcall_end: + __endif +_endsubp(ffcall) + + __ifdef([DARWIN]) + .section __DATA,__gcc_except_tab +GCC_except_table0: + .align 3 +LLSDA1: + .byte 0xff /* @LPStart format (omit) */ + .byte 0x0 /* @TType format (absolute) */ + .byte 0x4d /* uleb128 0x4d; @TType base offset */ + .byte 0x3 /* call-site format (udata4) */ + .byte 0x41 /* uleb128 0x41; Call-site table length */ + + .long Lffcall_setup-Lffcall /* region 0 start */ + .long Lffcall_setup_end-Lffcall_setup /* length */ + .long 0x0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + + .long Lffcall_call-Lffcall /* region 1 start */ + .long Lffcall_call_end-Lffcall_call /* length */ + .long LffcallLandingPad-Lffcall /* landing pad */ + .byte 0x1 /* uleb128 0x1; action */ + + .long LffcallUnwindResume-Lffcall /* region 2 start */ + .long LffcallUnwindResume_end-LffcallUnwindResume /* length */ + .long 0x0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + + .long LffcallBeginCatch-Lffcall /* region 3 start */ + .long LffcallBeginCatch_end-LffcallBeginCatch /* length */ + .long 0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + + .long LffcallEndCatch-Lffcall + .long LffcallEndCatch_end-LffcallEndCatch /* length */ + .long 0x0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + .byte 0x1 /* Action record table */ + .byte 0x0 + .align 3 + .quad 0 /* _OBJC_EHTYPE_$_NSException */ + .text + __endif + +_spentry(ffcall_return_registers) +LocalLabelPrefix[]ffcall_return_registers: + /* Unbox %arg_z. It's either a fixnum or macptr (or bignum) ; + if not a fixnum, get the first word */ + __(unbox_fixnum(%arg_z,%imm1)) + __(testb $fixnummask,%arg_z_b) + __(je 0f) + __(movq macptr.address(%arg_z),%imm1) +0: + /* Save lisp registers */ + __(push %rbp) + __(movq %rsp,%rbp) + __(push %temp0) + __(push %temp1) + __(push %temp2) + __(push %arg_x) + __(push %arg_y) + __(push %arg_z) + __(push %save0) + __(push %save1) + __(push %save2) + __(push %save3) + __(movq macptr.address(%arg_y),%rbx) /* %rbx non-volatile */ + __(push %fn) + __(movq %rsp,%rcontext:tcr.save_vsp) + __(movq %rbp,%rcontext:tcr.save_rbp) + __(movq $TCR_STATE_FOREIGN,%rcontext:tcr.valence) + __(movq %rcontext:tcr.foreign_sp,%rsp) + __(stmxcsr %rcontext:tcr.lisp_mxcsr) + __(emms) + __(ldmxcsr %rcontext:tcr.foreign_mxcsr) + __(movq (%rsp),%rbp) + __ifdef([DARWIN_GS_HACK]) + /* At this point, %imm1=%rdx is live (contains + the entrypoint) and %imm0.b=%al contains + xmm argument info; the lisp registers are + all saved, and the foreign arguments are + on the foreign stack (about to be popped + off). Save the linear TCR address in %save0/%r15 + so that we can restore it later, and preserve + the entrypoint somewhere where C won't bash it. + Note that dereferencing the entrypoint from + foreign code has never been safe (unless it's + a fixnum */ + __(save_tcr_linear(%save0)) + __(movq %imm0,%save1) + __(movq %imm1,%save2) + __(set_foreign_gs_base()) + __(movq %save1,%imm0) + __(movq %save2,%imm1) + __endif + __(movq %imm1,%r11) +LocalLabelPrefix[]ffcall_return_registers_setup: + __(addq $2*node_size,%rsp) + __(pop %rdi) + __(pop %rsi) + __(pop %rdx) + __(pop %rcx) + __(pop %r8) + __(pop %r9) +LocalLabelPrefix[]ffcall_return_registers_setup_end: +LocalLabelPrefix[]ffcall_return_registers_call: + __(call *%r11) +LocalLabelPrefix[]ffcall_return_registers_call_end: + __(movq %rax,(%rbx)) + __(movq %rdx,8(%rbx)) + __(movsd %xmm0,16(%rbx)) + __(movsd %xmm1,24(%rbx)) + __(movq %rbp,%rsp) + __ifdef([DARWIN_GS_HACK]) + /* %rax/%rdx contains the return value (maybe), %save0 still + contains the linear tcr address. Preserve %rax/%rdx here. */ + __(set_gs_base(%save0)) + __(movq (%save2),%rax) + __(movq 8(%save2),%rdx) + __(movsd 16(%save2),%xmm0) + __(movsd 24(%save2),%xmm1) + __endif + __(movq %rsp,%rcontext:tcr.foreign_sp) + __(clr %save3) + __(clr %save2) + __(clr %save1) + __(clr %save0) + __(clr %arg_z) + __(clr %arg_y) + __(clr %arg_x) + __(clr %temp2) + __(clr %temp1) + __(clr %temp0) + __(clr %fn) + __(pxor %fpzero,%fpzero) + /* Darwin's math library seems to be pretty casual + about causing spurious FP exceptions */ + __ifdef([DARWIN]) + __(movl %arg_x_l,%rcontext:tcr.ffi_exception) + __else + __(stmxcsr %rcontext:tcr.ffi_exception) + __endif + __(movq %rcontext:tcr.save_vsp,%rsp) + __(movq %rcontext:tcr.save_rbp,%rbp) + __(movq $TCR_STATE_LISP,%rcontext:tcr.valence) + __(pop %fn) + __(pop %save3) + __(pop %save2) + __(pop %save1) + __(pop %save0) + __(pop %arg_z) + __(pop %arg_y) + __(pop %arg_x) + __(pop %temp2) + __(pop %temp1) + __(ldmxcsr %rcontext:tcr.lisp_mxcsr) + __(check_pending_interrupt(%temp0)) + __(pop %temp0) + __(leave) + __ifdef([DARWIN]) + __(btrq $TCR_FLAG_BIT_FOREIGN_EXCEPTION,%rcontext:tcr.flags) + __(jc,pn 0f) + __endif + __(ret) + __ifdef([DARWIN]) +0: + /* Unboxed foreign exception (likely an NSException) in %imm0. */ + /* Box it, then signal a lisp error. */ + __(movq %imm0,%imm2) + __(movq $macptr_header,%rax) + __(Misc_Alloc_Fixed(%arg_z,macptr.size)) + __(movq %imm2,macptr.address(%arg_z)) + __(movq $XFOREIGNEXCEPTION,%arg_y) + __(set_nargs(2)) + __(jmp _SPksignalerr) + __endif + __ifdef([DARWIN]) + /* Handle exceptions, for ObjC 2.0 */ +LocalLabelPrefix[]ffcall_return_registersLandingPad: + __(movq %rax,%save1) + __(cmpq $1,%rdx) + __(je 1f) + __(movq %rax,%rdi) +LocalLabelPrefix[]ffcall_return_registersUnwindResume: + __(call *lisp_global(unwind_resume)) +LocalLabelPrefix[]ffcall_return_registersUnwindResume_end: +1: __(movq %save1,%rdi) +LocalLabelPrefix[]ffcall_return_registersBeginCatch: + __(call *lisp_global(objc2_begin_catch)) +LocalLabelPrefix[]ffcall_return_registersBeginCatch_end: + __(movq (%rax),%save1) /* indirection is necessary because we don't provide type info in lsda */ +LocalLabelPrefix[]ffcall_return_registersEndCatch: + __(call *lisp_global(objc2_end_catch)) +LocalLabelPrefix[]ffcall_return_registersEndCatch_end: + __(ref_global(get_tcr,%rax)) + __(movq $1,%rdi) + __(call *%rax) + __(btsq $TCR_FLAG_BIT_FOREIGN_EXCEPTION,tcr.flags(%rax)) + __(movq %save1,%rax) + __(jmp LocalLabelPrefix[]ffcall_return_registers_call_end) +LocalLabelPrefix[]ffcall_return_registers_end: + __endif +_endsubp(ffcall_returning_registers) + + __ifdef([DARWIN]) + .section __DATA,__gcc_except_tab +GCC_except_table1: + .align 3 +LLSDA2: + .byte 0xff /* @LPStart format (omit) */ + .byte 0x0 /* @TType format (absolute) */ + .byte 0x4d /* uleb128 0x4d; @TType base offset */ + .byte 0x3 /* call-site format (udata4) */ + .byte 0x41 /* uleb128 0x41; Call-site table length */ + + .long Lffcall_return_registers_setup-Lffcall_return_registers /* region 0 start */ + .long Lffcall_return_registers_setup_end-Lffcall_return_registers_setup /* length */ + .long 0x0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + + .long Lffcall_return_registers_call-Lffcall_return_registers /* region 1 start */ + .long Lffcall_return_registers_call_end-Lffcall_return_registers_call /* length */ + .long Lffcall_return_registersLandingPad-Lffcall_return_registers /* landing pad */ + .byte 0x1 /* uleb128 0x1; action */ + + .long Lffcall_return_registersUnwindResume-Lffcall_return_registers /* region 2 start */ + .long Lffcall_return_registersUnwindResume_end-Lffcall_return_registersUnwindResume /* length */ + .long 0x0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + + .long Lffcall_return_registersBeginCatch-Lffcall_return_registers /* region 3 start */ + .long Lffcall_return_registersBeginCatch_end-Lffcall_return_registersBeginCatch /* length */ + .long 0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + + .long Lffcall_return_registersEndCatch-Lffcall_return_registers + .long Lffcall_return_registersEndCatch_end-Lffcall_return_registersEndCatch /* length */ + .long 0x0 /* landing pad */ + .byte 0x0 /* uleb128 0x0; action */ + .byte 0x1 /* Action record table */ + .byte 0x0 + .align 3 + .quad 0 /* _OBJC_EHTYPE_$_NSException */ + .text + __endif + +_spentry(syscall) + /* Save lisp registers */ + __(push %rbp) + __(movq %rsp,%rbp) + __(push %temp0) + __(push %temp1) + __(push %temp2) + __(push %arg_x) + __(push %arg_y) + __(push %arg_z) + __(push %save0) + __(push %save1) + __(push %save2) + __(push %save3) + __(push %fn) + __(movq %rsp,%rcontext:tcr.save_vsp) + __(movq %rbp,%rcontext:tcr.save_rbp) + __(movq $TCR_STATE_FOREIGN,%rcontext:tcr.valence) + __(movq %rcontext:tcr.foreign_sp,%rsp) + __(emms) + __(movq (%rsp),%rbp) + __(addq $2*node_size,%rsp) + __(unbox_fixnum(%arg_z,%rax)) + __(pop %rdi) + __(pop %rsi) + __(pop %rdx) + __(pop %r10) /* syscalls take 4th param in %r10, not %rcx */ + __(pop %r8) + __(pop %r9) + __(syscall) + __ifdef([SYSCALL_SETS_CARRY_ON_ERROR]) + __(jnc 0f) + __(negq %rax) +0: + __endif + __(movq %rbp,%rsp) + __(movq %rsp,%rcontext:tcr.foreign_sp) + __(clr %save3) + __(clr %save2) + __(clr %save1) + __(clr %save0) + __(clr %arg_z) + __(clr %arg_y) + __(clr %arg_x) + __(clr %temp2) + __(clr %temp1) + __(clr %temp0) + __(clr %fn) + __(pxor %fpzero,%fpzero) + __(movq %rcontext:tcr.save_vsp,%rsp) + __(movq %rcontext:tcr.save_rbp,%rbp) + __(movq $TCR_STATE_LISP,%rcontext:tcr.valence) + __(pop %fn) + __(pop %save3) + __(pop %save2) + __(pop %save1) + __(pop %save0) + __(pop %arg_z) + __(pop %arg_y) + __(pop %arg_x) + __(pop %temp2) + __(pop %temp1) + __(check_pending_interrupt(%temp0)) + __(pop %temp0) + __(leave) + __(ret) +_endsubp(syscall) + +/* We need to reserve a frame here if (a) nothing else was already pushed and (b) */ +/* we push something (e.g., more than 3 args in the lexpr) */ +_spentry(spread_lexprz) + new_local_labels() + __(movq (%arg_z),%imm0) + __(testw %nargs,%nargs) /* anything pushed by caller ? */ + __(leaq node_size(%arg_z,%imm0),%imm1) + __(jne 0f) /* yes, caller has already created frame. */ + __(cmpw $(nargregs*node_size),%imm0_w) /* will we push anything ? */ + __(jbe 0f) + __(push $reserved_frame_marker) + __(push $reserved_frame_marker) +0: __(addw %imm0_w,%nargs) + __(cmpw $(nargregs*node_size),%imm0_w) + __(jae 9f) + __(cmpw $(2*node_size),%imm0_w) + __(je 2f) + __(testw %imm0_w,%imm0_w) + __(jne 1f) + /* lexpr count was 0; vpop the args that */ + /* were pushed by the caller */ + __(testw %nargs,%nargs) + __(je local_label(all_args_popped)) + __(pop %arg_z) +local_label(maybe_pop_yx): + __(cmpw $(1*node_size),%nargs) + __(je local_label(all_args_popped)) + __(pop %arg_y) + __(cmp $(2*node_size),%nargs) + __(je local_label(all_args_popped)) +local_label(pop_arg_x): + __(pop %arg_x) +local_label(all_args_popped): + /* If all args fit in registers but some were pushed */ + /* by the caller, discard the reserved frame that the caller */ + /* pushed. */ + __(cmpw %imm0_w,%nargs) + __(je local_label(go)) + __(cmpw $(nargregs*node_size),%nargs) + __(ja local_label(go)) + __(addq $(2*node_size),%rsp) +local_label(go): + __(jmp *%ra0) + /* vpush args from the lexpr until we have only */ + /* three left, then assign them to arg_x, arg_y, */ + /* and arg_z. */ +8: __(cmpw $(4*node_size),%imm0_w) + __(lea -1*node_size(%imm0),%imm0) + __(push -node_size(%imm1)) + __(lea -1*node_size(%imm1),%imm1) +9: __(jne 8b) + __(movq -node_size*1(%imm1),%arg_x) + __(movq -node_size*2(%imm1),%arg_y) + __(movq -node_size*3(%imm1),%arg_z) + __(jmp *%ra0) + + /* lexpr count is two: set arg_y, arg_z from the */ + /* lexpr, maybe vpop arg_x */ +2: __(cmpw $(2*node_size),%nargs) + __(movq -node_size*1(%imm1),%arg_y) + __(movq -node_size*2(%imm1),%arg_z) + __(jne local_label(pop_arg_x)) + __(jmp *%ra0) + /* lexpr count is one: set arg_z from the lexpr, */ + /* maybe vpop arg_y, arg_x */ +1: __(movq -node_size*1(%imm1),%arg_z) + __(jmp local_label(maybe_pop_yx)) +_endsubp(spread_lexprz) + + + + +/* Callback index in %r11 */ +_spentry(callback) + __(push %rbp) + __(movq %rsp,%rbp) + /* C scalar args */ + __(push %rdi) /* -8(%rbp) */ + __(push %rsi) + __(push %rdx) + __(push %rcx) + __(push %r8) + __(push %r9) + /* FP arg regs */ + __(subq $8*8,%rsp) + __(movq %xmm0,7*8(%rsp)) /* -56(%rbp) */ + __(movq %xmm1,6*8(%rsp)) + __(movq %xmm2,5*8(%rsp)) + __(movq %xmm3,4*8(%rsp)) + __(movq %xmm4,3*8(%rsp)) + __(movq %xmm5,2*8(%rsp)) + __(movq %xmm6,1*8(%rsp)) + __(movq %xmm7,0*8(%rsp)) + /* C NVRs */ + __(push %r12) + __(push %r13) + __(push %r14) + __(push %r15) + __(push %rbx) + __(push %rbp) + __ifdef([HAVE_TLS]) + /* TCR initialized for lisp ? */ + __(movq %fs:current_tcr@TPOFF+tcr.linear,%rax) + __(testq %rax,%rax) + __(jne 1f) + __endif + __(movq %r11,%r12) + __(ref_global(get_tcr,%rax)) + __(movq $1,%rdi) + __(call *%rax) + __ifdef([DARWIN_GS_HACK]) + /* linear TCR address in now in %rax; callback index was + saved in %r12 a moment ago. */ + __(set_gs_base(%rax)) + __endif + __(movq %r12,%r11) +1: /* Align foreign stack for lisp */ + __(subq $node_size,%rsp) + __(pushq %rcontext:tcr.foreign_sp) + /* init lisp registers */ + __(movq %r11,%rax) + __(movq %rsp,%rcontext:tcr.foreign_sp) + __(clr %save3) + __(clr %save2) + __(clr %save1) + __(clr %save0) + __(clr %arg_z) + __(clr %arg_y) + __(clr %arg_x) + __(clr %temp2) + __(clr %temp1) + __(clr %temp0) + __(clr %fn) + __(pxor %fpzero,%fpzero) + __(movq %rcontext:tcr.save_vsp,%rsp) + __(box_fixnum(%rax,%arg_y)) + __(movq %rbp,%arg_z) + __(movq %rcontext:tcr.save_rbp,%rbp) + __(movq $TCR_STATE_LISP,%rcontext:tcr.valence) + __(movq (%rsp),%save3) + __(movq 8(%rsp),%save2) + __(movq 16(%rsp),%save1) + __(movq 24(%rsp),%save0) + __(stmxcsr %rcontext:tcr.foreign_mxcsr) + __(andb $~mxcsr_all_exceptions,%rcontext:tcr.foreign_mxcsr) + __(ldmxcsr %rcontext:tcr.lisp_mxcsr) + __(movq $nrs.callbacks,%fname) + __(lea local_label(back_from_callback)(%rip),%ra0) + __(set_nargs(2)) + __(push %ra0) + __(jump_fname()) +__(tra(local_label(back_from_callback))) + __(movq %rsp,%rcontext:tcr.save_vsp) + __(movq %rbp,%rcontext:tcr.save_rbp) + __(movq %rcontext:tcr.foreign_sp,%rsp) + __(stmxcsr %rcontext:tcr.lisp_mxcsr) + __(movq $TCR_STATE_FOREIGN,%rcontext:tcr.valence) + __(emms) + __(pop %rcontext:tcr.foreign_sp) + __(addq $node_size,%rsp) + __(ldmxcsr %rcontext:tcr.foreign_mxcsr) + __ifdef([DARWIN_GS_HACK]) + /* Lucky us; nothing is live here */ + __(set_foreign_gs_base()) + __endif + __(pop %rbp) + __(pop %rbx) + __(pop %r15) + __(pop %r14) + __(pop %r13) + __(pop %r12) + __(movq -8(%rbp),%rax) + __(movq -16(%rbp),%rdx) + __(movq -24(%rbp),%xmm0) + __(movq -32(%rbp),%xmm1) + __(leave) + __(ret) +_endsubp(callback) + +/* arg_x = array, arg_y = i, arg_z = j. Typecheck everything. + We don't know whether the array is alleged to be simple or + not, and don't know anythng about the element type. */ + +_spentry(aref2) + __(testb $fixnummask,%arg_y_b) + __(jne 0f) + + __(testb $fixnummask,%arg_z_b) + __(jne 1f) + __(extract_typecode(%arg_x,%imm0)) + __(cmpb $subtag_arrayH,%imm0_b) + __(jne 2f) + __(cmpq $2< 1 (and we know that it was < 3), it must have */ + /* been 2. Set arg_x, then vpush the remaining args. */ + __(cmpw $fixnumone,%nargs) + __(jle local_label(set_y_z)) +local_label(set_arg_x): + __(subq $node_size,%temp1) + __(movq misc_data_offset(%fn,%temp1),%arg_x) + __(addw $fixnumone,%nargs) + __(subq $fixnumone,%imm0) + __(jne local_label(vpush_remaining)) + __(jmp local_label(go)) + /* Maybe set arg_y or arg_z, preceding args */ +local_label(set_y_z): + __(jne local_label(set_arg_z)) + /* Set arg_y, maybe arg_x, preceding args */ +local_label(set_arg_y): + __(subq $node_size,%temp1) + __(movq misc_data_offset(%fn,%temp1),%arg_y) + __(addw $fixnumone,%nargs) + __(subq $fixnum_one,%imm0) + __(jnz local_label(set_arg_x)) + __(jmp local_label(go)) +local_label(set_arg_z): + __(subq $node_size,%temp1) + __(movq misc_data_offset(%fn,%temp1),%arg_z) + __(addw $fixnumone,%nargs) + __(subq $fixnum_one,%imm0) + __(jne local_label(set_arg_y)) +local_label(go): + __(movq misc_data_offset+(4*node_size)(%fn),%fn) + __(push %ra0) + __(jmp *%fn) +local_label(regs_only): + __(leaq 5< +#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], *digits = "0123456789ABCDEF"; + + +void +sprint_unsigned_decimal_aux(natural n, Boolean first) +{ + if (n == 0) { + if (first) { + add_char('0'); + } + } else { + sprint_unsigned_decimal_aux(n/10, false); + add_char(digits[n%10]); + } +} + +void +sprint_unsigned_decimal(natural n) +{ + sprint_unsigned_decimal_aux(n, true); +} + +void +sprint_signed_decimal(signed_natural n) +{ + if (n < 0) { + add_char('-'); + n = -n; + } + sprint_unsigned_decimal(n); +} + + +void +sprint_unsigned_hex(natural n) +{ + int i, + ndigits = +#if WORD_SIZE == 64 + 16 +#else + 8 +#endif + ; + + add_c_string("#x"); + for (i = 0; i < ndigits; i++) { + add_char(digits[(n>>(4*(ndigits-(i+1))))&15]); + } +} + +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 X8664 + 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_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 = "); + add_char(digits[subtag>>4]); + add_char(digits[subtag&15]); + add_c_string(" @"); + 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, + pname_header = header_of(pname); + + 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_tra(LispObj o, int depth) +{ + signed sdisp; + unsigned disp; + LispObj f = 0; + + if ((*((unsigned short *)o) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(o+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + sdisp = (*(int *) (o+3)); + f = RECOVER_FN_FROM_RIP_LENGTH+o+sdisp; + disp = o-f; + } + + if (fulltag_of(f) == fulltag_function) { + add_c_string("tagged return address: "); + sprint_function(f, depth); + add_c_string(" + "); + sprint_unsigned_decimal(disp); + } else { + add_c_string("(tra ?) : "); + sprint_unsigned_hex(o); + } +} + +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; + } + + case subtag_instance: + { + LispObj class_or_hash = deref(o,1); + + if (tag_of(class_or_hash) == tag_fixnum) { + sprint_random_vector(o, subtag, elements); + } else { + add_c_string("#"); + } + 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 X8664 + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: +#else +#endif + add_c_string("#
"); + break; + +#ifdef X8664 + case fulltag_imm_0: + case fulltag_imm_1: +#else +#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 X8664 + } else if (header_subtag(o) == subtag_single_float) { + LispObj xx = o; + float f = ((float *)&xx)[1]; + sprintf(numbuf, "%f", f); + add_c_string(numbuf); +#endif + } else { + + add_c_string("#"); + } + } + break; + + case fulltag_nil: + case fulltag_cons: + sprint_list(o, depth); + break; + + case fulltag_misc: + sprint_vector(o, depth); + break; + + case fulltag_symbol: + sprint_symbol(o); + break; + + case fulltag_function: + sprint_function(o, depth); + break; + + case fulltag_tra_0: + case fulltag_tra_1: + sprint_tra(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/experimentation/later/source/lisp-kernel/xlbt.c =================================================================== --- /branches/experimentation/later/source/lisp-kernel/xlbt.c (revision 8058) +++ /branches/experimentation/later/source/lisp-kernel/xlbt.c (revision 8058) @@ -0,0 +1,158 @@ +/* + Copyright (C) 2005 Clozure Associates + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" +#include + +const char * +foreign_name_and_offset(void *frame, unsigned *delta) +{ +} + + +void +print_lisp_frame(lisp_frame *frame) +{ + LispObj pc = frame->tra, fun=0; + int delta = 0; + + if (pc == lisp_global(RET1VALN)) { + pc = frame->xtra; + } + if (tag_of(pc) == tag_tra) { + if ((*((unsigned short *)pc) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(pc+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (pc+3)); + fun = RECOVER_FN_FROM_RIP_LENGTH+pc+sdisp; + } + if (fulltag_of(fun) == fulltag_function) { + delta = pc - fun; + Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta); + return; + } + } + if (pc == 0) { + fun = ((xcf *)frame)->nominal_function; + Dprintf("(#x%016lX) #x%016lX : %s + ??", frame, pc, print_lisp_object(fun)); + return; + } +} + +Boolean +lisp_frame_p(lisp_frame *f) +{ + LispObj fun, ra; + unsigned offset; + int sdisp; + + if (f) { + ra = f->tra; + if (ra == lisp_global(RET1VALN)) { + ra = f->xtra; + } + + if (tag_of(ra) == tag_tra) { +#if 0 + if ((*((unsigned short *)ra) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(ra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + sdisp = (*(int *) (ra+3)); + fun = RECOVER_FN_FROM_RIP_LENGTH+ra+sdisp; + } + if (fulltag_of(fun) == fulltag_function) { + return true; + } +#endif + return true; + } else if ((ra == lisp_global(LEXPR_RETURN)) || + (ra == lisp_global(LEXPR_RETURN1V))) { + return true; + } else if (ra == 0) { + return true; + } + } + return false; +} + +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 { + if (start->backlink) { + fprintf(stderr, "Bogus frame %lx\n", start); + } + return; + } + + next = start->backlink; + if (next == 0) { + next = end; + } + if (next < start) { + fprintf(stderr, "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 +plbt_sp(LispObj currentRBP) +{ + area *vs_area, *cs_area; + +{ + TCR *tcr = (TCR *)get_tcr(true); + char *ilevel = interrupt_level_description(tcr); + vs_area = tcr->vs_area; + cs_area = tcr->cs_area; + if ((((LispObj) ptr_to_lispobj(vs_area->low)) > currentRBP) || + (((LispObj) ptr_to_lispobj(vs_area->high)) < currentRBP)) { + Dprintf("\nFramepointer [#x%lX] in unknown area.", currentRBP); + } else { + fprintf(stderr, "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(currentRBP), (lisp_frame *) (vs_area->high)); + /* walk_other_areas();*/ + } + } +} + + +void +plbt(ExceptionInformation *xp) +{ + plbt_sp(xpGPR(xp,Irbp)); +} Index: /branches/experimentation/later/source/objc-bridge/CocoaBridgeDoc.txt =================================================================== --- /branches/experimentation/later/source/objc-bridge/CocoaBridgeDoc.txt (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/CocoaBridgeDoc.txt (revision 8058) @@ -0,0 +1,289 @@ +A Cocoa Bridge for OpenMCL + +Randall D. Beer +beer@eecs.cwru.edu +http://vorlon.cwru.edu/~beer + + +INTRODUCTION + +The purpose of CocoaBridge is to make Cocoa as easy as possible to use +from OpenMCL, in order to support GUI application and development +environment activities. It builds on the capabilities provided in the +APPLE-OBJC example. The eventual goal is complete integration of +Cocoa into CLOS. The current release provides Lisp-like syntax and +naming conventions for ObjC object creation and message sending, with +automatic type processing and compile-time checking of message +sends. It also provides some convenience facilities for working with +Cocoa. + +A small sample Cocoa program can be invoked by evaluating (REQUIRE +'TINY) and then (CCL::TINY-SETUP). This program provides a simple example +of using several of the bridge's capabilities + + +BASICS + +The main things you need to know are: + +1) You create and initialize ObjC objects using +MAKE-OBJC-INSTANCE. This should be replaced by MAKE-INSTANCE as CLOS +integration improves + +Example: +[[NSNumber alloc] initWithFloat: 2.7] in ObjC becomes +(MAKE-OBJC-INSTANCE 'NS-NUMBER :INIT-WITH-FLOAT 2.7) in Lisp + +Note that class names and init keywords are translated from ObjC to Lisp in +pretty much the obvious way + +2) You send messages to ObjC objects using SEND + +Examples: +[w alphaValue] becomes (SEND W 'ALPHA-VALUE) +[w setAlphaValue: 0.5] becomes (SEND W :SET-ALPHA-VALUE 0.5) +[v mouse: p inRect: r] becomes (SEND V :MOUSE P :IN-RECT R) + +Note that message keywords are translated to Lisp in pretty much the obvious +way. From within a method, you can also use SEND-SUPER. + + +3) The @CLASS macro from APPLE-OBJC is currently used to refer to named ObjC +classes, which can also be sent messages via SEND. This should be replaced by +FIND-CLASS as CLOS integration improves. + +Example: +[NSColor whiteColor] becomes (SEND (@CLASS NS-COLOR) 'WHITE-COLOR) + + +4) New ObjC classes and methods are currently defined using DEF-OBJC-CLASS and +DEFINE-OBJC-METHOD from APPLE-OBJC. This should be replaced by DEFCLASS and +DEFMETHOD as CLOS integration improves. + + +NAME TRANSLATION + +There are a standard set of naming conventions for Cocoa classes, + messages, etc. As long as these are followed, the bridge is fairly + good at automaticallly translating between ObjC and Lisp names. + +Examples: +"NSURLHandleClient" <==> NS-URL-HANDLE-CLIENT +"NSOpenGLView" <==> NS-OPENGL-VIEW +"nextEventMatchingMask:untilDate:inMode:dequeue:" <==> +(:NEXT-EVENT-MATCHING-MASK :UNTIL-DATE :IN-MODE :DEQUEUE) + +To see how a given ObjC or Lisp name will be translated by the bridge, you can +use the following functions: + +OBJC-TO-LISP-CLASSNAME string +LISP-TO-OBJC-CLASSNAME symbol +OBJC-TO-LISP-MESSAGE string +LISP-TO-OBJC-MESSAGE keyword-list +OBJC-TO-LISP-INIT string +LISP-TO-OBJC-INIT keyword-list + +Of course, there will always be exceptions to any naming convention. +Please let me know if you come across any name translation problems +that seem to be bugs. Otherwise, the bridge provides two ways of +dealing with exceptions: + +1) You can pass a string as the class name of MAKE-OBJC-INSTANCE and +as the message to SEND. These strings will be directly interpreted as +ObjC names, with no translation. This is useful for a one-time +exception. + +Examples: +(MAKE-OBJC-INSTANCE "WiErDclass") +(SEND o "WiErDmEsSaGe:WithARG:" x y) + +2) You can define a special translation rule for your exception. This is useful +for an exceptional name that you need to use throughout your code. + +Examples: +(DEFINE-CLASSNAME-TRANSLATION "WiErDclass" WEIRD-CLASS) +(DEFINE-MESSAGE-TRANSLATION "WiErDmEsSaGe:WithARG:" (:WEIRD-MESSAGE :WITH-ARG)) +(DEFINE-INIT-TRANSLATION "WiErDiNiT:WITHOPTION:" (:WEIRD-INIT :OPTION) + +The normal rule in ObjC names is that each word begins with a capital letter +(except possibly the first). Using this rule literally, "NSWindow" would be +translated as N-S-WINDOW, which seems wrong. "NS" is a special word in ObjC +that should not be broken at each capital letter. Likewise "URL", "PDF", +"OpenGL", etc. Most common special words used in Cocoa are already defined in +the bridge, but you can define new ones as follows: (DEFINE-SPECIAL-OBJC-WORD +"QuickDraw") + +Note that message keywords in a SEND such as (SEND V :MOUSE P :IN-RECT R) may +look like Lisp keyword args, but they really aren't. All keywords must be +present and the order is significant. Neither (:IN-RECT :MOUSE) nor (:MOUSE) +translate to "mouse:inRect:" + +Note that an "init" prefix is optional in the initializer keywords, so +(MAKE-OBJC-INSTANCE 'NS-NUMBER :INIT-WITH-FLOAT 2.7) can also be expressed as +(MAKE-OBJC-INSTANCE 'NS-NUMBER :WITH-FLOAT 2.7) + + +STRETS + +Some Cocoa methods return small structures (such as those used to represent +points, rects, sizes and ranges). Although this is normally hidden by the ObjC +compiler, such messages are sent in a special way, with the storage for the +STructure RETurn (STRET) passed as an extra argument. This STRET and special +SEND must normally be made explicit in Lisp. Thus + +NSRect r = [v1 bounds]; +[v2 setBounds r]; + +in ObjC becomes + +(RLET ((R :ect)) + (SEND/STRET R V1 'BOUNDS) + (SEND V2 :SET-BOUNDS R)) + +In order to make STRETs easier to use, the bridge provides two conveniences: + +1) The SLET and SLET* macros may be used to define local variables that are +initialized to STRETs using a normal SEND syntax. Thus, the following is +equivalent to the above RLET: + +(SLET ((R (SEND V 'BOUNDS))) + (SEND V2 :SET-BOUNDS R)) + +2) The arguments to a SEND are evaluated inside an implicit SLET, so instead of +the above, one could in fact just write: + +(SEND V1 :SET-BOUNDS (SEND V2 'BOUNDS)) + +There are also several psuedo-functions provided for convenience by the ObjC +compiler. The following are currently supported by the bridge: NS-MAKE-POINT, +NS-MAKE-RANGE, NS-MAKE-RECT, and NS-MAKE-SIZE. These can be used within a SLET +initform or within a message send: + +(SLET ((P (NS-MAKE-POINT 100.0 200.0))) + (SEND W :SET-FRAME-ORIGIN P)) + +or + +(SEND W :SET-ORIGIN (NS-MAKE-POINT 100.0 200.0)) + +However, since these aren't real functions, a call like the following won't +work: + +(SETQ P (NS-MAKE-POINT 100.0 200.0)) + +The following convenience macros are also provided: NS-MAX-RANGE, NS-MIN-X, +NS-MIN-Y, NS-MAX-X, NS-MAX-Y, NS-MID-X, NS-MID-Y, NS-HEIGHT, and NS-WIDTH. + +Note that there is also a SEND-SUPER/STRET for use within methods. + + +OPTIMIZATION + +The bridge works fairly hard to optimize message sends under two conditions. In +both of these cases, a message send should be nearly as efficient as in ObjC: + +1) When both the message and the receiver's class are known at compile-time. In +general, the only way the receiver's class is known is if you declare it, which +you can do either via a DECLARE or THE form. For example: + +(SEND (THE NS-WINDOW W) 'CENTER) + +Note that there is no way in ObjC to name the class of a class. Thus +the bridge provides a @METACLASS declaration. The type of an instance +of "NSColor" is NS-COLOR. The type of the *class* "NSColor" is +(@METACLASS NS-COLOR): + +(LET ((C (@CLASS NS-COLOR))) + (DECLARE ((@METACLASS NS-COLOR) C)) + (SEND C 'WHITE-COLOR)) + +2) When only the message is known at compile-time, but its type +signature is unique. Of the over 6000 messages currently provided by +Cocoa, only about 50 of them have nonunique type signatures. An +example of a message whose type signature is not unique is SET. It +returns VOID for NSColor, but ID for NSSet. In order to optimize +sends of messages with nonunique type signatures, the class of the +receiver must be declared at compile-time. + +If the type signature is nonunique or the message is unknown at compile-time, +then a slower runtime call must be used. + +The ability of the bridge to optimize most constant message sends even +when the receiver's class is unknown crucially depends on a type +signature table that the bridge maintains. When the bridge is first +loaded, it initializes this table by scanning all methods of all ObjC +classes defined in the environment. If new methods are later defined, +this table must be updated. After a major change (such as loading a +new framework with many classes), you should evaluate +(UPDATE-TYPE-SIGNATURES) to rebuild the type signature table. + +Because SEND, SEND-SUPER, SEND/STRET and SEND-SUPER/STRET are macros, +they cannot be FUNCALLed, APPLYed or passed as functional arguments. +The functions %SEND and %SEND/STRET are provided for this +purpose. There are also %SEND-SUPER and %SEND-SUPER/STRET functions +for use within methods. However, these functions should be used only +when necessary since they perform general (nonoptimized) message +sends. + + +VARIABLE ARITY MESSAGES + +There are a few messages in Cocoa that take variable numbers of arguments. +Perhaps the most common examples involve formatted strings: + +[NSClass stringWithFormat: "%f %f" x y] + +In the bridge, this would be written as follows: + +(SEND (@CLASS NS-STRING) + :STRING-WITH-FORMAT #@"%f %f" + (:DOUBLE-FLOAT X :DOUBLE-FLOAT Y)) + +Note that the types of the variable arguments must be given, since the compiler +has no way of knowing these types in general. + +Variable arity messages can also be sent with the %SEND function: + +(%SEND (@CLASS NS-STRING) + :STRING-WITH-FORMAT #@"%f %f" + (LIST :DOUBLE-FLOAT X :DOUBLE-FLOAT Y)) + +Because the ObjC runtime system does not provide any information on +which messages are variable arity, they must be explicitly defined. +The standard variable arity messages in Cocoa are predefined. If you +need to define a new variable arity message, use +(DEFINE-VARIABLE-ARITY-MESSAGE "myVariableArityMessage:") + + +TYPE COERCION + +OpenMCL's FFI handles many common conversions between Lisp and foreign data, +such as unboxing floating-point args and boxing floating-point results. The +bridge adds a few more automatic conversions: + +1) NIL is equivalent to (%NULL-PTR) for any message argument that requires a +pointer + +2) T/NIL are equivalent to #$YES/#$NO for any boolean argument + +3) A #$YES/#$NO returned by any method that returns BOOL will be automatically +converted to T/NIL + +To make this last conversion work, the bridge has to engage in a bit +of hackery. The bridge uses ObjC run-time type info. Unfortunately, +BOOL is typed as CHAR by ObjC. Thus, a method that returns CHAR might +actually return only BOOL, or it might return any CHAR. The bridge +currently assumes that any method that returns CHAR actually returns +BOOL. But it provides a facility for defining exceptions to this +assumption: (DEFINE-RETURNS-BOOLEAN-EXCEPTION "charValue"). +Eventually, the best way to handle issues like this is probably to get +our method type info directly from the header files rather than using +ObjC's runtime type system. + +Note that no automatic conversion is currently performed between Lisp +strings and NSStrings. However, APPLE-OBJ provides a convenient +syntax for creating constant NSStrings: (SEND W :SET-TITLE #@"My +Window"), as well as facilities for converting between Lisp strings +and NSStrings. Note that #@"Hello" is a full ObjC object, so messages +can be sent to it: (SEND #@"Hello" 'LENGTH) + Index: /branches/experimentation/later/source/objc-bridge/bridge.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/bridge.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/bridge.lisp (revision 8058) @@ -0,0 +1,1425 @@ +;;;; -*- Mode: Lisp; Package: CCL -*- +;;;; bridge.lisp +;;;; +;;;; A Lisp bridge for Cocoa +;;;; +;;;; This provides: +;;;; (1) Convenient Lisp syntax for instantiating ObjC classes +;;;; (2) Convenient Lisp syntax for invoking ObjC methods +;;;; +;;;; Copyright (c) 2003 Randall D. Beer +;;;; +;;;; This software is licensed under the terms of the Lisp Lesser GNU Public +;;;; License, known as the LLGPL. The LLGPL consists of a preamble and +;;;; the LGPL. Where these conflict, the preamble takes precedence. The +;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. +;;;; +;;;; Please send comments and bug reports to + +;;; Temporary package and module stuff + +(in-package "CCL") + +(require "OBJC-RUNTIME") +(require "NAME-TRANSLATION") + +;;; Used in PRINT-OBJECT methods. + +(defun describe-macptr-allocation-and-address (p stream) + (format stream " ~@[~a ~](#x~x)" + (%macptr-allocation-string p) + (%ptr-to-int p))) + +(defstruct typed-foreign-struct-info + foreign-type + lisp-class-name + initializer + constructor + with-form-name + predicate-name) + +(defparameter *typed-foreign-struct-info* ()) + +(defun note-typed-foreign-struct-info (foreign-type lisp-class-name initializer constructor with-form-name predicate-name) + (let* ((info (find foreign-type *typed-foreign-struct-info* :test #'equal :key #'typed-foreign-struct-info-foreign-type))) + (unless info + (setq info (make-typed-foreign-struct-info :foreign-type foreign-type)) + (push info *typed-foreign-struct-info*)) + (setf (typed-foreign-struct-info-lisp-class-name info) lisp-class-name + (typed-foreign-struct-info-initializer info) initializer + (typed-foreign-struct-info-constructor info) constructor + (typed-foreign-struct-info-with-form-name info) with-form-name + (typed-foreign-struct-info-predicate-name info) predicate-name) + info)) + +;;; This gets installed as the COMPILER-MACRO-FUNCTION on any dispatch +;;; function associated with a method that passes structures by value. +(defun hoist-struct-constructors (whole env) + (declare (ignorable env)) + (destructuring-bind (operator receiver &rest args) whole + ;;See if any arguments are "obviously" known structure-creation forms. + (if (null (dolist (arg args) + (if (and (consp arg) + (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)) + (return t)))) + whole + ;;; Simplest to hoist one call, then let compiler-macroexpand + ;;; call us again. + (let* ((with-name nil) + (info nil) + (temp (gensym))) + (collect ((new-args)) + (new-args operator) + (new-args receiver) + (dolist (arg args) + (if (or info + (atom arg) + (not (setq info (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)))) + (new-args arg) + (progn + (setq with-name (typed-foreign-struct-info-with-form-name info)) + (if (cdr arg) + (new-args `(progn (,(typed-foreign-struct-info-initializer info) + ,temp + ,@(cdr arg)) + ,temp)) + (new-args temp))))) + `(,with-name (,temp) + (values ,(new-args)))))))) + + + +(defun define-typed-foreign-struct-accessor (type-name lisp-accessor-name foreign-accessor &optional (transform-output #'identity) (transform-input #'identity)) + (let* ((arg (gensym)) + (val (gensym))) + `(progn + (declaim (inline ,lisp-accessor-name)) + (defun ,lisp-accessor-name (,arg) + (if (typep ,arg ',type-name) + ,(funcall transform-input `(pref ,arg ,foreign-accessor)) + (report-bad-arg ,arg ',type-name))) + (declaim (inline (setf ,lisp-accessor-name))) + (defun (setf ,lisp-accessor-name) (,val ,arg) + (if (typep ,arg ',type-name) + (setf (pref ,arg ,foreign-accessor) ,(funcall transform-output val)) + (report-bad-arg ,arg ',type-name)))))) + +(defun define-typed-foreign-struct-accessors (type-name tuples) + (collect ((body)) + (dolist (tuple tuples `(progn ,@(body))) + (body (apply #'define-typed-foreign-struct-accessor type-name (cdr tuple)))))) + +(defun define-typed-foreign-struct-initializer (init-function-name tuples) + (when init-function-name + (let* ((struct (gensym))) + (collect ((initforms) + (args)) + (args struct) + (dolist (tuple tuples) + (destructuring-bind (arg-name lisp-accessor foreign-accessor &optional (transform #'identity)) tuple + (declare (ignore lisp-accessor)) + (args arg-name) + (initforms `(setf (pref ,struct ,foreign-accessor) ,(funcall transform arg-name))))) + `(progn + (declaim (inline ,init-function-name)) + (defun ,init-function-name ,(args) + (declare (ignorable ,struct)) + ,@(initforms) + ,struct)))))) + +(defun define-typed-foreign-struct-creation-function (creation-function-name init-function-name foreign-type accessors) + (when creation-function-name + (let* ((struct (gensym)) + (arg-names (mapcar #'car accessors))) + `(defun ,creation-function-name ,arg-names + (let* ((,struct (make-gcable-record ,foreign-type))) + (,init-function-name ,struct ,@arg-names) + ,struct))))) + +(defun define-typed-foreign-struct-class-with-form (with-form-name foreign-type init-function-name) + (declare (ignorable init-function-name)) + (when with-form-name + `(defmacro ,with-form-name ((instance &rest inits) &body body) + (multiple-value-bind (body decls) (parse-body body nil) + `(rlet ((,instance ,,foreign-type)) + ,@decls + ,@(when inits + `((,',init-function-name ,instance ,@inits))) + ,@body))))) + + +(defmacro define-typed-foreign-struct-class (class-name (foreign-type predicate-name init-function-name creation-function-name with-form-name) &rest accessors) + (let* ((arg (gensym))) + `(progn + (%register-type-ordinal-class (parse-foreign-type ',foreign-type) ',class-name) + (def-foreign-type ,class-name ,foreign-type) + (declaim (inline ,predicate-name)) + (note-typed-foreign-struct-info ',foreign-type ',class-name ',init-function-name ',creation-function-name ',with-form-name ',predicate-name) + (defun ,predicate-name (,arg) + (and (typep ,arg 'macptr) + (<= (the fixnum (%macptr-domain ,arg)) 1) + (= (the fixnum (%macptr-type ,arg)) + (foreign-type-ordinal (load-time-value (parse-foreign-type ',foreign-type)))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (type-predicate ',class-name) ',predicate-name)) + ,(define-typed-foreign-struct-initializer init-function-name accessors) + ,(define-typed-foreign-struct-creation-function creation-function-name init-function-name foreign-type accessors) + ,(define-typed-foreign-struct-class-with-form with-form-name foreign-type init-function-name) + ,(define-typed-foreign-struct-accessors class-name accessors) + ',class-name))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun wrap-cg-float (x) + `(float ,x +cgfloat-zero+))) + + + +;;; AEDesc (Apple Event Descriptor) + +(define-typed-foreign-struct-class ns::aedesc (:esc ns::aedesc-p ns::init-aedesc ns::make-aedesc ns::with-aedesc) + (descriptor-type ns::aedesc-descriptor-type :esc.descriptorype) + (data-handle ns::aedesc-data-handle :esc.dataandle)) + + +(defmethod print-object ((a ns::aedesc) stream) + (print-unreadable-object (a stream :type t :identity (%gcable-ptr-p a)) + (unless (%null-ptr-p a) + (format stream "~s ~s" + (ns::aedesc-descriptor-type a) + (ns::aedesc-data-handle a))) + (describe-macptr-allocation-and-address a stream))) + +;;; It's not clear how useful this would be; I think that it's +;;; part of the ObjC 2.0 extensible iteration stuff ("foreach"). +#+apple-objc-2.0 +(define-typed-foreign-struct-class ns::ns-fast-enumeration-state (:astnumerationtate ns::ns-fast-enumeration-state-p ns::init-ns-fast-enumeration-state ns::make-ns-fast-enumeration-state ns::with-ns-fast-enumeration-state)) + +;;; NSAffineTransformStruct CGAffineTransform +(define-typed-foreign-struct-class ns::ns-affine-transform-struct (:ffineransformtruct ns::ns-affine-transform-struct-p ns::init-ns-affine-transform-struct ns::make-ns-affine-transform-struct ns::wint-ns-affine-transform-struct) + (m11 ns::ns-affine-transform-struct-m11 :ffineransformtruct.m11 wrap-cg-float) + (m12 ns::ns-affine-transform-struct-m12 :ffineransformtruct.m12 wrap-cg-float) + (m21 ns::ns-affine-transform-struct-m21 :ffineransformtruct.m21 wrap-cg-float) + (m22 ns::ns-affine-transform-struct-m22 :ffineransformtruct.m22 wrap-cg-float) + (tx ns::ns-affine-transform-struct-tx :ffineransformtruct.t wrap-cg-float) + (ty ns::ns-affine-transform-struct-ty :ffineransformtruct.t wrap-cg-float)) + + +(defmethod print-object ((transform ns::ns-affine-transform-struct) stream) + (print-unreadable-object (transform stream :type t :identity t) + (format stream "~s ~s ~s ~s ~s ~s" + (ns::ns-affine-transform-struct-m11 transform) + (ns::ns-affine-transform-struct-m12 transform) + (ns::ns-affine-transform-struct-m21 transform) + (ns::ns-affine-transform-struct-m22 transform) + (ns::ns-affine-transform-struct-tx transform) + (ns::ns-affine-transform-struct-ty transform)) + (describe-macptr-allocation-and-address transform stream))) + + + + + +;;; An ffineransformtruct is identical to a +;;; (:struct :ffineransform), except for the names of its fields. + +(setf (foreign-type-ordinal (parse-foreign-type '(:struct :ffineransform))) + (foreign-type-ordinal (parse-foreign-type :ffineransformtruct))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun unwrap-boolean (form) + `(not (eql 0 ,form))) + (defun wrap-boolean (form) + `(if ,form 1 0))) + + +;;; NSDecimal +(define-typed-foreign-struct-class ns::ns-decimal (:ecimal ns::ns-decimal-p nil nil nil) + (nil ns::ns-decimal-exponent :ecimal._exponent) + (nil ns::ns-decimal-length :ecimal._length) + (nil ns::ns-decimal-is-negative :ecimal._isegative wrap-boolean unwrap-boolean) + (nil ns::ns-decimal-is-compact :ecimal._isompact wrap-boolean unwrap-boolean)) + + +(defun ns::init-ns-decimal (data exponent length is-negative is-compact mantissa) + (setf (pref data :ecimal._exponent) exponent + (pref data :ecimal._length) length + (pref data :ecimal._isegative) (if is-negative 1 0) + (pref data :ecimal._isompact) (if is-compact 1 0)) + (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8)))) + (declare (type (simple-array (unsigned-byte 16) (8)) v)) + (with-macptrs ((m (pref data :ecimal._mantissa))) + (dotimes (i 8) + (setf (paref m (:* (:unsigned 16)) i) (aref v i)))))) + +(defun ns::make-ns-decimal (exponent length is-negative is-compact mantissa) + (let* ((data (make-gcable-record :ecimal))) + (ns::init-ns-decimal data exponent length is-negative is-compact mantissa) + data)) + + + + +(defun ns::ns-decimal-mantissa (decimal) + (if (typep decimal 'ns::ns-decimal) + (let* ((dest (make-array 8 :element-type '(unsigned-byte 16)))) + (with-macptrs ((m (pref decimal :ecimal._mantissa))) + (dotimes (i 8 dest) + (setf (aref dest i) (paref m (:* (:unsigned 16)) i))))) + (report-bad-arg decimal 'ns::ns-decimal))) + +(defun (setf ns::ns-decimal-mantissa) (new decimal) + (if (typep decimal 'ns::ns-decimal) + (let* ((src (coerce new '(simple-array (unsigned-byte 16) (8))))) + (declare (type (simple-array (unsigned-byte 16) 8) src)) + (with-macptrs ((m (pref decimal :ecimal._mantissa))) + (dotimes (i 8 new) + (setf (paref m (:* (:unsigned 16)) i) (aref src i))))) + (report-bad-arg decimal 'ns::ns-decimal))) + +(defmethod print-object ((d ns::ns-decimal) stream) + (print-unreadable-object (d stream :type t :identity t) + (unless (%null-ptr-p d) + (format stream "exponent = ~d, length = ~s, is-negative = ~s, is-compact = ~s, mantissa = ~s" (ns::ns-decimal-exponent d) (ns::ns-decimal-length d) (ns::ns-decimal-is-negative d) (ns::ns-decimal-is-compact d) (ns::ns-decimal-mantissa d))) + (describe-macptr-allocation-and-address d stream))) + + + + +;;; NSRect + +(define-typed-foreign-struct-class ns::ns-rect (:ect ns::ns-rect-p ns::init-ns-rect ns::make-ns-rect ns::with-ns-rect) + (x ns::ns-rect-x :ect.origin.x wrap-cg-float) + (y ns::ns-rect-y :ect.origin.y wrap-cg-float) + (width ns::ns-rect-width :ect.size.width wrap-cg-float) + (height ns::ns-rect-height :ect.size.height wrap-cg-float)) + + +(defmethod print-object ((r ns::ns-rect) stream) + (print-unreadable-object (r stream :type t :identity t) + (unless (%null-ptr-p r) + (flet ((maybe-round (x) + (multiple-value-bind (q r) (round x) + (if (zerop r) q x)))) + (format stream "~s X ~s @ ~s,~s" + (maybe-round (ns::ns-rect-width r)) + (maybe-round (ns::ns-rect-height r)) + (maybe-round (ns::ns-rect-x r)) + (maybe-round (ns::ns-rect-y r))) + (describe-macptr-allocation-and-address r stream))))) + + + +;;; NSSize +(define-typed-foreign-struct-class ns::ns-size (:ize ns::ns-size-p ns::init-ns-size ns::make-ns-size ns::with-ns-size) + (width ns::ns-size-width :ize.width wrap-cg-float) + (height ns::ns-size-height :ize.height wrap-cg-float)) + + +(defmethod print-object ((s ns::ns-size) stream) + (flet ((maybe-round (x) + (multiple-value-bind (q r) (round x) + (if (zerop r) q x)))) + (unless (%null-ptr-p s) + (print-unreadable-object (s stream :type t :identity t) + (format stream "~s X ~s" + (maybe-round (ns::ns-size-width s)) + (maybe-round (ns::ns-size-height s))))) + (describe-macptr-allocation-and-address s stream))) + + +;;; NSPoint +(define-typed-foreign-struct-class ns::ns-point (:oint ns::ns-point-p ns::init-ns-point ns::make-ns-point ns::with-ns-point) + (x ns::ns-point-x :oint.x wrap-cg-float) + (y ns::ns-point-y :oint.y wrap-cg-float)) + +(defmethod print-object ((p ns::ns-point) stream) + (flet ((maybe-round (x) + (multiple-value-bind (q r) (round x) + (if (zerop r) q x)))) + (print-unreadable-object (p stream :type t :identity t) + (unless (%null-ptr-p p) + (format stream "~s,~s" + (maybe-round (ns::ns-point-x p)) + (maybe-round (ns::ns-point-y p)))) + (describe-macptr-allocation-and-address p stream)))) + + +;;; NSRange +(define-typed-foreign-struct-class ns::ns-range (:ange ns::ns-range-p ns::init-ns-range ns::make-ns-range ns::with-ns-range) + (location ns::ns-range-location :ange.location) + (length ns::ns-range-length :ange.length )) + +(defmethod print-object ((r ns::ns-range) stream) + (print-unreadable-object (r stream :type t :identity t) + (unless (%null-ptr-p r) + (format stream "~s/~s" + (ns::ns-range-location r) + (ns::ns-range-length r))) + (describe-macptr-allocation-and-address r stream))) + + +;;; String might be stack allocated; make a copy before complaining +;;; about it. +(defun check-objc-message-name (string) + (dotimes (i (length string)) + (let* ((ch (char string i))) + (unless (or (alpha-char-p ch) + (digit-char-p ch 10) + (eql ch #\:) + (eql ch #\_)) + (error "Illegal character ~s in ObjC message name ~s" + ch (copy-seq string))))) + (when (and (position #\: string) + (not (eql (char string (1- (length string))) #\:))) + (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string)))) + + +(setf (pkg.intern-hook (find-package "NSFUN")) + 'get-objc-message-info) + +(set-dispatch-macro-character #\# #\/ + (lambda (stream subchar numarg) + (declare (ignorable subchar numarg)) + (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t)) + (attrtab (rdtab.ttab *readtable*))) + (when (peek-char t stream nil nil) + (loop + (multiple-value-bind (char attr) + (%next-char-and-attr stream attrtab) + (unless (eql attr $cht_cnst) + (when char (unread-char char stream)) + (return)) + (vector-push-extend char token)))) + (unless *read-suppress* + (unless (> (length token) 0) + (signal-reader-error stream "Invalid token after #/.")) + (check-objc-message-name token) + (intern token "NSFUN"))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Utilities ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Return separate lists of the keys and values in a keyword/value list + +(defun keys-and-vals (klist) + (when (oddp (length klist)) + (error "Invalid keyword/value list: ~S" klist)) + (loop for l = klist then (cddr l) + until (null l) + collect (first l) into keys + collect (second l) into vals + finally (return (values keys vals)))) + + +;;; Return the typestring for an ObjC METHOD + +(defun method-typestring (method) + (%get-cstring #+apple-objc-2.0 + (#_method_getTypeEncoding method) + #-apple-objc-2.0 + (pref method :objc_method.method_types))) + + +;;; Parse the ObjC message from a SENDxxx macro + +(defun parse-message (args) + (let ((f (first args)) + (nargs (length args))) + (cond ((or (= nargs 1) (= nargs 2)) + ;; (THING {VARGS}) + (if (constantp f) + (%parse-message (cons (eval f) (rest args))) + (values f (rest args) nil))) + ;; (THING1 ARG1 ... THINGN ARGN) + ((evenp nargs) + (multiple-value-bind (ks vs) (keys-and-vals args) + (if (every #'constantp ks) + (%parse-message (mapcan #'list (mapcar #'eval ks) vs)) + (values f (rest args) nil)))) + ;; (THING1 ARG1 ... THINGN ARGN VARGS) + (t (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) + (if (every #'constantp ks) + (%parse-message + (nconc (mapcan #'list (mapcar #'eval ks) vs) (last args))) + (values f (rest args) nil))))))) + + +;;; Parse the ObjC message from the evaluated args of a %SENDxxx function + +(defun %parse-message (args) + (let ((f (first args)) + (l (first (last args)))) + (cond ((stringp f) + ;; (STRING-with-N-colons ARG1 ... ARGN {LIST}) + (let* ((n (count #\: (the simple-string f))) + (message-info (need-objc-message-info f)) + (args (rest args)) + (nargs (length args))) + (cond ((and (= nargs 1) + (getf (objc-message-info-flags message-info) + :accepts-varargs)) + (values f nil l)) + ((= nargs n) (values f args nil)) + ((= nargs (1+ n)) (values f (butlast args) l)) + (t (error "Improperly formatted argument list: ~S" args))))) + ((keywordp f) + ;; (KEY1 ARG1 ... KEYN ARGN {LIST}) or (KEY LIST) + (let ((nargs (length args))) + (cond ((and (= nargs 2) (consp l) + (let* ((info (need-objc-message-info + (lisp-to-objc-message (list f))))) + (getf (objc-message-info-flags info) + :accepts-varargs))) + (values (lisp-to-objc-message (list f)) nil l)) + ((evenp nargs) + (multiple-value-bind (ks vs) (keys-and-vals args) + (values (lisp-to-objc-message ks) vs nil))) + ((and (> nargs 1) (listp l)) + (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) + (values (lisp-to-objc-message ks) vs l))) + (t (error "Improperly formatted argument list: ~S" args))))) + ((symbolp f) + ;; (SYMBOL {LIST}) + (let ((nargs (length (rest args)))) + (cond ((= nargs 0) (values (lisp-to-objc-message (list f)) nil nil)) + ((= nargs 1) (values (lisp-to-objc-message (list f)) nil l)) + (t (error "Improperly formatted argument list: ~S" args))))) + (t (error "Improperly formatted argument list: ~S" args))))) + + +;;; Return the declared type of FORM in ENV + +(defun declared-type (form env) + (cond ((symbolp form) + (multiple-value-bind (ignore ignore decls) + (variable-information form env) + (declare (ignore ignore)) + (or (cdr (assoc 'type decls)) t))) + ((and (consp form) (eq (first form) 'the)) + (second form)) + (t t))) + + +;;; Return the current optimization setting of KEY in ENV + +(defun optimization-setting (key &optional env) + (cadr (assoc key (declaration-information 'optimize env)))) + + +;;; Return the ObjC class named CNAME + +(defun find-objc-class (cname) + (%objc-class-classptr + (if (symbolp cname) + (find-class cname) + (load-objc-class-descriptor cname)))) + + +;;; Return the class object of an ObjC object O, signalling an error +;;; if O is not an ObjC object + +(defun objc-class-of (o) + (if (objc-object-p o) + (class-of o) + (progn + #+debug + (#_NSLog #@"class name = %s" :address (pref (pref o :objc_object.isa) + :objc_class.name)) + (error "~S is not an ObjC object" o)))) + + +;;; Returns the ObjC class corresponding to the declared type OTYPE if +;;; possible, NIL otherwise + +(defun get-objc-class-from-declaration (otype) + (cond ((symbolp otype) (lookup-objc-class (lisp-to-objc-classname otype))) + ((and (consp otype) (eq (first otype) '@metaclass)) + (let* ((name (second otype)) + (c + (typecase name + (string (lookup-objc-class name)) + (symbol (lookup-objc-class (lisp-to-objc-classname name))) + (t (error "Improper metaclass typespec: ~S" otype))))) + (unless (null c) (objc-class-of c)))))) + + +;;; Returns the selector of MSG + +(defun get-selector (msg) + (%get-selector (load-objc-selector msg))) + + +;;; Get the instance method structure corresponding to SEL for CLASS + +(defun get-method (class sel) + (let ((m (class-get-instance-method class sel))) + (if (%null-ptr-p m) + (error "Instances of ObjC class ~S cannot respond to the message ~S" + (objc-class-name class) + (lisp-string-from-sel sel)) + m))) + + +;;; Get the class method structure corresponding to SEL for CLASS + +(defun get-class-method (class sel) + (let ((m (class-get-class-method class sel))) + (if (%null-ptr-p m) + (error "ObjC class ~S cannot respond to the message ~S" + (objc-class-name class) + (lisp-string-from-sel sel)) + m))) + + +;;; For some reason, these types sometimes show up as :STRUCTs even though they +;;; are not structure tags, but type names + +(defun fudge-objc-type (ftype) + (if (equal ftype '(:STRUCT :ecimal)) + :ecimal + ftype)) + + +;;; Returns T if the result spec requires a STRET for its return, NIL otherwise +;;; RSPEC may be either a number (in which case it is interpreted as a number +;;; of words) or a foreign type spec acceptable to PARSE-FOREIGN-TYPE. STRETS +;;; must be used when a structure larger than 4 bytes is returned + +(defun requires-stret-p (rspec) + (when (member rspec '(:DOUBLE-FLOAT :UNSIGNED-DOUBLEWORD :SIGNED-DOUBLEWORD) + :test #'eq) + (return-from requires-stret-p nil)) + (setq rspec (fudge-objc-type rspec)) + (if (numberp rspec) + (> rspec 1) + (> (ensure-foreign-type-bits (parse-foreign-type rspec)) target::nbits-in-word))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Stret Convenience Stuff ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Allocate any temporary storage necessary to hold strets required +;;; AT TOPLEVEL in the value forms. Special recognition is given to +;;; SENDs involving strets and to stret pseudo-functions +;;; NS-MAKE-POINT, NS-MAKE-RANGE, NS-MAKE-RECT and NS-MAKE-SIZE + +(defmacro slet (varforms &body body &environment env) + (multiple-value-bind (clean-body decls) (parse-body body env nil) + (loop with r and s + for (var val) in varforms + do (multiple-value-setq (r s) (sletify val t var)) + collect r into rvarforms + unless (null s) collect s into stretforms + finally + (return + `(rlet ,rvarforms + ,@decls + ,@stretforms + ,@clean-body))))) + + +;;; Note that SLET* does not allow declarations + +(defmacro slet* (varforms &body body &environment env) + (if (= (length varforms) 1) + `(slet ,varforms ,@body) + `(slet ,(list (first varforms)) + (slet* ,(rest varforms) ,@body)))) + + +;;; Collect the info necessary to transform a SLET into an RLET + +(defun sletify (form &optional errorp (var (gensym))) + (if (listp form) + (case (first form) + (ns-make-point + (assert (= (length form) 3)) + `(,var :oint :x ,(second form) :y ,(third form))) + (ns-make-rect + (assert (= (length form) 5)) + `(,var :ect :origin.x ,(second form) :origin.y ,(third form) + :size.width ,(fourth form) :size.height ,(fifth form))) + (ns-make-range + (assert (= (length form) 3)) + `(,var :ange :location ,(second form) :length ,(third form))) + (ns-make-size + (assert (= (length form) 3)) + `(,var :ize :width ,(second form) :height ,(third form))) + (send + (let* ((info (get-objc-message-info (parse-message (cddr form))))) + (if (null info) + (error "Can't determine message being sent in ~s" form)) + (let* ((rtype (objc-method-info-result-type + (car (objc-message-info-methods info))))) + (if (getf (objc-message-info-flags info) :returns-structure) + (values `(,var ,(if (typep rtype 'foreign-type) + (unparse-foreign-type rtype) + rtype)) + `(send/stret ,var ,@(rest form))) + (if errorp + (error "NonSTRET SEND in ~S" form) + form))))) + (send-super + (let* ((info (get-objc-message-info (parse-message (cddr form))))) + (if (null info) + (error "Can't determine message being sent in ~s" form)) + (let* ((rtype (objc-method-info-result-type + (car (objc-message-info-methods info))))) + (if (getf (objc-message-info-flags info) :returns-structure) + (values `(,var ,(if (typep rtype 'foreign-type) + (unparse-foreign-type rtype) + rtype)) + `(send-super/stret ,var ,@(rest form))) + (if errorp + (error "NonSTRET SEND-SUPER in ~S" form) + form))))) + (t (if errorp + (error "Unrecognized STRET call in ~S" form) + form))) + (if errorp + (error "Unrecognized STRET call in ~S" form) + form))) + + +;;; Process the arguments to a message send as an implicit SLET, collecting +;;; the info necessary to build the corresponding RLET + +(defun sletify-message-args (args) + (loop with svf and sif + for a in args + do (multiple-value-setq (svf sif) (sletify a)) + unless (null sif) collect sif into sifs + unless (equal svf a) + do (setf a (first svf)) + and collect svf into svfs + collect a into nargs + finally (return (values nargs svfs sifs)))) + + +;;; Convenience macros for some common Cocoa structures. More +;;; could be added + +(defmacro ns-max-range (r) + (let ((rtemp (gensym))) + `(let ((,rtemp ,r)) + (+ (pref ,rtemp :ange.location) (pref ,rtemp :ange.length))))) +(defmacro ns-min-x (r) `(pref ,r :ect.origin.x)) +(defmacro ns-min-y (r) `(pref ,r :ect.origin.y)) +(defmacro ns-max-x (r) + (let ((rtemp (gensym))) + `(let ((,rtemp ,r)) + (+ (pref ,r :ect.origin.x) + (pref ,r :ect.size.width))))) +(defmacro ns-max-y (r) + (let ((rtemp (gensym))) + `(let ((,rtemp ,r)) + (+ (pref ,r :ect.origin.y) + (pref ,r :ect.size.height))))) +(defmacro ns-mid-x (r) + (let ((rtemp (gensym))) + `(let ((,rtemp ,r)) + (* 0.5 (+ (ns-min-x ,rtemp) (ns-max-x ,rtemp)))))) +(defmacro ns-mid-y (r) + (let ((rtemp (gensym))) + `(let ((,rtemp ,r)) + (* 0.5 (+ (ns-min-y ,rtemp) (ns-max-y ,rtemp)))))) +(defmacro ns-height (r) `(pref ,r :ect.size.height)) +(defmacro ns-width (r) `(pref ,r :ect.size.width)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Type Stuff ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +(defvar *objc-message-info* (make-hash-table :test #'equal :size 800)) + +(defun result-type-requires-structure-return (result-type) + ;; Use objc-msg-send-stret for all methods that return + ;; record types. + (or (typep result-type 'foreign-record-type) + (and (not (typep result-type 'foreign-type)) + (typep (parse-foreign-type result-type) 'foreign-record-type)))) + +(defvar *objc-method-signatures* (make-hash-table :test #'equal)) + +(defstruct objc-method-signature-info + type-signature + function + super-function) + +(defun objc-method-signature-info (sig) + (or (gethash sig *objc-method-signatures*) + (setf (gethash sig *objc-method-signatures*) + (make-objc-method-signature-info + :type-signature sig + :function (compile-send-function-for-signature sig) + :super-function (%compile-send-function-for-signature sig t))))) + +(defun concise-foreign-type (ftype) + (if (typep ftype 'foreign-record-type) + (let* ((name (foreign-record-type-name ftype))) + (if name + `(,(foreign-record-type-kind ftype) ,name) + (unparse-foreign-type ftype))) + (if (objc-id-type-p ftype) + :id + (if (typep ftype 'foreign-pointer-type) + (let* ((to (foreign-pointer-type-to ftype))) + (if (null to) + '(:* :void) + `(:* ,(concise-foreign-type to)))) + (if (typep ftype 'foreign-type) + (unparse-foreign-type ftype) + ftype))))) + + +;;; Not a perfect mechanism. +(defclass objc-dispatch-function (funcallable-standard-object) + () + (:metaclass funcallable-standard-class)) + +(defmethod print-object ((o objc-dispatch-function) stream) + (print-unreadable-object (o stream :type t :identity t) + (let* ((name (function-name o))) + (when name + (format stream "~s" name))))) + + + + +(declaim (inline check-receiver)) + +;;; Return a NULL pointer if RECEIVER is a null pointer. +;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL. +(defun check-receiver (receiver) + (if (%null-ptr-p receiver) + (%null-ptr) + (let* ((domain (%macptr-domain receiver)) + (valid (eql domain *objc-object-domain*))) + (declare (fixnum domain)) + (when (zerop domain) + (if (recognize-objc-object receiver) + (progn (%set-macptr-domain receiver *objc-object-domain*) + (setq valid t)))) + (unless valid + (report-bad-arg receiver 'objc:objc-object))))) + +(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys) + (declare (ignore slot-names)) + (if message-info + (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous)) + (selector (objc-message-info-selector message-info)) + (first-method (car (objc-message-info-methods message-info)))) + (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info)) + $lfbits-numreq + (logior (ash + (if (getf (objc-message-info-flags message-info) + :accepts-varargs) + 1 + 0) + $lfbits-rest-bit) + (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit))))) + (flet ((signature-function-for-method (m) + (let* ((signature-info (objc-method-info-signature-info m))) + (or (objc-method-signature-info-function signature-info) + (setf (objc-method-signature-info-function signature-info) + (compile-send-function-for-signature + (objc-method-signature-info-type-signature signature-info))))))) + + (if (null ambiguous-methods) + ;; Pick an arbitrary method, since all methods have the same + ;; signature. + (let* ((function (signature-function-for-method first-method))) + (set-funcallable-instance-function + gf + (nfunction + send-unambiguous-message + (lambda (receiver &rest args) + (declare (dynamic-extent args)) + (or (check-receiver receiver) + (with-ns-exceptions-as-errors + (apply function receiver selector args))))))) + (let* ((protocol-pairs (mapcar #'(lambda (pm) + (cons (lookup-objc-protocol + (objc-method-info-class-name pm)) + (signature-function-for-method + pm))) + (objc-message-info-protocol-methods message-info))) + (method-pairs (mapcar #'(lambda (group) + (cons (mapcar #'(lambda (m) + (get-objc-method-info-class m)) + group) + (signature-function-for-method (car group)))) + (objc-message-info-ambiguous-methods message-info))) + (default-function (if method-pairs + (prog1 (cdar (last method-pairs)) + (setq method-pairs (nbutlast method-pairs))) + (prog1 (cdr (last protocol-pairs)) + (setq protocol-pairs (nbutlast protocol-pairs)))))) + (set-funcallable-instance-function + gf + (nfunction + send-unambiguous-message + (lambda (receiver &rest args) + (declare (dynamic-extent args)) + (or (check-receiver receiver) + (let* ((function + (or (dolist (pair protocol-pairs) + (when (conforms-to-protocol receiver (car pair)) + (return (cdr pair)))) + (block m + (dolist (pair method-pairs default-function) + (dolist (class (car pair)) + (when (typep receiver class) + (return-from m (cdr pair))))))))) + (with-ns-exceptions-as-errors + (apply function receiver selector args))))))))))) + (with-slots (name) gf + (set-funcallable-instance-function + gf + #'(lambda (&rest args) + (error "Unknown ObjC message ~a called with arguments ~s" + (symbol-name name) args)))))) + + +(defun %call-next-objc-method (self class selector sig &rest args) + (declare (dynamic-extent args)) + (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self + #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class + #+apple-objc-2.0 (#_class_getSuperclass class) + #-apple-objc-2.0 (pref class :objc_class.super_class))) + (let* ((siginfo (objc-method-signature-info sig)) + (function (or (objc-method-signature-info-super-function siginfo) + (setf (objc-method-signature-info-super-function siginfo) + (%compile-send-function-for-signature sig t))))) + (with-ns-exceptions-as-errors + (apply function s selector args))))) + + +(defun %call-next-objc-class-method (self class selector sig &rest args) + (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self + #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class + #+apple-objc-2.0 (#_class_getSuperclass (pref class :objc_class.isa)) + #-apple-objc-2.0 (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class))) + (let* ((siginfo (objc-method-signature-info sig)) + (function (or (objc-method-signature-info-super-function siginfo) + (setf (objc-method-signature-info-super-function siginfo) + (%compile-send-function-for-signature sig t))))) + (with-ns-exceptions-as-errors + (apply function s selector args))))) + +(defun postprocess-objc-message-info (message-info) + (let* ((objc-name (objc-message-info-message-name message-info)) + (lisp-name (or (objc-message-info-lisp-name message-info) + (setf (objc-message-info-lisp-name message-info) + (compute-objc-to-lisp-function-name objc-name)))) + (gf (or (fboundp lisp-name) + (setf (fdefinition lisp-name) + (make-instance 'objc-dispatch-function :name lisp-name))))) + + (unless (objc-message-info-selector message-info) + (setf (objc-message-info-selector message-info) + (ensure-objc-selector (objc-message-info-message-name message-info)))) + + (flet ((reduce-to-ffi-type (ftype) + (concise-foreign-type ftype))) + (flet ((ensure-method-signature (m) + (or (objc-method-info-signature m) + (setf (objc-method-info-signature m) + (let* ((sig + (cons (reduce-to-ffi-type + (objc-method-info-result-type m)) + (mapcar #'reduce-to-ffi-type + (objc-method-info-arglist m))))) + (setf (objc-method-info-signature-info m) + (objc-method-signature-info sig)) + sig))))) + (let* ((methods (objc-message-info-methods message-info)) + (signatures ()) + (protocol-methods) + (signature-alist ())) + (labels ((signatures-equal (xs ys) + (and xs + ys + (do* ((xs xs (cdr xs)) + (ys ys (cdr ys))) + ((null xs) (null ys)) + (unless (foreign-type-= (ensure-foreign-type (car xs)) + (ensure-foreign-type (car ys))) + (return nil)))))) + (dolist (m methods) + (let* ((signature (ensure-method-signature m))) + (pushnew signature signatures :test #'signatures-equal) + (if (getf (objc-method-info-flags m) :protocol) + (push m protocol-methods) + (let* ((pair (assoc signature signature-alist :test #'signatures-equal))) + (if pair + (push m (cdr pair)) + (push (cons signature (list m)) signature-alist))))))) + (setf (objc-message-info-ambiguous-methods message-info) + (mapcar #'cdr + (sort signature-alist + #'(lambda (x y) + (< (length (cdr x)) + (length (cdr y))))))) + (setf (objc-message-info-flags message-info) nil) + (setf (objc-message-info-protocol-methods message-info) + protocol-methods) + (when (cdr signatures) + (setf (getf (objc-message-info-flags message-info) :ambiguous) t)) + (let* ((first-method (car methods)) + (first-sig (objc-method-info-signature first-method)) + (first-sig-len (length first-sig))) + (setf (objc-message-info-req-args message-info) + (1- first-sig-len)) + ;; Whether some arg/result types vary or not, we want to insist + ;; on (a) either no methods take a variable number of arguments, + ;; or all do, and (b) either no method uses structure-return + ;; conventions, or all do. (It's not clear that these restrictions + ;; are entirely reasonable in the long run; in the short term, + ;; they'll help get things working.) + (flet ((method-returns-structure (m) + (result-type-requires-structure-return + (objc-method-info-result-type m))) + (method-accepts-varargs (m) + (eq (car (last (objc-method-info-arglist m))) + *void-foreign-type*)) + (method-has-structure-arg (m) + (dolist (arg (objc-method-info-arglist m)) + (when (typep (ensure-foreign-type arg) 'foreign-record-type) + (return t))))) + (when (dolist (method methods) + (when (method-has-structure-arg method) + (return t))) + (setf (compiler-macro-function lisp-name) + 'hoist-struct-constructors)) + (let* ((first-result-is-structure (method-returns-structure first-method)) + (first-accepts-varargs (method-accepts-varargs first-method))) + (if (dolist (m (cdr methods) t) + (unless (eq (method-returns-structure m) + first-result-is-structure) + (return nil))) + (if first-result-is-structure + (setf (getf (objc-message-info-flags message-info) + :returns-structure) t))) + (if (dolist (m (cdr methods) t) + (unless (eq (method-accepts-varargs m) + first-accepts-varargs) + (return nil))) + (if first-accepts-varargs + (progn + (setf (getf (objc-message-info-flags message-info) + :accepts-varargs) t) + (decf (objc-message-info-req-args message-info))))))))) + (reinitialize-instance gf :message-info message-info))))) + +;;; -may- need to invalidate cached info whenever new interface files +;;; are made accessible. Probably the right thing to do is to insist +;;; that (known) message signatures be updated in that case. +(defun get-objc-message-info (message-name &optional (use-database t)) + (setq message-name (string message-name)) + (or (gethash message-name *objc-message-info*) + (and use-database + (let* ((info (lookup-objc-message-info message-name))) + (when info + (setf (gethash message-name *objc-message-info*) info) + (postprocess-objc-message-info info) + info))))) + +(defun need-objc-message-info (message-name) + (or (get-objc-message-info message-name) + (error "Undeclared message: ~s" message-name))) + +;;; Should be called after using new interfaces that may define +;;; new methods on existing messages. +(defun update-objc-method-info () + (maphash #'(lambda (message-name info) + (lookup-objc-message-info message-name info) + (postprocess-objc-message-info info)) + *objc-message-info*)) + + +;;; Of the method declarations (OBJC-METHOD-INFO structures) associated +;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M, +;;; return the one that seems to be applicable for the object O. +;;; (If there's no ambiguity among the declared methods, any method +;;; will do; this just tells runtime %SEND functions how to compose +;;; an %FF-CALL). +(defun %lookup-objc-method-info (m o) + (let* ((methods (objc-message-info-methods m)) + (ambiguous (getf (objc-message-info-flags m) :ambiguous))) + (if (not ambiguous) + (car methods) + (or + (dolist (method methods) + (let* ((mclass (get-objc-method-info-class method))) + (if (typep o mclass) + (return method)))) + (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o))))) + +(defun resolve-existing-objc-method-info (message-info class-name class-p result-type args) + (let* ((method-info (dolist (m (objc-message-info-methods message-info)) + (when (and (eq (getf (objc-method-info-flags m) :class-p) + class-p) + (equal (objc-method-info-class-name m) + class-name)) + (return m))))) + (when method-info + (unless (and (foreign-type-= (ensure-foreign-type (objc-method-info-result-type method-info)) + (parse-foreign-type result-type)) + (do* ((existing (objc-method-info-arglist method-info) (cdr existing)) + (proposed args (cdr proposed))) + ((null existing) (null proposed)) + (unless (foreign-type-= (ensure-foreign-type (car existing)) + (parse-foreign-type (car proposed))) + (return nil)))) + (cerror "Redefine existing method to have new type signature." + "The method ~c[~a ~a] is already declared to have type signature ~s; the new declaration ~s is incompatible." (if class-p #\+ #\-) class-name (objc-message-info-message-name message-info) (objc-method-info-signature method-info) (cons result-type args)) + (setf (objc-method-info-arglist method-info) args + (objc-method-info-result-type method-info) result-type + (objc-method-info-signature method-info) nil + (objc-method-info-signature-info method-info) nil)) + method-info))) + +;;; Still not right; we have to worry about type conflicts with +;;; shadowed methods, as well. +(defun %declare-objc-method (message-name class-name class-p result-type args) + (let* ((info (get-objc-message-info message-name))) + (unless info + (format *error-output* "~&; Note: defining new ObjC message ~c[~a ~a]" (if class-p #\+ #\-) class-name message-name) + (setq info (make-objc-message-info :message-name message-name)) + (setf (gethash message-name *objc-message-info*) info)) + (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous)) + (method-info (or (resolve-existing-objc-method-info info class-name class-p result-type args) + (make-objc-method-info :message-info info + :class-name class-name + :result-type result-type + :arglist args + :flags (if class-p '(:class t)))))) + (pushnew method-info (objc-message-info-methods info)) + (postprocess-objc-message-info info) + (if (and (getf (objc-message-info-flags info) :ambiguous) + (not was-ambiguous)) + (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info)) + + (objc-method-info-signature method-info)))) + + + +;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID + +(defun translate-foreign-result-type (ftype) + (ensure-foreign-type-bits (parse-foreign-type ftype)) + (if (eq ftype :void) + :void + (translate-foreign-arg-type ftype))) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Invoking ObjC Methods ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; The SEND and SEND/STRET macros + +(defmacro send (o msg &rest args &environment env) + (make-optimized-send o msg args env)) + +(defmacro send/stret (s o msg &rest args &environment env) + (make-optimized-send o msg args env s)) + + + + +;;; Optimize special cases of SEND and SEND/STRET + +(defun make-optimized-send (o msg args env &optional s super sclassname) + (multiple-value-bind (msg args vargs) (parse-message (cons msg args)) + (let* ((message-info (get-objc-message-info msg))) + (if (null message-info) + (error "Unknown message: ~S" msg)) + ;; If a vararg exists, make sure that the message can accept it + (when (and vargs (not (getf (objc-message-info-flags message-info) + :accepts-varargs))) + (error "Message ~S cannot accept a variable number of arguments" msg)) + (unless (= (length args) (objc-message-info-req-args message-info)) + (error "Message ~S requires ~a ~d args, but ~d were provided." + msg + (if vargs "at least" "exactly") + (objc-message-info-req-args message-info) + (length args))) + (multiple-value-bind (args svarforms sinitforms) (sletify-message-args args) + (let* ((ambiguous (getf (objc-message-info-flags message-info) :ambiguous)) + (methods (objc-message-info-methods message-info)) + (method (if (not ambiguous) (car methods)))) + (when ambiguous + (let* ((class (if sclassname + (find-objc-class sclassname) + (get-objc-class-from-declaration (declared-type o env))))) + (if class + (dolist (m methods) + (unless (getf (objc-method-info-flags m) :protocol) + (let* ((mclass (or (get-objc-method-info-class m) + (error "Can't find ObjC class named ~s" + (objc-method-info-class-name m))))) + (when (and class (subtypep class mclass)) + (return (setq method m))))))))) + (if method + (build-call-from-method-info method + args + vargs + o + msg + svarforms + sinitforms + s + super) + (build-ambiguous-send-form message-info + args + vargs + o + msg + svarforms + sinitforms + s + super))))))) + + +;;; WITH-NS-EXCEPTIONS-AS-ERRORS is only available in OpenMCL 0.14 and above + +#-openmcl-native-threads +(defmacro with-ns-exceptions-as-errors (&body body) + `(progn ,@body)) + + +;;; Return a call to the method specified by SEL on object O, with the args +;;; specified by ARGSPECS. This decides whether a normal or stret call is +;;; needed and, if the latter, uses the memory S to hold the result. If SUPER +;;; is nonNIL, then this builds a send to super. Finally, this also +;;; coerces return #$YES/#$NO values to T/NIL. The entire call takes place +;;; inside an implicit SLET. + +(defun build-call (o sel msg argspecs svarforms sinitforms &optional s super) + `(with-ns-exceptions-as-errors + (rlet ,svarforms + ,@sinitforms + ,(let ((rspec (first (last argspecs)))) + (if (requires-stret-p rspec) + (if (null s) + ;; STRET required but not provided + (error "The message ~S must be sent using SEND/STRET" msg) + ;; STRET required and provided, use stret send + (if (null super) + ;; Regular stret send + `(progn + (objc-message-send-stret ,s ,o ,(cadr sel) + ,@(append (butlast argspecs) (list :void))) + ,s) + ;; Super stret send + `(progn + (objc-message-send-super-stret ,s ,super ,(cadr sel) + ,@(append (butlast argspecs) (list :void))) + ,s))) + (if (null s) + ;; STRET not required and not provided, use send + (if (null super) + ;; Regular send + (if (eq rspec :) + `(coerce-from-bool + (objc-message-send ,o ,(cadr sel) ,@argspecs)) + `(objc-message-send ,o ,(cadr sel) ,@argspecs)) + ;; Super send + (if (eq rspec :) + `(coerce-from-bool + (objc-message-send-super ,super ,(cadr sel) ,@argspecs)) + `(objc-message-send-super ,super ,(cadr sel) ,@argspecs))) + ;; STRET not required but provided + (error "The message ~S must be sent using SEND" msg))))))) + +(defun objc-id-type-p (foreign-type) + (and (typep foreign-type 'foreign-pointer-type) + (let* ((to (foreign-pointer-type-to foreign-type))) + (and (typep to 'foreign-record-type) + (eq :struct (foreign-record-type-kind to)) + (not (null (progn (ensure-foreign-type-bits to) (foreign-record-type-fields to)))) + (let* ((target (foreign-record-field-type (car (foreign-record-type-fields to))))) + (and (typep target 'foreign-pointer-type) + (let* ((target-to (foreign-pointer-type-to target))) + (and (typep target-to 'foreign-record-type) + (eq :struct (foreign-record-type-kind target-to)) + (eq :objc_class (foreign-record-type-name target-to)))))))))) + +(defun unique-objc-classes-in-method-info-list (method-info-list) + (if (cdr method-info-list) ; if more than 1 class + (flet ((subclass-of-some-other-class (c) + (let* ((c-class (get-objc-method-info-class c))) + (dolist (other method-info-list) + (unless (eq other c) + (when (subtypep c-class (get-objc-method-info-class other)) + (return t))))))) + (remove-if #'subclass-of-some-other-class method-info-list)) + method-info-list)) + +(defun get-objc-method-info-class (method-info) + (or (objc-method-info-class-pointer method-info) + (setf (objc-method-info-class-pointer method-info) + (let* ((c (lookup-objc-class (objc-method-info-class-name method-info) nil))) + (when c + (let* ((meta-p (getf (objc-method-info-flags method-info) :class))) + (if meta-p + (with-macptrs ((m (pref c :objc_class.isa))) + (canonicalize-registered-metaclass m)) + (canonicalize-registered-class c)))))))) + +;;; Generate some sort of CASE or COND to handle an ambiguous message +;;; send (where the signature of the FF-CALL depends on the type of the +;;; receiver.) +;;; AMBIGUOUS-METHODS is a list of lists of OBJC-METHOD-INFO structures, +;;; where the methods in each sublist share the same type signature. It's +;;; sorted so that more unique method/signature combinations appear first +;;; (and are easier to special-case via TYPECASE.) +(defun build-send-case (ambiguous-methods + args + vargs + receiver + msg + s + super + protocol-methods) + (flet ((method-class-name (m) + (let* ((mclass (get-objc-method-info-class m))) + (unless mclass + (error "Can't find class with ObjC name ~s" + (objc-method-info-class-name m))) + (class-name mclass)))) + + (collect ((clauses)) + (let* ((protocol (gensym)) + (protocol-address (gensym))) + (dolist (method protocol-methods) + (let* ((protocol-name (objc-method-info-class-name method))) + (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)) + (,protocol-address (and ,protocol (objc-protocol-address ,protocol)))) + (and ,protocol-address + (objc-message-send ,receiver + "conformsToProtocol:" + :address ,protocol-address + :))) + ,(build-internal-call-from-method-info + method args vargs receiver msg s super)))))) + (do* ((methods ambiguous-methods (cdr methods))) + ((null (cdr methods)) + (when ambiguous-methods + (clauses `(t + ,(build-internal-call-from-method-info + (caar methods) args vargs receiver msg s super))))) + (clauses `(,(if (cdar methods) + `(or ,@(mapcar #'(lambda (m) + `(typep ,receiver + ',(method-class-name m))) + (unique-objc-classes-in-method-info-list + (car methods)))) + `(typep ,receiver ',(method-class-name (caar methods)))) + ,(build-internal-call-from-method-info + (caar methods) args vargs receiver msg s super)))) + `(cond + ,@(clauses))))) + +(defun build-ambiguous-send-form (message-info args vargs o msg svarforms sinitforms s super) + (let* ((receiver (gensym)) + (caseform (build-send-case + (objc-message-info-ambiguous-methods message-info) + args + vargs + receiver + msg + s + super + (objc-message-info-protocol-methods message-info)))) + `(with-ns-exceptions-as-errors + (rlet ,svarforms + ,@sinitforms + (let* ((,receiver ,o)) + ,caseform))))) + + +;;; Generate the "internal" part of a method call; the "external" part +;;; has established ObjC exception handling and handled structure-return +;; details +(defun build-internal-call-from-method-info (method-info args vargs o msg s super) + (let* ((arglist ())) + (collect ((specs)) + (do* ((args args (cdr args)) + (argtypes (objc-method-info-arglist method-info) (cdr argtypes)) + (reptypes (cdr (objc-method-info-signature method-info)) (cdr reptypes))) + ((null args) (setq arglist (append (specs) vargs))) + (let* ((reptype (if (objc-id-type-p (car argtypes)) :id (car reptypes))) + (arg (car args))) + (specs reptype) + (specs arg))) + ;;(break "~& arglist = ~s" arglist) + (if (result-type-requires-structure-return + (objc-method-info-result-type method-info)) + (if (null s) + ;; STRET required but not provided + (error "The message ~S must be sent using SEND/STRET" msg) + (if (null super) + `(objc-message-send-stret ,s ,o ,msg ,@arglist ,(car (objc-method-info-signature method-info))) + `(objc-message-send-super-stret ,s ,super ,msg ,@arglist ,(car (objc-method-info-signature method-info))))) + (if s + ;; STRET provided but not required + (error "The message ~S must be sent using SEND" msg) + (let* ((result-spec (car (objc-method-info-signature method-info))) + (form (if super + `(objc-message-send-super ,super ,msg ,@arglist ,result-spec) + `(objc-message-send ,o ,msg ,@arglist ,result-spec)))) + form)))))) + +(defun build-call-from-method-info (method-info args vargs o msg svarforms sinitforms s super) + `(with-ns-exceptions-as-errors + (rlet ,svarforms + ,@sinitforms + ,(build-internal-call-from-method-info + method-info + args + vargs + o + msg + s + super)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Instantiating ObjC Class ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; A MAKE-INSTANCE like interface to ObjC object creation + +(defun make-objc-instance (cname &rest initargs) + (declare (dynamic-extent initargs)) + (multiple-value-bind (ks vs) (keys-and-vals initargs) + (declare (dynamic-extent ks vs)) + (let* ((class (etypecase cname + (string (canonicalize-registered-class + (find-objc-class cname))) + (symbol (find-class cname)) + (class cname)))) + (send-objc-init-message (#/alloc class) ks vs)))) + + + + + +;;; Provide the BRIDGE module + +(provide "BRIDGE") Index: /branches/experimentation/later/source/objc-bridge/fake-cfbundle-path.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/fake-cfbundle-path.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/fake-cfbundle-path.lisp (revision 8058) @@ -0,0 +1,60 @@ +;;;-*-Mode: LISP; Package: CCL -*- + +(in-package "CCL") + +;;; Before loading any Cocoa code which depends on CFBundle/NSBundle +;;; being able to find an application bundle, it -may- be neccessary +;;; to point the environment variable "CFProcessPath" to some file +;;; that's where the bundle's executable would be. +;;; This should only be necessary if the current application isn't +;;; already "inside a bundle". If it is necessary, it has to happen +;;; before the CoreFoundation library's initialized. + +(defun fake-cfbundle-path (bundle-root info-plist-proto-path bundle-prefix) + (let* ((kernel-name (standard-kernel-name)) + (translated-root (translate-logical-pathname bundle-root)) + (bundle-name (let* ((name (if (directory-pathname-p translated-root) + (car (last (pathname-directory translated-root))) + (file-namestring translated-root))) + (len (length name))) + (if (and (> len 4) + (string-equal name ".app" :start1 (- len 4))) + (subseq name 0 (- len 4)) + name))) + (bundle-id (concatenate 'string bundle-prefix "." bundle-name)) + (bundle-version (format nil "~d" *openmcl-svn-revision*)) + (needles `(("OPENMCL-KERNEL" . ,kernel-name) + ("OPENMCL-NAME" . ,bundle-name) + ("OPENMCL-IDENTIFIER" . ,bundle-id) + ("OPENMCL-VERSION" . ,bundle-version))) + (executable-path (merge-pathnames + (make-pathname :directory "Contents/MacOS/" + :name kernel-name) + translated-root))) + (unless (probe-file info-plist-proto-path) + (error "Can't find Info.plist prototype in ~s" info-plist-proto-path)) + (with-open-file (in info-plist-proto-path + :direction :input + :external-format :utf-8) + (with-open-file (out (merge-pathnames + (make-pathname :directory "Contents/" + :name "Info" + :type "plist") + translated-root) + :direction :output + :if-does-not-exist :create + :if-exists :supersede + :external-format :utf-8) + (do* ((line (read-line in nil nil) (read-line in nil nil))) + ((null line)) + (dolist (needle needles) + (let* ((pos (search (car needle) line))) + (when pos + (setq line + (concatenate 'string + (subseq line 0 pos) + (cdr needle) + (subseq line (+ pos (length (car needle))))))))) + (write-line line out)))) + (touch executable-path) + (setenv "CFProcessPath" (native-translated-namestring executable-path)))) Index: /branches/experimentation/later/source/objc-bridge/name-translation.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/name-translation.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/name-translation.lisp (revision 8058) @@ -0,0 +1,443 @@ +;;;; -*- Mode: Lisp; Package: CCL -*- +;;;; name-translation.lisp +;;;; +;;;; Handles the translation between ObjC and Lisp names +;;;; +;;;; Copyright (c) 2003 Randall D. Beer +;;;; +;;;; This software is licensed under the terms of the Lisp Lesser GNU Public +;;;; License , known as the LLGPL. The LLGPL consists of a preamble and +;;;; the LGPL. Where these conflict, the preamble takes precedence. The +;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. +;;;; +;;;; Please send comments and bug reports to + +;;; Temporary package stuff + +(in-package "CCL") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Special ObjC Words ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Special character sequences that should be treated as words in ObjC +;;; names even though they do not follow the normal naming conventions + +(defvar *special-objc-words* nil) + + +;;; Add a special word to *SPECIAL-OBJC-WORDS*, keeping the words sorted +;;; from longest to shortest + +(defmacro define-special-objc-word (str) + `(setf *special-objc-words* + (sort (pushnew ,str *special-objc-words* :test #'equal) + #'> + :key #'length))) + + +;;; Known special words used in Cocoa names + +(define-special-objc-word "AB") +(define-special-objc-word "AE") +(define-special-objc-word "ATS") +(define-special-objc-word "BMP") +(define-special-objc-word "CF") +(define-special-objc-word "CG") +(define-special-objc-word "CMYK") +(define-special-objc-word "MIME") +(define-special-objc-word "DR") +(define-special-objc-word "EPS") +(define-special-objc-word "FTP") +(define-special-objc-word "GMT") +(define-special-objc-word "objC") +(define-special-objc-word "OpenGL") +(define-special-objc-word "HTML") +(define-special-objc-word "HTTP") +(define-special-objc-word "HTTPS") +(define-special-objc-word "IB") +(define-special-objc-word "ID") +(define-special-objc-word "INT64") +(define-special-objc-word "NS") +(define-special-objc-word "MIME") +(define-special-objc-word "PDF") +(define-special-objc-word "PICT") +(define-special-objc-word "PNG") +(define-special-objc-word "QD") +(define-special-objc-word "RGB") +(define-special-objc-word "RTFD") +(define-special-objc-word "RTF") +(define-special-objc-word "TCP") +(define-special-objc-word "TIFF") +(define-special-objc-word "UI") +(define-special-objc-word "UID") +(define-special-objc-word "UTF8") +(define-special-objc-word "URL") +(define-special-objc-word "XOR") +(define-special-objc-word "XML") +(define-special-objc-word "1970") +#+gnu-objc +(define-special-objc-word "GS") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Utilities ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Concatenate all of the simple strings STRS + +(defun string-cat (&rest strs) + (apply #'concatenate 'simple-string strs)) + + +;;; 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)) + + +;;; Collapse all prefixes of L that correspond to known special ObjC words + +(defun collapse-prefix (l) + (unless (null l) + (multiple-value-bind (newpre skip) (check-prefix l) + (cons newpre (collapse-prefix (nthcdr skip l)))))) + +(defun check-prefix (l) + (let ((pl (prefix-list l))) + (loop for w in *special-objc-words* + for p = (position-if #'(lambda (s) (string= s w)) pl) + when p do (return-from check-prefix (values (nth p pl) (1+ p)))) + (values (first l) 1))) + +(defun prefix-list (l) + (loop for i from (1- (length l)) downto 0 + collect (apply #'string-cat (butlast l i)))) + + +;;; Concatenate a list of strings with optional separator into a symbol + +(defun symbol-concatenate (slist &optional (sep "") (package *package*)) + (values + (intern + (reduce #'(lambda (s1 s2) (string-cat s1 sep s2)) + (mapcar #'string-upcase slist)) + package))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Implementation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Convert an ObjC name to a corresponding Lisp name +;;; Example: "NSURLHandleClient" ==> ns-url-handle-client +;;; +;;; 1) Break the string at each uppercase letter +;;; e.g., "NSWindow" ==> ("N" "S" "Window") +;;; 2) Collapse known sequences of letters +;;; e.g., ("N" "S" "Window") ==> ("NS" "Window") +;;; 3) Uppercase and concatenate with hyphens into a symbol +;;; e.g., ("NS" "Window") ==> NS-WINDOW + +(defun compute-lisp-name (str &optional (package *package*)) + (symbol-concatenate + (collapse-prefix + (split-if #'(lambda (ch) (or (upper-case-p ch) (digit-char-p ch))) str)) + "-" + package)) + + +;;; Convert a Lisp classname into a corresponding ObjC classname +;;; Example: ns-url-handle-client ==> "NSURLHandleClient" + +(defun compute-objc-classname (sym) + (apply #'string-cat + (loop for str in (split-if-char #\- (string sym) :elide) + for e = (member str *special-objc-words* + :test #'equal + :key #'string-upcase) + collect (if e (first e) (string-capitalize str))))) + + +;;; Convert an ObjC method selector to a set of Lisp keywords +;;; Example: "nextEventMatchingMask:untilDate:inMode:dequeue:" ==> +;;; (:next-event-matching-mask :until-date :in-mode :dequeue) + +(defun compute-objc-to-lisp-message (str) + (mapcar #'(lambda (s) (compute-lisp-name s (find-package "KEYWORD"))) + (split-if-char #\: str :elide))) + + +(defparameter *objc-colon-replacement-character* #\.) + + +(defun compute-objc-to-lisp-function-name (str &optional (package "NSFUN")) + #-nil + (intern str package) + #+nil + (let* ((n (length str)) + (i 0) + (trailing t)) + (let* ((subs (if (not (position #\: str)) + (progn (setq trailing nil) + (list str)) + (collect ((substrings)) + (do* () + ((= i n) (substrings)) + (let* ((pos (position #\: str :start i))) + (unless pos + (break "Huh?")) + (substrings (subseq str i pos)) + (setq i (1+ pos))))))) + (split + (mapcar #'(lambda (s) + (collapse-prefix + (split-if #'(lambda (ch) + (or (upper-case-p ch) (digit-char-p ch))) + s))) + + subs)) + (namelen (+ (if trailing (length split) 0) + (let* ((c 0)) + (dolist (s split c) + (if s (incf c (1- (length s)))))) + (let* ((c 0)) + (dolist (s split c) + (dolist (sub s) + (incf c (length sub))))))) + (name (make-string namelen))) + (declare (dynamic-extent name)) + (let* ((p 0)) + (flet ((out-ch (ch) + (setf (schar name p) ch) + (incf p))) + (dolist (sub split) + (when sub + (do* ((string (pop sub) (pop sub))) + ((null string)) + (dotimes (i (length string)) + (out-ch (char-upcase (schar string i)))) + (when sub + (out-ch #\-)))) + (when trailing (out-ch *objc-colon-replacement-character*))))) + (values + (or (find-symbol name package) + (intern (copy-seq name) package)))))) + + +;;; Convert a Lisp list of keywords into an ObjC method selector string +;;; Example: (:next-event-matching-mask :until-date :in-mode :dequeue) ==> +;;; "nextEventMatchingMask:untilDate:inMode:dequeue:" + +(defun compute-lisp-to-objc-message (klist) + (flet ((objcify (sym) + (apply + #'string-cat + (loop for str in (split-if-char #\- (string sym) :elide) + for first-word-flag = t then nil + for e = (member str *special-objc-words* + :test #'equal + :key #'string-upcase) + collect + (cond (e (first e)) + (first-word-flag (string-downcase str)) + (t (string-capitalize str))))))) + (if (and (= (length klist) 1) + (neq (symbol-package (first klist)) (find-package :keyword))) + (objcify (first klist)) + (apply #'string-cat + (mapcar #'(lambda (sym) (string-cat (objcify sym) ":")) klist))))) + + +;;; Convert an ObjC initializer to a list of corresponding initargs, +;;; stripping off any initial "init" +;;; Example: "initWithCString:length:" ==> (:with-c-string :length) + +(defun compute-objc-to-lisp-init (init) + (cond + ((= (length init) 0) nil) + ((and (> (length init) 3) (string= init "init" :start1 0 :end1 4)) + (mapcar #'(lambda (s) (compute-lisp-name s (find-package "KEYWORD"))) + (split-if-char #\: (subseq init 4 (length init)) :elide))) + (t (error "~S is not a valid initializer" init)))) + + +;;; Convert a list of initargs into an ObjC initilizer, adding an "init" +;;; prefix if necessary +;;; Example: (:with-c-string :length) ==> "initWithCString:length:" + +(defun compute-lisp-to-objc-init (initargs) + (if (null initargs) + "init" + (let ((str (compute-lisp-to-objc-message initargs))) + (if (string/= (first (split-if-char #\- (string (first initargs)))) + "INIT") + (string-cat "init" (nstring-upcase str :start 0 :end 1)) + str)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Class Name Translation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Hash tables for caching class name translations + +(defvar *lisp-classname-table* (make-hash-table :test #'equal)) +(defvar *objc-classname-table* (make-hash-table :test #'eq)) + + +;;; Define a hard-wired ObjC class name translation (if the automatic +;;; translation doesn't apply) + +(defmacro define-classname-translation (str sym) + (let ((str-temp (gensym)) + (sym-temp (gensym)) + (old-str-temp (gensym)) + (old-sym-temp (gensym))) + `(let* ((,str-temp ',str) + (,sym-temp ',sym) + (,old-sym-temp (gethash ,str-temp *lisp-classname-table*)) + (,old-str-temp (gethash ,sym-temp *objc-classname-table*))) + (remhash ,old-str-temp *lisp-classname-table*) + (remhash ,old-sym-temp *objc-classname-table*) + (setf (gethash ,str-temp *lisp-classname-table*) ,sym-temp) + (setf (gethash ,sym-temp *objc-classname-table*) ,str-temp) + (values)))) + + +;;; Translate an ObjC class name to a Lisp class name + +(defun objc-to-lisp-classname (str &optional (package *package*)) + (let ((sym + (or (gethash str *lisp-classname-table*) + (compute-lisp-name str package)))) + (setf (gethash sym *objc-classname-table*) str) + (setf (gethash str *lisp-classname-table*) sym))) + + +;;; Translate a Lisp class name to an ObjC class name + +(defun lisp-to-objc-classname (sym) + (let ((str + (or (gethash sym *objc-classname-table*) + (compute-objc-classname sym)))) + (setf (gethash str *lisp-classname-table*) sym) + (setf (gethash sym *objc-classname-table*) str))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Message Keyword Translation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Hash tables for caching initializer translations + +(defvar *lisp-message-table* (make-hash-table :test #'equal)) +(defvar *objc-message-table* (make-hash-table :test #'equal)) + + +;;; Define a hard-wired message-keyword translation (if the automatic +;;; translation doesn't apply) + +(defmacro define-message-translation (message msg-keywords) + (let ((message-temp (gensym)) + (msg-keywords-temp (gensym)) + (old-message-temp (gensym)) + (old-msg-keywords-temp (gensym))) + `(let* ((,message-temp ',message) + (,msg-keywords-temp ',msg-keywords) + (,old-message-temp + (gethash ,message-temp *lisp-message-table*)) + (,old-msg-keywords-temp + (gethash ,msg-keywords-temp *objc-message-table*))) + (remhash ,old-message-temp *lisp-message-table*) + (remhash ,old-msg-keywords-temp *objc-message-table*) + (setf (gethash ,message-temp *lisp-message-table*) ,msg-keywords-temp) + (setf (gethash ,msg-keywords-temp *objc-message-table*) ,message-temp) + (values)))) + + +;;; Translate an ObjC message to a list of Lisp message keywords + +(defun objc-to-lisp-message (message) + (let ((msg-keywords + (or (gethash message *lisp-message-table*) + (compute-objc-to-lisp-message message)))) + (setf (gethash msg-keywords *objc-message-table*) message) + (setf (gethash message *lisp-message-table*) msg-keywords))) + + +;;; Translate a set of Lisp message keywords to an ObjC message + +(defun lisp-to-objc-message (msg-keywords) + (let ((message + (or (gethash msg-keywords *objc-message-table*) + (compute-lisp-to-objc-message msg-keywords)))) + (setf (gethash message *lisp-message-table*) msg-keywords) + (setf (gethash msg-keywords *objc-message-table*) message))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Initializer Translation ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Hash tables for caching initializer translations + +(defvar *lisp-initializer-table* (make-hash-table :test #'equal)) +(defvar *objc-initializer-table* (make-hash-table :test #'equal)) + + +;;; Define a hard-wired init-keyword translation (if the automatic +;;; translation doesn't apply) + +(defmacro define-init-translation (initmsg initargs) + (let ((initmsg-temp (gensym)) + (initargs-temp (gensym)) + (old-initmsg-temp (gensym)) + (old-initargs-temp (gensym))) + `(let* ((,initmsg-temp ',initmsg) + (,initargs-temp ',initargs) + (,old-initmsg-temp + (gethash ,initmsg-temp *lisp-initializer-table*)) + (,old-initargs-temp + (gethash ,initargs-temp *objc-initializer-table*))) + (remhash ,old-initmsg-temp *lisp-initializer-table*) + (remhash ,old-initargs-temp *objc-initializer-table*) + (setf (gethash ,initmsg-temp *lisp-initializer-table*) ,initargs-temp) + (setf (gethash ,initargs-temp *objc-initializer-table*) ,initmsg-temp) + (values)))) + + +;;; Translate an ObjC initializer to a list of Lisp initargs + +(defun objc-to-lisp-init (initmsg) + (let ((initargs + (or (gethash initmsg *lisp-initializer-table*) + (compute-objc-to-lisp-init initmsg)))) + (setf (gethash initargs *objc-initializer-table*) initmsg) + (setf (gethash initmsg *lisp-initializer-table*) initargs))) + + +;;; Translate a set of Lisp initargs to an ObjC initializer + +(defun lisp-to-objc-init (initargs) + (let ((initmsg + (or (gethash initargs *objc-initializer-table*) + (compute-lisp-to-objc-init initargs)))) + (setf (gethash initmsg *lisp-initializer-table*) initargs) + (setf (gethash initargs *objc-initializer-table*) initmsg))) Index: /branches/experimentation/later/source/objc-bridge/objc-clos.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/objc-clos.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/objc-clos.lisp (revision 8058) @@ -0,0 +1,921 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2003-2004 Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;;; +;;; TO DO +;;; - Both method creation and invocation should be faster and cons less +;;; - Resolve messages with repeated keywords +;;; (rename them to :range1:range2 or don't use &key in GFs and methods) +;;; - How to integrate SEND-SUPER with CALL-NEXT-METHOD? +;;; - Variable arity ObjC methods +;;; - Pass-by-ref structures need to keep track of IN, OUT, IN/OUT info +;;; - Need to canonicalize and retain every returned :ID +;;; - Support :BEFORE, :AFTER and :AROUND for ObjC methods +;;; - User-defined ObjC methods via DEFMETHOD (or DEFINE-OBJ-METHOD) +;;; - Need to fully handle init keywords and ObjC init messages + +;;; Package and module stuff + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + #+apple-objc + (use-interface-dir :cocoa) + #+gnu-objc + (use-interface-dir :gnustep)) + +;;; We need OBJC-FOREIGN-ARG-TYPE from the bridge to process ivar types + +(require "BRIDGE") + + +(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore. Note that this may exacerbate compatibility problems.") + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Testing ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Enable some debugging output. +(defparameter *objc-clos-debug* nil) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; OBJC Foreign Object Domain ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconstant objc-type-flags (byte 3 20)) +(defconstant objc-type-index (byte 20 0)) +(defconstant objc-flag-instance 0) +(defconstant objc-flag-class 1) +(defconstant objc-flag-metaclass 2) + +(defvar *objc-class-class*) +(defvar *objc-metaclass-class*) + +(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql)) +(defvar *objc-canonical-instances* (make-hash-table :test #'eql :weak :value)) + +(defun raw-macptr-for-instance (instance) + (let* ((p (%null-ptr))) + (%set-macptr-domain p 1) ; not an ObjC object, but EQL to one + (%setf-macptr p instance) + p)) + +(defun register-canonical-objc-instance (instance raw-ptr) + ;(terminate-when-unreachable instance) + ;(retain-objc-instance instance) + (setf (gethash raw-ptr *objc-canonical-instances*) instance)) + +(defun canonicalize-objc-instance (instance) + (or (gethash instance *objc-canonical-instances*) + (register-canonical-objc-instance + (setq instance (%inc-ptr instance 0)) + (raw-macptr-for-instance instance)))) + + +(defun recognize-objc-object (p) + (labels ((recognize (p mapped) + (let* ((idx (objc-class-id p))) + (if idx + (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx)) + (if (setq idx (objc-metaclass-id p)) + (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx)) + (if (setq idx (%objc-instance-class-index p)) + (%set-macptr-type p idx) + (unless mapped + (if (maybe-map-objc-classes) + (recognize p t))))))))) + (recognize p nil))) + +(defun release-canonical-nsobject (object) + object) + + + +(defun %objc-domain-class-of (p) + (let* ((type (%macptr-type p)) + (flags (ldb objc-type-flags type)) + (index (ldb objc-type-index type))) + (declare (fixnum type flags index)) + (ecase flags + (#.objc-flag-instance (id->objc-class index)) + (#.objc-flag-class (objc-class-id->objc-metaclass index)) + (#.objc-flag-metaclass *objc-metaclass-class*)))) + +(defun %objc-domain-classp (p) + (let* ((type (%macptr-type p)) + (flags (ldb objc-type-flags type))) + (declare (fixnum type flags)) + (not (= flags objc-flag-instance)))) + +(defun %objc-domain-instance-class-wrapper (p) + (let* ((type (%macptr-type p)) + (flags (ldb objc-type-flags type)) + (index (ldb objc-type-index type))) + (declare (fixnum type flags index)) + (ecase flags + (#.objc-flag-instance (id->objc-class-wrapper index)) + (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index))) + (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*))))) + +(defun %objc-domain-class-own-wrapper (p) + (let* ((type (%macptr-type p)) + (flags (ldb objc-type-flags type)) + (index (ldb objc-type-index type))) + (declare (fixnum type flags index)) + (ecase flags + (#.objc-flag-instance nil) + (#.objc-flag-class (id->objc-class-wrapper index)) + (#.objc-flag-metaclass (id->objc-metaclass-wrapper index))))) + +(defun %objc-domain-slots-vector (p) + (let* ((type (%macptr-type p)) + (flags (ldb objc-type-flags type)) + (index (ldb objc-type-index type))) + (declare (fixnum type flags index)) + (ecase flags + (#.objc-flag-instance (or (gethash p *objc-object-slot-vectors*) + ; try to allocate the slot vector on demand + (let* ((raw-ptr (raw-macptr-for-instance p)) + (slot-vector (create-foreign-instance-slot-vector (class-of p)))) + (when slot-vector + (setf (slot-vector.instance slot-vector) raw-ptr) + (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector) + (register-canonical-objc-instance p raw-ptr) + (initialize-instance p)) + slot-vector) + (error "~s has no slots." p))) + (#.objc-flag-class (id->objc-class-slots-vector index)) + (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index))))) + +(defloadvar *objc-object-domain* + (register-foreign-object-domain :objc + :recognize #'recognize-objc-object + :class-of #'%objc-domain-class-of + :classp #'%objc-domain-classp + :instance-class-wrapper + #'%objc-domain-instance-class-wrapper + :class-own-wrapper + #'%objc-domain-class-own-wrapper + :slots-vector #'%objc-domain-slots-vector)) + +;;; P is known to be a (possibly null!) instance of some ObjC class. +(defun %set-objc-instance-type (p) + (unless (%null-ptr-p p) + (let* ((parent (pref p :objc_object.isa)) + (id (objc-class-id parent))) + (when id + (%set-macptr-domain p *objc-object-domain*) + (%set-macptr-type p id))))) + +;;; P is known to be of type :ID. It may be null. +(defun %set-objc-id-type (p) + (let* ((idx (objc-class-id p))) + (if idx + (progn + (%set-macptr-domain p *objc-object-domain*) + (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))) + (if (setq idx (objc-metaclass-id p)) + (progn + (%set-macptr-domain p *objc-object-domain*) + (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))) + (%set-objc-instance-type p))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; ObjC Objects, Classes and Metaclasses ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass objc:objc-object (foreign-standard-object) + ()) + +;;; "Real" OBJC-CLASSes and OBJC-METACLASSEs are subtypes of this +;;; abstract class. We need to keep track of those classes that're +;;; implemented in lisp separately (so that they can be restored after +;;; SAVE-APPLICATION). + +(defclass objc:objc-class-object (foreign-class objc:objc-object) + ((foreign :initform nil :initarg :foreign) + (peer :initform nil :initarg :peer))) + +(defclass objc:objc-metaclass (objc:objc-class-object) + ()) + +(setq *objc-metaclass-class* (find-class 'objc:objc-metaclass)) + +(defclass objc:objc-class (objc:objc-class-object) + ()) + +(setq *objc-class-class* (find-class 'objc:objc-class)) + +(defmethod objc-metaclass-p ((c class)) + nil) + +(defmethod objc-metaclass-p ((c objc:objc-class-object)) + (%objc-metaclass-p c)) + + +(defmethod print-object ((c objc:objc-class) stream) + (print-unreadable-object (c stream) + (format stream "~s ~:[~;[MetaClass] ~]~s (#x~x)" + 'objc:objc-class + (objc-metaclass-p c) + (if (slot-boundp c 'name) + (class-name c) + "") + (%ptr-to-int c)))) + +(defmethod print-object ((c objc:objc-metaclass) stream) + (print-unreadable-object (c stream) + (format stream "~s ~s (#x~x)" + 'objc:objc-metaclass + (if (slot-boundp c 'name) + (class-name c) + "") + (%ptr-to-int c)))) + +(defmethod print-object ((o objc:objc-object) stream) + (if (objc-object-p o) + (print-unreadable-object (o stream :type t) + (format stream + (if (typep o 'ns::ns-string) + "~s (#x~x)" + "~a (#x~x)") + (nsobject-description o) (%ptr-to-int o))) + (format stream "#" (%ptr-to-int o)))) + + + + + + +(defun make-objc-class-object-slots-vector (class meta) + (let* ((n (1+ (length (extract-instance-effective-slotds meta)))) + (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker)))) + (setf (slot-vector.instance slots) class) + slots)) + +(defun make-objc-metaclass-slots-vector (metaclass) + (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*)) + +(defun make-objc-class-slots-vector (class) + (make-objc-class-object-slots-vector class *objc-class-class*)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Slot Protocol ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Accessing Lisp slots + +(defmethod slot-boundp-using-class ((class objc:objc-class-object) + instance + (slotd standard-effective-slot-definition)) + (%std-slot-vector-boundp (%objc-domain-slots-vector instance) slotd)) + +(defmethod slot-value-using-class ((class objc:objc-class-object) + instance + (slotd standard-effective-slot-definition)) + (%std-slot-vector-value (%objc-domain-slots-vector instance) slotd)) + +(defmethod (setf slot-value-using-class) + (new + (class objc:objc-class-object) + instance + (slotd standard-effective-slot-definition)) + (%set-std-slot-vector-value (%objc-domain-slots-vector instance) slotd new)) + + +;;; Metaclasses for foreign slots + +(defclass foreign-direct-slot-definition (direct-slot-definition) + ((foreign-type :initform :id :accessor foreign-slot-definition-foreign-type) + (bit-offset :initarg :bit-offset + :initform nil + :accessor foreign-direct-slot-definition-bit-offset + :documentation "A bit-offset, relative to the start of the + instance's slots. The corresponding effective slot definition's + offset is strictly determined by this value"))) + +(defmethod shared-initialize :after ((slotd foreign-direct-slot-definition) + slot-names + &key (foreign-type :id)) + (declare (ignore slot-names)) + (unless (typep foreign-type 'foreign-type) + (setq foreign-type (parse-foreign-type foreign-type))) + (setf (foreign-slot-definition-foreign-type slotd) foreign-type)) + + +(defclass foreign-effective-slot-definition (effective-slot-definition) + ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type) + (getter :type function :accessor foreign-slot-definition-getter) + (setter :type function :accessor foreign-slot-definition-setter))) + + +;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute +;; + +(defmethod direct-slot-definition-class ((class objc:objc-class-object) + &rest initargs) + (if (getf initargs :foreign-type) + (find-class 'foreign-direct-slot-definition) + (find-class 'standard-direct-slot-definition))) + +(defmethod effective-slot-definition-class ((class objc:objc-class-object) + &rest initargs) + (if (getf initargs :foreign-type) + (find-class 'foreign-effective-slot-definition) + (find-class 'standard-effective-slot-definition))) + + +(defun set-objc-foreign-direct-slot-offsets (dslotds bit-offset) + (dolist (d dslotds) + (let* ((ftype (foreign-slot-definition-foreign-type d)) + (type-alignment (progn (ensure-foreign-type-bits ftype) + (foreign-type-alignment ftype)))) + (setf (foreign-direct-slot-definition-bit-offset d) + (setq bit-offset + (align-offset bit-offset type-alignment))) + (setq bit-offset (+ bit-offset (foreign-type-bits ftype)))))) + +(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class)) + #-apple-objc-2.0 + (let* ((foreign-dslotds + (loop for d in dslotds + when (typep d 'foreign-direct-slot-definition) + collect d)) + (bit-offset (dolist (c (class-direct-superclasses class) 0) + (when (typep c 'objc::objc-class) + (return + (ash (%objc-class-instance-size c) + 3)))))) + (unless + (dolist (d foreign-dslotds t) + (if (not (foreign-direct-slot-definition-bit-offset d)) + (return nil))) + (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset))) + #+apple-objc-2.0 + ;; Add ivars for each foreign direct slot, then ask the runtime for + ;; the ivar's byte offset. (Note that the ObjC 2.0 ivar initialization + ;; protocol doesn't seem to offer support for bitfield-valued ivars.) + (dolist (dslotd dslotds) + (when (typep dslotd 'foreign-direct-slot-definition) + (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) + (type (foreign-slot-definition-foreign-type dslotd)) + (encoding (progn + (ensure-foreign-type-bits type) + (encode-objc-type type))) + (size (ceiling (foreign-type-bits type) 8)) + (align (round (log (ceiling (foreign-type-alignment type) 8) 2)))) + (with-cstrs ((name string) + (encoding encoding)) + (#_class_addIvar class name size align encoding) + (with-macptrs ((ivar (#_class_getInstanceVariable class name))) + (unless (%null-ptr-p ivar) + (let* ((offset (#_ivar_getOffset ivar))) + (setf (foreign-direct-slot-definition-bit-offset dslotd) + (ash offset 3)))))))))) + + +#+apple-objc-2.0 +(defun %revive-foreign-slots (class) + (dolist (dslotd (class-direct-slots class)) + (when (typep dslotd 'foreign-direct-slot-definition) + (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) + (type (foreign-slot-definition-foreign-type dslotd)) + (encoding (progn + (ensure-foreign-type-bits type) + (encode-objc-type type))) + (size (ceiling (foreign-type-bits type) 8)) + (align (round (log (ceiling (foreign-type-alignment type) 8) 2)))) + (with-cstrs ((name string) + (encoding encoding)) + (#_class_addIvar class name size align encoding) + (with-macptrs ((ivar (#_class_getInstanceVariable class name))) + (unless (%null-ptr-p ivar) + (let* ((offset (#_ivar_getOffset ivar))) + (unless (eql (foreign-direct-slot-definition-bit-offset dslotd) + (ash offset 3)) + (dbg)))))))))) + +(defun lisp-defined-slot-name-to-objc-slot-name (lisp-name) + (lisp-to-objc-message (list lisp-name))) + +;;; This is only going to be called on a class created by the user; +;;; each foreign direct slotd's offset field should already have been +;;; set to the slot's bit offset. +#-apple-objc-2.0 +(defun %make-objc-ivars (class) + (let* ((start-offset (superclass-instance-size class)) + (foreign-dslotds (loop for s in (class-direct-slots class) + when (typep s 'foreign-direct-slot-definition) + collect s))) + (if (null foreign-dslotds) + (values (%null-ptr) start-offset) + (let* ((n (length foreign-dslotds)) + (offset start-offset) + (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size + :objc_ivar :bytes)))))) + (setf (pref ivars :objc_ivar_list.ivar_count) n) + (do* ((l foreign-dslotds (cdr l)) + (dslotd (car l) (car l)) + (ivar (pref ivars :objc_ivar_list.ivar_list) + (%inc-ptr ivar (%foreign-type-or-record-size + :objc_ivar :bytes)))) + ((null l) (values ivars (ash (align-offset offset 32) 3))) + (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd))) + (type (foreign-slot-definition-foreign-type dslotd)) + (encoding (progn + (ensure-foreign-type-bits type) + (encode-objc-type type)))) + (setq offset (foreign-direct-slot-definition-bit-offset dslotd)) + (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string) + (pref ivar :objc_ivar.ivar_type) (make-cstring encoding) + (pref ivar :objc_ivar.ivar_offset) (ash offset -3)) + (incf offset (foreign-type-bits type)))))))) + + + +(defun %objc-ivar-offset-in-class (name c) + ;; If C is a non-null ObjC class that contains an instance variable + ;; named NAME, return that instance variable's offset, else return + ;; NIL. + #+apple-objc-2.0 + (with-cstrs ((name name)) + (with-macptrs ((ivar (#_class_getInstanceVariable c name))) + (unless (%null-ptr-p ivar) + (#_ivar_getOffset ivar)))) + #-apple-objc-2.0 + (when (objc-class-p c) + (with-macptrs ((ivars (pref c :objc_class.ivars))) + (unless (%null-ptr-p ivars) + (loop with n = (pref ivars :objc_ivar_list.ivar_count) + for i from 1 to n + for ivar = (pref ivars :objc_ivar_list.ivar_list) + then (%inc-ptr ivar (record-length :objc_ivar)) + when (string= name (%get-cstring (pref ivar :objc_ivar.ivar_name))) + do (return-from %objc-ivar-offset-in-class (pref ivar :objc_ivar.ivar_offset))))))) + +(defun %objc-ivar-offset (name c) + (labels ((locate-objc-slot (name class) + (unless (%null-ptr-p class) + (or (%objc-ivar-offset-in-class name class) + (with-macptrs ((super #+apple-objc-2.0 + (#_class_getSuperclass class) + #-apple-objc-2.0 + (pref class :objc_class.super_class))) + (unless (or (%null-ptr-p super) (eql super class)) + (locate-objc-slot name super))))))) + (when (objc-class-p c) + (or (locate-objc-slot name c) + (error "No ObjC instance variable named ~S in ~S" name c))))) + +;;; Maintain the class wrapper of an ObjC class or metaclass. + +(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass)) + (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper)) + +(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class)) + (setf (id->objc-class-wrapper (objc-class-id class)) wrapper)) + +;;; Return the getter and setter functions for a foreign slot +;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE + +(defun compute-foreign-slot-accessors (eslotd) + (let* ((ftype (foreign-slot-definition-foreign-type eslotd)) + (ordinal (foreign-type-ordinal ftype))) + (etypecase ftype + (foreign-integer-type + (let* ((bits (foreign-integer-type-bits ftype)) + (align (foreign-integer-type-alignment ftype)) + (signed (foreign-integer-type-signed ftype))) + (if (= bits align) + (ecase bits + (1 (values #'%get-bit #'%set-bit)) + (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte) + #'%set-byte)) + (16 (values (if signed #'%get-signed-word #'%get-unsigned-word) + #'%set-word)) + (32 (values (if signed #'%get-signed-long #'%get-unsigned-long) + #'%set-long)) + (64 (if signed + (values #'%%get-signed-longlong #'%%set-signed-longlong) + (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)))) + (values #'(lambda (ptr offset) + (%get-bitfield ptr offset bits)) + #'(lambda (ptr offset new) + (setf (%get-bitfield ptr offset bits) new)))))) + (foreign-double-float-type + (values #'%get-double-float #'%set-double-float)) + (foreign-single-float-type + (values #'%get-single-float #'%set-single-float)) + (foreign-pointer-type + (if (objc-id-type-p ftype) + (values #'%get-ptr #'%set-ptr) + (let* ((to (foreign-pointer-type-to ftype)) + (to-ordinal (if to (foreign-type-ordinal to) 0))) + (values #'(lambda (ptr offset) + (let* ((p (%null-ptr))) + (%setf-macptr p (%get-ptr ptr offset)) + (unless (%null-ptr-p p) + (%set-macptr-domain p 1) + (%set-macptr-type p to-ordinal)) + p)) + #'%set-ptr)))) + (foreign-mem-block-type + (let* ((nbytes (%foreign-type-or-record-size ftype :bytes))) + (values #'(lambda (ptr offset) + (let* ((p (%inc-ptr ptr offset))) + (%set-macptr-type p ordinal) + p)) + #'(lambda (pointer offset new) + (setf (%composite-pointer-ref + nbytes + pointer + offset) + new)))))))) + + + +;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a +;;; method for OBJC-CLASSes that sets up foreign slot info. + +(defmethod compute-effective-slot-definition :around ((class objc:objc-class-object) + name + direct-slots) + (let* ((first (first direct-slots))) + (if (not (typep first 'foreign-direct-slot-definition)) + (call-next-method) + (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)))) + (initargs (let* ((initargs nil)) + (dolist (dslot direct-slots initargs) + (dolist (dslot-arg (%slot-definition-initargs dslot)) + (pushnew dslot-arg initargs :test #'eq))))) + (eslotd + (make-effective-slot-definition + class + :name name + :allocation :instance + :type (or (%slot-definition-type first) t) + :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)) + :foreign-type (foreign-slot-definition-foreign-type first)))) + (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd) + (setf (foreign-slot-definition-getter eslotd) getter) + (setf (foreign-slot-definition-setter eslotd) setter)) + eslotd)))) + +(defun bit-offset-to-location (bit-offset foreign-type) + (ensure-foreign-type-bits foreign-type) + (let* ((bits (foreign-type-bits foreign-type))) + (if (or (= bits 1) + (and (not (typep foreign-type 'foreign-mem-block-type)) + (not (= bits (foreign-type-alignment foreign-type))))) + bit-offset + (ash bit-offset -3)))) + +;;; Determine the location of each slot +;;; An effective slot's location is +;;; a) a function of the class's origin (superclass-instance-size) +;;; and the corresponding direct class's offset, if it's defined in the +;;; class (has a corresponding direct-slot-definition in the class) +;;; b) Exactly the same as the superclass's version's location, because +;;; of single inheritance. + +(defun determine-foreign-slot-location (class slot-name) + (or + (dolist (d (class-direct-slots class)) + (when (and (eq slot-name (slot-definition-name d)) + (typep d 'foreign-direct-slot-definition)) + (return (bit-offset-to-location + (foreign-direct-slot-definition-bit-offset d) + (foreign-slot-definition-foreign-type d ))))) + (dolist (super (class-direct-superclasses class)) + (when (typep super 'objc:objc-class) ; can be at most 1 + (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name))) + (when e (return (slot-definition-location e)))))) + (error "Can't find slot definition for ~s in ~s" slot-name class))) + + +(defmethod compute-slots :around ((class objc:objc-class-object)) + (flet ((foreign-slot-p (s) (typep s 'foreign-effective-slot-definition))) + (let* ((cpl (%class-precedence-list class)) + (slots (call-next-method)) + (instance-slots + (remove-if #'foreign-slot-p + (remove :class slots :key #'%slot-definition-allocation))) + (class-slots (remove :instance slots :key #'%slot-definition-allocation)) + (foreign-slots (remove-if-not #'foreign-slot-p slots))) + (setq instance-slots + (sort-effective-instance-slotds instance-slots class cpl)) + (when *objc-clos-debug* + (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%" + instance-slots class-slots foreign-slots)) + (loop for islot in instance-slots + for loc = 1 then (1+ loc) + do (setf (%slot-definition-location islot) loc)) + (dolist (cslot class-slots) + (setf (%slot-definition-location cslot) + (assoc (%slot-definition-name cslot) + (%class-get (%slot-definition-class cslot) :class-slots) + :test #'eq))) + (dolist (fslot foreign-slots) + (setf (%slot-definition-location fslot) + (determine-foreign-slot-location + class + (%slot-definition-name fslot)))) + (append instance-slots class-slots foreign-slots)))) + + +;;; Accessing foreign slots + +(defmethod slot-boundp-using-class ((class objc:objc-class-object) + instance + (slotd foreign-effective-slot-definition)) + (declare (ignore class instance slotd)) + ;; foreign slots are always bound + t) + +(defmethod slot-makunbound-using-class ((class objc:objc-class-object) + instance + (slotd foreign-effective-slot-definition)) + (declare (ignore instance)) + (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd))) + +(defmethod slot-value-using-class ((class objc:objc-class-object) + instance + (slotd foreign-effective-slot-definition)) + (funcall (foreign-slot-definition-getter slotd) + instance + (slot-definition-location slotd))) + +(defmethod (setf slot-value-using-class) (value + (class objc:objc-class-object) + instance + (slotd foreign-effective-slot-definition)) + (funcall (foreign-slot-definition-setter slotd) + instance + (slot-definition-location slotd) + value)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Instance Allocation and Initialization Protocols ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-instance ((class objc:objc-class-object) &rest initargs) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs))) + + +(defun remove-slot-initargs (class initargs) + (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe + (collect ((new-initargs)) + (loop for l = initargs then (cddr l) + when (null l) do (return-from remove-slot-initargs (new-initargs)) + unless (member (first l) slot-initargs :test #'eq) + do + (new-initargs (car l)) + (new-initargs (cadr l)))))) + +(defun create-foreign-instance-slot-vector (class) + (let* ((max 0)) + (dolist (slotd (class-slots class) + (unless (zerop max) + (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker)))) + (when (typep slotd 'standard-effective-slot-definition) + (let* ((loc (slot-definition-location slotd))) + (if (> loc max) + (setq max loc))))))) + + + +(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((instance + (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs + class + initargs)) + (send-objc-init-message (allocate-objc-object class) ks vs)))) + (unless (%null-ptr-p instance) + (or (gethash instance *objc-object-slot-vectors*) + (let* ((slot-vector (create-foreign-instance-slot-vector class))) + (when slot-vector + (let* ((raw-ptr (raw-macptr-for-instance instance))) + (setf (slot-vector.instance slot-vector) raw-ptr) + (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector) + (register-canonical-objc-instance instance raw-ptr)))))) + instance)) + +(defmethod terminate ((instance objc:objc-object)) + (objc-message-send instance "release")) + + + +(defmethod initialize-instance ((instance objc:objc-object) &rest initargs) + (apply #'shared-initialize instance t initargs)) + +(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs) + (apply #'shared-initialize instance nil initargs)) + +(defmethod initialize-instance :after ((class objc:objc-class) &rest initargs) + (declare (ignore initargs)) + (unless (slot-value class 'foreign) + #-apple-objc-2.0 + (multiple-value-bind (ivars instance-size) + (%make-objc-ivars class) + (%add-objc-class class ivars instance-size)) + #+apple-objc-2.0 + (%add-objc-class class))) + +(defmethod shared-initialize ((instance objc:objc-object) slot-names + &rest initargs) + (let ((class (class-of instance))) + ;; Initialize CLOS slots + (dolist (slotd (class-slots class)) + (when (not (typep slotd 'foreign-effective-slot-definition)) ; For now + (let ((sname (slot-definition-name slotd)) + (slot-type (slot-definition-type slotd)) + (typepred (slot-value slotd 'type-predicate)) + (initfunction (slot-definition-initfunction slotd))) + (multiple-value-bind (ignore newval foundp) + (get-properties initargs + (slot-definition-initargs slotd)) + (declare (ignore ignore)) + (if foundp + (if (funcall typepred newval) + (setf (slot-value instance sname) newval) + (report-bad-arg newval slot-type)) + (let* ((loc (slot-definition-location slotd)) + (curval (%standard-instance-instance-location-access + instance loc))) + (when (and (or (eq slot-names t) + (member sname slot-names :test #'eq)) + (eq curval (%slot-unbound-marker)) + initfunction) + (let ((newval (funcall initfunction))) + (unless (funcall typepred newval) + (report-bad-arg newval slot-type)) + (setf (%standard-instance-instance-location-access + instance loc) + newval))))))))) + instance)) + +(defmethod shared-initialize :after ((spec foreign-effective-slot-definition) + slot-names + &key &allow-other-keys) + (declare (ignore slot-names)) + (setf (slot-value spec 'type-predicate) #'true)) + +;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS, +;;; but not necessarily the one specified as a :metaclass option to +;;; DEFCLASS or ENSURE-CLASS. Allow an existing class to be reinitialized, +;;; as long as the specified :metaclass and the class's own class have +;;; the same metaclass and specified metaclass is a root class. + +(defmethod ensure-class-using-class ((class objc:objc-class) + name + &rest keys &key) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (let* ((existing-metaclass (class-of class))) + (if (and (eq (class-of metaclass) + (class-of existing-metaclass)) + ;; A root metaclass has the corresponding class as + ;; its superclass, and that class has no superclass. + (with-macptrs ((super #+apple-objc-2.0 + (#_class_getSuperclass metaclass) + #-apple-objc-2.0 + (pref metaclass :objc_class.super_class))) + (and (not (%null-ptr-p super)) + (not (%objc-metaclass-p super)) + (%null-ptr-p + #+apple-objc-2.0 + (#_class_getSuperclass super) + #-apple-objc-2.0 + (pref super :objc_class.super_class))))) + ;; Whew! it's ok to reinitialize the class. + (progn + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class)) + (error "Can't change metaclass of ~s to ~s." class metaclass))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Class Definition and Finalization Protocols ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Create the ObjC class/metaclass pair and dress it up in its minimal CLOS garb +;;; This currently requires that exactly one of DIRECT-SUPERCLASSES be a +;;; already existing subclass of OBJC:OBJC-CLASS + +(defun compute-objc-variable-name (sym) + (let* ((pname (string sym)) + (first-alpha (position-if #'alpha-char-p pname))) + (string-downcase + (apply #'string-cat + (mapcar #'string-capitalize (split-if-char #\- pname :elide))) + :end (if first-alpha (1+ first-alpha) 1)))) + +(defmethod allocate-instance ((metaclass objc:objc-metaclass) + &key name direct-superclasses + &allow-other-keys) + (let ((superclass + (loop for s in direct-superclasses + when (typep s 'objc:objc-class) + collect s into objc-supers + finally + (if (= (length objc-supers) 1) + (return (first objc-supers)) + (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" + direct-superclasses + (length objc-supers)))))) + (%allocate-objc-class name superclass))) + +(defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs) + (%shared-initialize class slot-names initargs)) + +(defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class)) + t) + +(defmethod make-instances-obsolete ((class objc:objc-class)) + class) + +;;; Reader/writer methods for instances of OBJC:OBJC-CLASS +(defmethod reader-method-class ((class objc:objc-class) + (dslotd direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + (find-class 'standard-reader-method)) + +(defmethod writer-method-class ((class objc:objc-class) + (dslotd direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + (find-class 'standard-writer-method)) + + +;;; By the time we see this, the slot name has been transformed to the form +;;; "(load-time-value (ensure-slot-id ))". +;;; This only works if the setter is SETF inverse of the getter. +(define-compiler-macro slot-id-value (&whole call instance slot-name &environment env) + (or + (let* ((type nil)) + (if (and (symbolp instance) + (subtypep (setq type (cdr (assq 'type (nth-value 2 (variable-information instance env))))) + 'objc:objc-object) + (consp slot-name) + (eq (car slot-name) 'load-time-value) + (consp (cdr slot-name)) + (null (cddr slot-name)) + (eq (caadr slot-name) 'ensure-slot-id) + (consp (cdadr slot-name)) + (null (cddadr slot-name)) + (setq slot-name (cadadr slot-name)) + (quoted-form-p slot-name) + (setq slot-name (cadr slot-name))) + (let* ((class (find-class type nil)) + (eslotd (when class (find slot-name (class-slots class) + :key #'slot-definition-name)))) + (when (typep eslotd 'foreign-effective-slot-definition) + (let* ((getter (foreign-slot-definition-getter eslotd)) + (name (if (typep getter 'compiled-function) + (function-name getter)))) + (when name + `(,name ,instance ,(slot-definition-location eslotd)))))))) + call)) + + Index: /branches/experimentation/later/source/objc-bridge/objc-package.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/objc-package.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/objc-package.lisp (revision 8058) @@ -0,0 +1,59 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2007 Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;;; + +(in-package "CCL") + +;;; All class names and instance variable names are interned in the NS package +;;; Force all symbols interned in the NS package to be external + +(defpackage "NS" + (:use) + (:export "+CGFLOAT-ZERO+" "CGFLOAT")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (package-force-export "NS")) + +;;; ObjC function names (as produced by #/) are interned in NSF. +(defpackage "NEXTSTEP-FUNCTIONS" + (:use) + (:nicknames "NSFUN")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (package-force-export "NSFUN")) + +(defpackage "OBJC" + (:use) + (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS" + "@CLASS" "@SELECTOR" "MAKE-OBJC-INSTANCE" "RETURNING-FOREIGN-STRUCT" + "DEFMETHOD" "SLET" "SEND" "SEND/STRET" "SEND-SUPER" "SEND-SUPER/STRET" + "DEFINE-OBJC-METHOD" "DEFINE-OBJC-CLASS-METHOD" + "OBJC-MESSAGE-SEND" "OBJC-MESSAGE-SEND-STRET" + "OBJC-MESSAGE-SEND-SUPER" "OBJC-MESSAGE-SEND-SUPER-STRET" + "LOAD-FRAMEWORK")) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import '(objc:@class objc:@selector objc:make-objc-instance + objc:send objc:send/stret objc:send-super objc:send-super/stret + ns:+cgfloat-zero+ ns:cgfloat + objc:define-objc-method objc:define-objc-class-method + objc:objc-message-send objc:objc-message-send-stret + objc:objc-message-send-super objc:objc-message-send-super-stret + ) + "CCL")) + +(provide "OBJC-PACKAGE") Index: /branches/experimentation/later/source/objc-bridge/objc-readtable.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/objc-readtable.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/objc-readtable.lisp (revision 8058) @@ -0,0 +1,65 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2002-2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + (defvar *objc-readtable* (copy-readtable nil)) + (set-syntax-from-char #\] #\) *objc-readtable*)) + + + +;;; We use the convention that [:super ....] denotes a send to the +;;; defining object's superclass's method, and that a return value +;;; specification of the form (:-> ... x) indicates a message send +;;; that returns a structure (by reference) via the pointer x. + +(set-macro-character + #\[ + (nfunction + |objc-[-reader| + (lambda (stream ignore) + (declare (ignore ignore)) + (let* ((tail (read-delimited-list #\] stream)) + (structptr nil)) + (unless *read-suppress* + (let* ((return (car (last tail)))) + (when (and (consp return) (eq (car return) :->)) + (rplaca (last tail) :void) + (setq structptr (car (last return))))) + (if (eq (car tail) :super) + (if structptr + `(objc-message-send-super-stret ,structptr (super) ,@(cdr tail)) + `(objc-message-send-super (super) ,@(cdr tail))) + (if structptr + `(objc-message-send-stret ,structptr ,@tail) + `(objc-message-send ,@tail))))))) + nil + *objc-readtable*) + +(set-dispatch-macro-character + #\# + #\@ + (nfunction + |objc-#@-reader| + (lambda (stream subchar numarg) + (declare (ignore subchar numarg)) + (let* ((string (read stream))) + (unless *read-suppress* + (check-type string string) + `(@ ,string))))) + *objc-readtable*) + Index: /branches/experimentation/later/source/objc-bridge/objc-runtime.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/objc-runtime.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/objc-runtime.lisp (revision 8058) @@ -0,0 +1,2921 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2002-2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +;;; Utilities for interacting with the Apple/GNU Objective-C runtime +;;; systems. + +(eval-when (:compile-toplevel :load-toplevel :execute) + #+darwin-target (pushnew :apple-objc *features*) + #+(and darwin-target 64-bit-target) (pushnew :apple-objc-2.0 *features*) + #-darwin-target (pushnew :gnu-objc *features*)) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (set-dispatch-macro-character + #\# + #\@ + (nfunction + |objc-#@-reader| + (lambda (stream subchar numarg) + (declare (ignore subchar numarg)) + (let* ((string (read stream))) + (unless *read-suppress* + (check-type string string) + `(@ ,string))))))) + +(eval-when (:compile-toplevel :execute) + #+apple-objc + (progn + (use-interface-dir :cocoa) + #+nomore + (use-interface-dir :carbon)) ; need :carbon for things in this file + #+gnu-objc + (use-interface-dir :gnustep)) + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "OBJC-PACKAGE") + (require "SPLAY-TREE") + (require "NAME-TRANSLATION") + (require "OBJC-CLOS")) + +;;; NSInteger and NSUInteger probably belong here. +;;; CGFloat not so much. + +#-apple-objc-2.0 +(progn + (def-foreign-type :loat :float) + (def-foreign-type :nteger :unsigned) + (def-foreign-type :nteger :signed) + ) + +(defconstant +cgfloat-zero+ + #+(and apple-objc-2.0 64-bit-target) 0.0d0 + #-(and apple-objc-2.0 64-bit-target) 0.0f0) + +(deftype cgfloat () + #+(and apple-objc-2.0 64-bit-target) 'double-float + #-(and apple-objc-2.0 64-bit-target) 'single-float) + +(deftype cg-float () 'cgfloat) + +(deftype nsuinteger () + #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64) + #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32)) + +(deftype nsinteger () + #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64) + #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32)) + + +(defloadvar *NSApp* nil ) + +;;; Apple ObjC 2.0 provides (#_objc_getProtocol name). In other +;;; runtimes, there doesn't seem to be any way to find a Protocol +;;; object given its name. We need to be able to ask at runtime +;;; whether a given object conforms to a protocol in order to +;;; know when a protocol method is ambiguous, at least when the +;;; message contains ambiguous methods and some methods are protocol +;;; methods +(defvar *objc-protocols* (make-hash-table :test #'equal)) + + +(defstruct objc-protocol + name + address) + + +(defun clear-objc-protocols () + (maphash #'(lambda (name proto) + (declare (ignore name)) + (setf (objc-protocol-address proto) nil)) + *objc-protocols*)) + +(defun lookup-objc-protocol (name) + (values (gethash name *objc-protocols*))) + +(defun ensure-objc-classptr-resolved (classptr) + #+apple-objc (declare (ignore classptr)) + #+gnu-objc + (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info)) + (external-call "__objc_resolve_class_links" :void))) + + + +(defstruct private-objc-class-info + name + declared-ancestor) + +(defun compute-objc-direct-slots-from-info (info class) + (let* ((ns-package (find-package "NS"))) + (mapcar #'(lambda (field) + (let* ((name (compute-lisp-name (unescape-foreign-name + (foreign-record-field-name + field)) + ns-package)) + + (type (foreign-record-field-type field)) + (offset (progn + (ensure-foreign-type-bits type) + (foreign-record-field-offset field)))) + (make-instance 'foreign-direct-slot-definition + :initfunction #'false + :initform nil + :name name + :foreign-type type + :class class + :bit-offset offset + :allocation :instance))) + (db-objc-class-info-ivars info)))) + + +(defun %ptr< (x y) + (< (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32) + (%ptr-to-int x)) + (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32) + (%ptr-to-int Y)))) + +(let* ((objc-class-map (make-splay-tree #'%ptr-eql #'%ptr<)) + (objc-metaclass-map (make-splay-tree #'%ptr-eql #'%ptr<)) + ;;; These are NOT lisp classes; we mostly want to keep track + ;;; of them so that we can pretend that instances of them + ;;; are instances of some known (declared) superclass. + (private-objc-classes (make-splay-tree #'%ptr-eql #'%ptr<)) + (objc-class-lock (make-lock)) + (next-objc-class-id 0) + (next-objc-metaclass-id 0) + (class-table-size 1024) + (c (make-array class-table-size)) + (m (make-array class-table-size)) + (cw (make-array 1024 :initial-element nil)) + (mw (make-array 1024 :initial-element nil)) + (csv (make-array 1024)) + (msv (make-array 1024)) + (class-id->metaclass-id (make-array 1024 :initial-element nil)) + (class-foreign-names (make-array 1024)) + (metaclass-foreign-names (make-array 1024)) + ) + + (flet ((grow-vectors () + (let* ((old-size class-table-size) + (new-size (* 2 old-size))) + (declare (fixnum old-size new-size)) + (macrolet ((extend (v) + `(setq ,v (%extend-vector old-size ,v new-size)))) + (extend c) + (extend m) + (extend cw) + (extend mw) + (fill cw nil :start old-size :end new-size) + (fill mw nil :start old-size :end new-size) + (extend csv) + (extend msv) + (extend class-id->metaclass-id) + (fill class-id->metaclass-id nil :start old-size :end new-size) + (extend class-foreign-names) + (extend metaclass-foreign-names)) + (setq class-table-size new-size)))) + (flet ((assign-next-class-id () + (let* ((id next-objc-class-id)) + (if (= (incf next-objc-class-id) class-table-size) + (grow-vectors)) + id)) + (assign-next-metaclass-id () + (let* ((id next-objc-metaclass-id)) + (if (= (incf next-objc-metaclass-id) class-table-size) + (grow-vectors)) + id))) + (defun id->objc-class (i) + (svref c i)) + (defun (setf id->objc-class) (new i) + (setf (svref c i) new)) + (defun id->objc-metaclass (i) + (svref m i)) + (defun (setf id->objc-metaclass) (new i) + (setf (svref m i) new)) + (defun id->objc-class-wrapper (i) + (svref cw i)) + (defun (setf id->objc-class-wrapper) (new i) + (setf (svref cw i) new)) + (defun id->objc-metaclass-wrapper (i) + (svref mw i)) + (defun (setf id->objc-metaclass-wrapper) (new i) + (setf (svref mw i) new)) + (defun id->objc-class-slots-vector (i) + (svref csv i)) + (defun (setf id->objc-class-slots-vector) (new i) + (setf (svref csv i) new)) + (defun id->objc-metaclass-slots-vector (i) + (svref msv i)) + (defun (setf id->objc-metaclass-slots-vector) (new i) + (setf (svref msv i) new)) + (defun objc-class-id-foreign-name (i) + (svref class-foreign-names i)) + (defun (setf objc-class-id-foreign-name) (new i) + (setf (svref class-foreign-names i) new)) + (defun objc-metaclass-id-foreign-name (i) + (svref metaclass-foreign-names i)) + (defun (setf objc-metaclass-id-foreign-name) (new i) + (setf (svref metaclass-foreign-names i) new)) + (defun %clear-objc-class-maps () + (with-lock-grabbed (objc-class-lock) + (setf (splay-tree-root objc-class-map) nil + (splay-tree-root objc-metaclass-map) nil + (splay-tree-root private-objc-classes) nil + (splay-tree-count objc-class-map) 0 + (splay-tree-count objc-metaclass-map) 0 + (splay-tree-count private-objc-classes) 0))) + (flet ((install-objc-metaclass (meta) + (or (splay-tree-get objc-metaclass-map meta) + (let* ((id (assign-next-metaclass-id)) + (meta (%inc-ptr meta 0))) + (splay-tree-put objc-metaclass-map meta id) + (setf (svref m id) meta + (svref msv id) + (make-objc-metaclass-slots-vector meta)) + id)))) + (defun register-objc-class (class) + "ensure that the class is mapped to a small integer and associate a slots-vector with it." + (with-lock-grabbed (objc-class-lock) + (ensure-objc-classptr-resolved class) + (or (splay-tree-get objc-class-map class) + (let* ((id (assign-next-class-id)) + (class (%inc-ptr class 0)) + (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer))) + (splay-tree-put objc-class-map class id) + (setf (svref c id) class + (svref csv id) + (make-objc-class-slots-vector class) + (svref class-id->metaclass-id id) + (install-objc-metaclass meta)) + id))))) + (defun objc-class-id (class) + (with-lock-grabbed (objc-class-lock) + (splay-tree-get objc-class-map class))) + (defun objc-metaclass-id (meta) + (with-lock-grabbed (objc-class-lock) + (splay-tree-get objc-metaclass-map meta))) + (defun objc-class-id->objc-metaclass-id (class-id) + (svref class-id->metaclass-id class-id)) + (defun objc-class-id->objc-metaclass (class-id) + (svref m (svref class-id->metaclass-id class-id))) + (defun objc-class-map () objc-class-map) + (defun %objc-class-count () next-objc-class-id) + (defun objc-metaclass-map () objc-metaclass-map) + (defun %objc-metaclass-count () next-objc-metaclass-id) + (defun %register-private-objc-class (c name) + (splay-tree-put private-objc-classes c (make-private-objc-class-info :name name))) + (defun %get-private-objc-class (c) + (splay-tree-get private-objc-classes c)) + (defun (setf %get-private-objc-class) (public c) + (let* ((node (binary-tree-get private-objc-classes c))) + (if node + (setf (tree-node-value node) public) + (error "Private class ~s not found" c)))) + (defun private-objc-classes () + private-objc-classes)))) + +(pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq + :key #'function-name) + +(defun do-all-objc-classes (f) + (map-splay-tree (objc-class-map) #'(lambda (id) + (funcall f (id->objc-class id))))) + +(defun canonicalize-registered-class (c) + (let* ((id (objc-class-id c))) + (if id + (id->objc-class id) + (error "Class ~S isn't recognized." c)))) + +(defun canonicalize-registered-metaclass (m) + (let* ((id (objc-metaclass-id m))) + (if id + (id->objc-metaclass id) + (error "Class ~S isn't recognized." m)))) + +(defun canonicalize-registered-class-or-metaclass (x) + (if (%objc-metaclass-p x) + (canonicalize-registered-metaclass x) + (canonicalize-registered-class x))) + + +;;; Open shared libs. +#+darwin-target +(progn +(defloadvar *cocoa-event-process* *initial-process*) + + +(defun current-ns-thread () + (with-cstrs ((class-name "NSThread") + (message-selector-name "currentThread")) + (let* ((nsthread-class (#_objc_lookUpClass class-name)) + (message-selector (#_sel_getUid message-selector-name))) + (#_objc_msgSend nsthread-class message-selector) + nil))) + +(defun create-void-nsthread () + ;; Create an NSThread which does nothing but exit. + ;; This'll help to convince the AppKit that we're + ;; multitheaded. (A lot of other things, including + ;; the ObjC runtime, seem to have already noticed.) + (with-cstrs ((thread-class-name "NSThread") + (pool-class-name "NSAutoreleasePool") + (thread-message-selector-name "detachNewThreadSelector:toTarget:withObject:") + (exit-selector-name "exit") + (alloc-selector-name "alloc") + (init-selector-name "init") + (release-selector-name "release")) + (let* ((nsthread-class (#_objc_lookUpClass thread-class-name)) + (pool-class (#_objc_lookUpClass pool-class-name)) + (thread-message-selector (#_sel_getUid thread-message-selector-name)) + (exit-selector (#_sel_getUid exit-selector-name)) + (alloc-selector (#_sel_getUid alloc-selector-name)) + (init-selector (#_sel_getUid init-selector-name)) + (release-selector (#_sel_getUid release-selector-name)) + (pool (#_objc_msgSend + (#_objc_msgSend pool-class + alloc-selector) + init-selector))) + (unwind-protect + (#_objc_msgSend nsthread-class thread-message-selector + :address exit-selector + :address nsthread-class + :address (%null-ptr)) + (#_objc_msgSend pool release-selector)) + nil))) + +(defun run-in-cocoa-process-and-wait (f) + (let* ((process *cocoa-event-process*) + (success (cons nil nil)) + (done (make-semaphore))) + (process-interrupt process #'(lambda () + (unwind-protect + (progn + (setf (car success) (funcall f))) + (signal-semaphore done)))) + (wait-on-semaphore done) + (car success))) + + +(def-ccl-pointers cocoa-framework () + (run-in-cocoa-process-and-wait + #'(lambda () + ;; We need to load and "initialize" the CoreFoundation library + ;; in the thread that's going to process events. Looking up a + ;; symbol in the library should cause it to be initialized + (open-shared-library "/System/Library/Frameworks/Cocoa.framework/Cocoa") + ;(#_GetCurrentEventQueue) + (current-ns-thread) + (create-void-nsthread)))) + + +(defun find-cfstring-sections () + (warn "~s is obsolete" 'find-cfstring-sections)) + +) + +#+gnu-objc +(progn +(defparameter *gnustep-system-root* "/usr/GNUstep/" "The root of all evil.") +(defparameter *gnustep-libraries-pathname* + (merge-pathnames "System/Library/Libraries/" *gnustep-system-root*)) + +(defloadvar *pending-loaded-classes* ()) + +(defcallback register-class-callback (:address class :address category :void) + (let* ((id (map-objc-class class))) + (unless (%null-ptr-p category) + (let* ((cell (or (assoc id *pending-loaded-classes*) + (let* ((c (list id))) + (push c *pending-loaded-classes*) + c)))) + (push (%inc-ptr category 0) (cdr cell)))))) + +;;; Shouldn't really be GNU-objc-specific. + +(defun get-c-format-string (c-format-ptr c-arg-ptr) + (do* ((n 128)) + () + (declare (fixnum n)) + (%stack-block ((buf n)) + (let* ((m (#_vsnprintf buf n c-format-ptr c-arg-ptr))) + (declare (fixnum m)) + (cond ((< m 0) (return nil)) + ((< m n) (return (%get-cstring buf))) + (t (setq n m))))))) + + + +(defun init-gnustep-framework () + (or (getenv "GNUSTEP_SYSTEM_ROOT") + (setenv "GNUSTEP_SYSTEM_ROOT" *gnustep-system-root*)) + (open-shared-library "libobjc.so.1") + (setf (%get-ptr (foreign-symbol-address "_objc_load_callback")) + register-class-callback) + (open-shared-library (namestring (merge-pathnames "libgnustep-base.so" + *gnustep-libraries-pathname*))) + (open-shared-library (namestring (merge-pathnames "libgnustep-gui.so" + *gnustep-libraries-pathname*)))) + +(def-ccl-pointers gnustep-framework () + (init-gnustep-framework)) +) + +(defun get-appkit-version () + #+apple-objc + #&NSAppKitVersionNumber + #+gnu-objc + (get-foundation-version)) + +(defun get-foundation-version () + #&NSFoundationVersionNumber + #+gnu-objc (%get-cstring (foreign-symbol-address "gnustep_base_version"))) + +(defparameter *appkit-library-version-number* (get-appkit-version)) +(defparameter *foundation-library-version-number* (get-foundation-version)) + +(defparameter *extension-framework-paths* ()) + +;;; An instance of NSConstantString (which is a subclass of NSString) +;;; consists of a pointer to the NSConstantString class (which the +;;; global "_NSConstantStringClassReference" conveniently refers to), a +;;; pointer to an array of 8-bit characters (doesn't have to be #\Nul +;;; terminated, but doesn't hurt) and the length of that string (not +;;; counting any #\Nul.) +;;; The global reference to the "NSConstantString" class allows us to +;;; make instances of NSConstantString, ala the @"foo" construct in +;;; ObjC. Sure it's ugly, but it seems to be exactly what the ObjC +;;; compiler does. + + +(defloadvar *NSConstantString-class* + (with-cstrs ((name "NSConstantString")) + #+apple-objc (#_objc_lookUpClass name) + #+gnu-objc (#_objc_lookup_class name))) + + + + +#+apple-objc +(progn +;;; NSException-handling stuff. +;;; First, we have to jump through some hoops so that #_longjmp can +;;; jump through some hoops (a jmp_buf) and wind up throwing to a +;;; lisp catch tag. + +;;; These constants (offsets in the jmp_buf structure) come from +;;; the _setjmp.h header file in the Darwin LibC source. + +#+ppc32-target +(progn +(defconstant JMP-lr #x54 "link register (return address) offset in jmp_buf") +#|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|# +(defconstant JMP-sp 0 "stack pointer offset in jmp_buf") +(defconstant JMP-r14 12 "offset of r14 (which we clobber) in jmp_buf") +(defconstant JMP-r15 16 "offset of r14 (which we also clobber) in jmp_buf")) + +#+ppc64-target +(progn +(defconstant JMP-lr #xa8 "link register (return address) offset in jmp_buf") +#|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|# +(defconstant JMP-sp 0 "stack pointer offset in jmp_buf") +(defconstant JMP-r13 #x10 "offset of r13 (which we preserve) in jmp_buf") +(defconstant JMP-r14 #x18 "offset of r14 (which we clobber) in jmp_buf") +(defconstant JMP-r15 #x20 "offset of r15 (which we also clobber) in jmp_buf")) + +;;; These constants also come from Libc sources. Hey, who needs +;;; header files ? +#+x8664-target +(progn +(defconstant JB-RBX 0) +(defconstant JB-RBP 8) +(defconstant JB-RSP 16) +(defconstant JB-R12 24) +(defconstant JB-R13 32) +(defconstant JB-R14 40) +(defconstant JB-R15 48) +(defconstant JB-RIP 56) +(defconstant JB-RFLAGS 64) +(defconstant JB-MXCSR 72) +(defconstant JB-FPCONTROL 76) +(defconstant JB-MASK 80) +) + + + + +;;; A malloc'ed pointer to thre words of machine code. The first +;;; instruction copies the address of the trampoline callback from r14 +;;; to the count register. The second instruction (rather obviously) +;;; copies r15 to r4. A C function passes its second argument in r4, +;;; but since r4 isn't saved in a jmp_buf, we have to do this copy. +;;; The second instruction just jumps to the address in the count +;;; register, which is where we really wanted to go in the first +;;; place. + +#+ppc-target +(macrolet ((ppc-lap-word (instruction-form) + (uvref (uvref (compile nil + `(lambda (&lap 0) + (ppc-lap-function () ((?? 0)) + ,instruction-form))) + 0) #+ppc64-target 1 #+ppc32-target 0))) + (defloadvar *setjmp-catch-lr-code* + (let* ((p (malloc 12))) + (setf (%get-unsigned-long p 0) (ppc-lap-word (mtctr 14)) + (%get-unsigned-long p 4) (ppc-lap-word (mr 4 15)) + (%get-unsigned-long p 8) (ppc-lap-word (bctr))) + ;;; Force this code out of the data cache and into memory, so + ;;; that it'll get loaded into the icache. + (ff-call (%kernel-import #.target::kernel-import-makedataexecutable) + :address p + :unsigned-fullword 12 + :void) + p))) + +#+x8664-target +(defloadvar *setjmp-catch-rip-code* + (let* ((code-bytes '(#x4c #x89 #xe6 ; movq %r12, %rsi + #xff #xd3)) ; call *%rbx + (nbytes (length code-bytes)) + (p (malloc nbytes))) + (dotimes (i nbytes p) + (setf (%get-unsigned-byte p i) (pop code-bytes))))) + + +;;; Catch frames are allocated on a stack, so it's OK to pass their +;;; addresses around to foreign code. +(defcallback throw-to-catch-frame (:signed-fullword value + :address frame + :void) + (throw (%get-object frame target::catch-frame.catch-tag) value)) + +;;; Initialize a jmp_buf so that when it's #_longjmp-ed to, it'll +;;; wind up calling THROW-TO-CATCH-FRAME with the specified catch +;;; frame as its second argument. The C frame used here is just +;;; an empty C stack frame from which the callback will be called. + +#+ppc-target +(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) + (%set-object jmp-buf JMP-sp c-frame) + (%set-object jmp-buf JMP-r15 catch-frame) + #+ppc64-target + (%set-object jmp-buf JMP-r13 (%get-os-context)) + (setf (%get-ptr jmp-buf JMP-lr) *setjmp-catch-lr-code* + (%get-ptr jmp-buf JMP-r14) throw-to-catch-frame) + t) + +#+x8664-target +(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame) + (setf (%get-ptr jmp-buf JB-rbx) throw-to-catch-frame + (%get-ptr jmp-buf JB-rip) *setjmp-catch-rip-code*) + (setf (%get-unsigned-long jmp-buf JB-mxcsr) #x1f80 + (%get-unsigned-long jmp-buf JB-fpcontrol) #x37f) + (%set-object jmp-buf JB-RSP c-frame) + (%set-object jmp-buf JB-RBP c-frame) + (%set-object jmp-buf JB-r12 catch-frame) + t) + + +) + +;;; When starting up an image that's had ObjC classes in it, all of +;;; those canonical classes (and metaclasses) will have had their type +;;; changed (by SAVE-APPLICATION) to, CCL::DEAD-MACPTR and the addresses +;;; of those classes may be bogus. The splay trees (objc-class/metaclass-map) +;;; should be empty. +;;; For each class that -had- had an assigned ID, determine its ObjC +;;; class name, and ask ObjC where (if anywhere) the class is now. +;;; If we get a non-null answer, revive the class pointer and set its +;;; address appropriately, then add an entry to the splay tree; this +;;; means that classes that existed on both sides of SAVE-APPLICATION +;;; will retain the same ID. + +(defun revive-objc-classes () + ;; We need to do some things so that we can use (@class ...) + ;; and (@selector ...) early. + (invalidate-objc-class-descriptors) + (clear-objc-selectors) + (clear-objc-protocols) + (reset-objc-class-count) + ;; Ensure that any addon frameworks are loaded. + (dolist (path *extension-framework-paths*) + (%reload-objc-framework path)) + ;; Make a first pass over the class and metaclass tables; + ;; resolving those foreign classes that existed in the old + ;; image and still exist in the new. + (let* ((class-map (objc-class-map)) + (metaclass-map (objc-metaclass-map)) + (nclasses (%objc-class-count))) + (dotimes (i nclasses) + (let* ((c (id->objc-class i)) + (meta-id (objc-class-id->objc-metaclass-id i)) + (m (id->objc-metaclass meta-id))) + (unless (typep c 'macptr) + (%revive-macptr c) + (%setf-macptr c (%null-ptr))) + (unless (typep m 'macptr) + (%revive-macptr m) + (%setf-macptr m (%null-ptr))) + (unless (splay-tree-get class-map c) + (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c) + ;; If the class is valid and the metaclass is still + ;; unmapped, set the metaclass pointer's address and map it. + (unless (%null-ptr-p c) + (splay-tree-put class-map c i) + (unless (splay-tree-get metaclass-map m) + (%setf-macptr m (pref c #+apple-objc :objc_class.isa + #+gnu-objc :objc_class.class_pointer)) + (splay-tree-put metaclass-map m meta-id)) + (note-class-protocols c))))) + ;; Second pass: install class objects for user-defined classes, + ;; assuming the superclasses are already "revived". If the + ;; superclass is itself user-defined, it'll appear first in the + ;; class table; that's an artifact of the current implementation. + (dotimes (i nclasses) + (let* ((c (id->objc-class i))) + (when (and (%null-ptr-p c) + (not (slot-value c 'foreign))) + (let* ((super (dolist (s (class-direct-superclasses c) + (error "No ObjC superclass of ~s" c)) + (when (objc-class-p s) (return s)))) + (meta-id (objc-class-id->objc-metaclass-id i)) + (m (id->objc-metaclass meta-id))) + (let* ((class (make-objc-class-pair super (make-cstring (objc-class-id-foreign-name i)))) + (meta (pref class #+apple-objc :objc_class.isa + #+gnu-objc :objc-class.class_pointer))) + (unless (splay-tree-get metaclass-map m) + (%revive-macptr m) + (%setf-macptr m meta) + (splay-tree-put metaclass-map m meta-id)) + (%setf-macptr c class)) + #+apple-objc-2.0 + (%revive-foreign-slots c) + #+apple-objc-2.0 + (%add-objc-class c) + #-apple-objc-2.0 + (multiple-value-bind (ivars instance-size) + (%make-objc-ivars c) + (%add-objc-class c ivars instance-size)) + (splay-tree-put class-map c i))))) + ;; Finally, iterate over all classes in the runtime world. + ;; Register any class that's not found in the class map + ;; as a "private" ObjC class. + ;; Iterate over all classes in the runtime. Those that + ;; aren't already registered will get identified as + ;; "private" (undeclared) ObjC classes. + ;; Note that this means that if an application bundle + ;; was saved on (for instance) Panther and Tiger interfaces + ;; were used, and then the application is run on Tiger, any + ;; Tiger-specific classes will not be magically integrated + ;; into CLOS in the running application. + ;; A development envronment might want to provide such a + ;; mechanism; it would need access to Panther class + ;; declarations, and - in the general case - a standalone + ;; application doesn't necessarily have access to the + ;; interface database. + (map-objc-classes nil) + )) + +(pushnew #'revive-objc-classes *lisp-system-pointer-functions* + :test #'eq + :key #'function-name) + + +(defun %objc-class-instance-size (c) + #+apple-objc-2.0 + (#_class_getInstanceSize c) + #-apple-objc-2.0 + (pref c :objc_class.instance_size)) + +(defun find-named-objc-superclass (class string) + (unless (or (null string) (%null-ptr-p class)) + (with-macptrs ((name #+apple-objc-2.0 (#_class_getName class) + #-apple-objc-2.0 (pref class :objc_class.name))) + (or + (dotimes (i (length string) class) + (let* ((b (%get-unsigned-byte name i))) + (unless (eq b (char-code (schar string i))) + (return)))) + (find-named-objc-superclass #+apple-objc-2.0 (#_class_getSuperclass class) + #-apple-objc-2.0 (pref class :objc_class.super_class) + string))))) + +(defun install-foreign-objc-class (class &optional (use-db t)) + (let* ((id (objc-class-id class))) + (unless id + (let* ((name (%get-cstring #+apple-objc-2.0 (#_class_getName class) + #-apple-objc-2.0 (pref class :objc_class.name))) + (decl (get-objc-class-decl name use-db))) + (if (null decl) + (or (%get-private-objc-class class) + (%register-private-objc-class class name)) + (progn + (setq id (register-objc-class class) + class (id->objc-class id)) + ;; If not mapped, map the superclass (if there is one.) + (let* ((super (find-named-objc-superclass + #+apple-objc-2.0 + (#_class_getSuperclass class) + #-apple-objc-2.0 + (pref class :objc_class.super_class) + (db-objc-class-info-superclass-name decl)))) + (unless (null super) + (install-foreign-objc-class super)) + (let* ((class-name + (objc-to-lisp-classname + name + "NS")) + (meta-id + (objc-class-id->objc-metaclass-id id)) + (meta (id->objc-metaclass meta-id))) + ;; Metaclass may already be initialized. It'll have a + ;; class wrapper if so. + (unless (id->objc-metaclass-wrapper meta-id) + (let* ((meta-foreign-name + (%get-cstring + #+apple-objc-2.0 + (#_class_getName meta) + #-apple-objc-2.0 + (pref meta :objc_class.name))) + (meta-name + (intern + (concatenate 'string + "+" + (string + (objc-to-lisp-classname + meta-foreign-name + "NS"))) + "NS")) + (meta-super + (if super (pref super #+apple-objc :objc_class.isa + #+gnu-objc :objc_class.class_pointer)))) + ;; It's important (here and when initializing the + ;; class below) to use the "canonical" + ;; (registered) version of the class, since some + ;; things in CLOS assume EQness. We probably + ;; don't want to violate that assumption; it'll be + ;; easier to revive a saved image if we don't have + ;; a lot of EQL-but-not-EQ class pointers to deal + ;; with. + (initialize-instance + meta + :name meta-name + :direct-superclasses + (list + (if (or (null meta-super) + (not (%objc-metaclass-p meta-super))) + (find-class 'objc:objc-class) + (canonicalize-registered-metaclass meta-super))) + :peer class + :foreign t) + (setf (objc-metaclass-id-foreign-name meta-id) + meta-foreign-name) + (setf (find-class meta-name) meta) + (%defglobal meta-name meta))) + (setf (slot-value class 'direct-slots) + (compute-objc-direct-slots-from-info decl class)) + (initialize-instance + class + :name class-name + :direct-superclasses + (list + (if (null super) + (find-class 'objc:objc-object) + (canonicalize-registered-class super))) + :peer meta + :foreign t) + (setf (objc-class-id-foreign-name id) + name) + (setf (find-class class-name) class) + (%defglobal class-name class) + class)))))))) + + + +;;; Execute the body with the variable NSSTR bound to a +;;; stack-allocated NSConstantString instance (made from +;;; *NSConstantString-class*, CSTRING and LEN). +(defmacro with-nsstr ((nsstr cstring len) &body body) + #+apple-objc + `(rlet ((,nsstr :onstanttring + :isa *NSConstantString-class* + :bytes ,cstring + :numytes ,len)) + ,@body) + #+gnu-objc + `(rlet ((,nsstr :onstanttring + :isa *NSConstantString-class* + :c_string ,cstring + :len ,len)) + ,@body)) + +;;; Make a persistent (heap-allocated) NSConstantString. + +(defun %make-constant-nsstring (string) + "Make a persistent (heap-allocated) NSConstantString from the +argument lisp string." + #+apple-objc + (make-record :onstanttring + :isa *NSConstantString-Class* + :bytes (make-cstring string) + :numytes (length string)) + #+gnu-objc + (make-record :onstanttring + :isa *NSConstantString-Class* + :c_string (make-cstring string) + :len (length string)) + ) + +;;; Class declarations +(defparameter *objc-class-declarations* (make-hash-table :test #'equal)) + +(defun register-objc-class-decls () + (do-interface-dirs (d) + (dolist (class-name (cdb-enumerate-keys (db-objc-classes d))) + (get-objc-class-decl class-name t)))) + + +(defun get-objc-class-decl (class-name &optional (use-db nil)) + (or (gethash class-name *objc-class-declarations*) + (and use-db + (let* ((decl (%find-objc-class-info class-name))) + (when decl + (setf (gethash class-name *objc-class-declarations*) decl)))))) + +(defun %ensure-class-declaration (name super-name) + (unless (get-objc-class-decl name) + (setf (gethash name *objc-class-declarations*) + (make-db-objc-class-info :class-name (string name) + :superclass-name (string super-name)))) + name) + +;;; It's hard (and questionable) to allow ivars here. +(defmacro declare-objc-class (name super-name) + `(%ensure-class-declaration ',name ',super-name)) + +;;; Intern NSConstantString instances. +(defvar *objc-constant-strings* (make-hash-table :test #'equal)) + +(defstruct objc-constant-string + string + nsstringptr) + +(defun ns-constant-string (string) + (or (gethash string *objc-constant-strings*) + (setf (gethash string *objc-constant-strings*) + (make-objc-constant-string :string string + :nsstringptr (%make-constant-nsstring string))))) + +(def-ccl-pointers objc-strings () + (maphash #'(lambda (string cached) + (setf (objc-constant-string-nsstringptr cached) + (%make-constant-nsstring string))) + *objc-constant-strings*)) + +(defmethod make-load-form ((s objc-constant-string) &optional env) + (declare (ignore env)) + `(ns-constant-string ,(objc-constant-string-string s))) + +(defmacro @ (string) + `(objc-constant-string-nsstringptr ,(ns-constant-string string))) + +#+gnu-objc +(progn + (defcallback lisp-objc-error-handler (:id receiver :int errcode (:* :char) format :address argptr :) + (let* ((message (get-c-format-string format argptr))) + (error "ObjC runtime error ~d, receiver ~s :~& ~a" + errcode receiver message)) + #$YES) + + (def-ccl-pointers install-lisp-objc-error-handler () + (#_objc_set_error_handler lisp-objc-error-handler))) + + + + + + +;;; Registering named objc classes. + + +(defun objc-class-name-string (name) + (etypecase name + (symbol (lisp-to-objc-classname name)) + (string name))) + +;;; We'd presumably cache this result somewhere, so we'd only do the +;;; lookup once per session (in general.) +(defun lookup-objc-class (name &optional error-p) + (with-cstrs ((cstr (objc-class-name-string name))) + (let* ((p (#+apple-objc #_objc_lookUpClass + #+gnu-objc #_objc_lookup_class + cstr))) + (if (%null-ptr-p p) + (if error-p + (error "ObjC class ~a not found" name)) + p)))) + +(defun %set-pointer-to-objc-class-address (class-name-string ptr) + (with-cstrs ((cstr class-name-string)) + (%setf-macptr ptr + (#+apple-objc #_objc_lookUpClass + #+gnu-objc #_objc_lookup_class + cstr))) + nil) + + + +(defvar *objc-class-descriptors* (make-hash-table :test #'equal)) + + +(defstruct objc-class-descriptor + name + classptr) + +(defun invalidate-objc-class-descriptors () + (maphash #'(lambda (name descriptor) + (declare (ignore name)) + (setf (objc-class-descriptor-classptr descriptor) nil)) + *objc-class-descriptors*)) + +(defun %objc-class-classptr (class-descriptor &optional (error-p t)) + (or (objc-class-descriptor-classptr class-descriptor) + (setf (objc-class-descriptor-classptr class-descriptor) + (lookup-objc-class (objc-class-descriptor-name class-descriptor) + error-p)))) + +(defun load-objc-class-descriptor (name) + (let* ((descriptor (or (gethash name *objc-class-descriptors*) + (setf (gethash name *objc-class-descriptors*) + (make-objc-class-descriptor :name name))))) + (%objc-class-classptr descriptor nil) + descriptor)) + +(defmacro objc-class-descriptor (name) + `(load-objc-class-descriptor ,name)) + +(defmethod make-load-form ((o objc-class-descriptor) &optional env) + (declare (ignore env)) + `(load-objc-class-descriptor ,(objc-class-descriptor-name o))) + +(defmacro @class (name) + (let* ((name (objc-class-name-string name))) + `(the (@metaclass ,name) (%objc-class-classptr ,(objc-class-descriptor name))))) + +;;; This isn't quite the inverse operation of LOOKUP-OBJC-CLASS: it +;;; returns a simple C string. and can be applied to a class or any +;;; instance (returning the class name.) +(defun objc-class-name (object) + #+apple-objc + (with-macptrs (p) + (%setf-macptr p (#_object_getClassName object)) + (unless (%null-ptr-p p) + (%get-cstring p))) + #+gnu-objc + (unless (%null-ptr-p object) + (with-macptrs ((parent (pref object :objc_object.class_pointer))) + (unless (%null-ptr-p parent) + (if (logtest (pref parent :objc_class.info) #$_CLS_CLASS) + (%get-cstring (pref parent :objc_class.name)) + (%get-cstring (pref object :objc_class.name))))))) + + +;;; Likewise, we want to cache the selectors ("SEL"s) which identify +;;; method names. They can vary from session to session, but within +;;; a session, all methods with a given name (e.g, "init") will be +;;; represented by the same SEL. +(defun get-selector-for (method-name &optional error) + (with-cstrs ((cmethod-name method-name)) + (let* ((p (#+apple-objc #_sel_getUid + #+gnu-objc #_sel_get_uid + cmethod-name))) + (if (%null-ptr-p p) + (if error + (error "Can't find ObjC selector for ~a" method-name)) + p)))) + +(defvar *objc-selectors* (make-hash-table :test #'equal)) + +(defstruct objc-selector + name + %sel) + +(defun %get-SELECTOR (selector &optional (error-p t)) + (or (objc-selector-%sel selector) + (setf (objc-selector-%sel selector) + (get-selector-for (objc-selector-name selector) error-p)))) + +(defun clear-objc-selectors () + (maphash #'(lambda (name sel) + (declare (ignore name)) + (setf (objc-selector-%sel sel) nil)) + *objc-selectors*)) + +;;; Find or create a SELECTOR; don't bother resolving it. +(defun ensure-objc-selector (name) + (setq name (string name)) + (or (gethash name *objc-selectors*) + (setf (gethash name *objc-selectors*) + (make-objc-selector :name name)))) + +(defun load-objc-selector (name) + (let* ((selector (ensure-objc-selector name))) + (%get-SELECTOR selector nil) + selector)) + +(defmacro @SELECTOR (name) + `(%get-selector ,(load-objc-selector name))) + +(defmethod make-load-form ((s objc-selector) &optional env) + (declare (ignore env)) + `(load-objc-selector ,(objc-selector-name s))) + + +;;; Convert a Lisp object X to a desired foreign type FTYPE +;;; The following conversions are currently done: +;;; - T/NIL => #$YES/#$NO +;;; - NIL => (%null-ptr) +;;; - Lisp string => NSString +;;; - Lisp numbers => SINGLE-FLOAT when possible + +(defun coerce-to-bool (x) + (let ((x-temp (gensym))) + `(let ((,x-temp ,x)) + (if (or (eq ,x-temp 0) (null ,x-temp)) + #.#$NO + #.#$YES)))) + +(declaim (inline %coerce-to-bool)) +(defun %coerce-to-bool (x) + (if (and x (not (eql x 0))) + #$YES + #$NO)) + +(defun coerce-to-address (x) + (let ((x-temp (gensym))) + `(let ((,x-temp ,x)) + (cond ((null ,x-temp) +null-ptr+) + ((stringp ,x-temp) (%make-nsstring ,x-temp)) + (t ,x-temp))))) + +;;; This is generally a bad idea; it forces us to +;;; box intermediate pointer arguments in order +;;; to typecase on them, and it's not clear to +;;; me that it offers much in the way of additional +;;; expressiveness. +(declaim (inline %coerce-to-address)) +(defun %coerce-to-address (x) + (etypecase x + (macptr x) + (string (%make-nsstring x)) ; does this ever get released ? + (null (%null-ptr)))) + +(defun coerce-to-foreign-type (x ftype) + (cond ((and (constantp x) (constantp ftype)) + (case ftype + (:id (if (null x) `(%null-ptr) (coerce-to-address x))) + (: (coerce-to-bool (eval x))) + (t x))) + ((constantp ftype) + (case ftype + (:id `(%coerce-to-address ,x)) + (: `(%coerce-to-bool ,x)) + (t x))) + (t `(case ,(if (atom ftype) ftype) + (:id (%coerce-to-address ,x)) + (: (%coerce-to-bool ,x)) + (t ,x))))) + +(defun objc-arg-coerce (typespec arg) + (case typespec + (: `(%coerce-to-bool ,arg)) + (:id `(%coerce-to-address ,arg)) + (t arg))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Boolean Return Hackery ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Convert a foreign object X to T or NIL + +(defun coerce-from-bool (x) + (cond + ((eq x #$NO) nil) + ((eq x #$YES) t) + (t (error "Cannot coerce ~S to T or NIL" x)))) + +(defun objc-result-coerce (type result) + (cond ((eq type :) + `(coerce-from-bool ,result)) + (t result))) + +;;; Add a faster way to get the message from a SEL by taking advantage of the +;;; fact that a selector is really just a canonicalized, interned C string +;;; containing the message. (This is an admitted modularity violation; +;;; there's a more portable but slower way to do this if we ever need to.) + + +(defun lisp-string-from-sel (sel) + (%get-cstring + #+apple-objc sel + #+gnu-objc (#_sel_get_name sel))) + +;;; #_objc_msgSend takes two required arguments (the receiving object +;;; and the method selector) and 0 or more additional arguments; +;;; there'd have to be some macrology to handle common cases, since we +;;; want the compiler to see all of the args in a foreign call. + +;;; I don't remmber what the second half of the above comment might +;;; have been talking about. + +(defmacro objc-message-send (receiver selector-name &rest argspecs) + (when (evenp (length argspecs)) + (setq argspecs (append argspecs '(:id)))) + #+apple-objc + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) + `(:address ,receiver : (@selector ,selector-name) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce) + #+gnu-objc + (let* ((r (gensym)) + (s (gensym)) + (imp (gensym))) + `(with-macptrs ((,r ,receiver) + (,s (@selector ,selector-name)) + (,imp (external-call "objc_msg_lookup" + :id ,r + : ,s + :))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + `(:address ,receiver : (@selector ,selector-name) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)))) + +(defmacro objc-message-send-with-selector (receiver selector &rest argspecs) + (when (evenp (length argspecs)) + (setq argspecs (append argspecs '(:id)))) + #+apple-objc + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) + `(:address ,receiver : (%get-selector ,selector) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce) + #+gnu-objc + (let* ((r (gensym)) + (s (gensym)) + (imp (gensym))) + `(with-macptrs ((,r ,receiver) + (,s (%get-selector ,selector)) + (,imp (external-call "objc_msg_lookup" + :id ,r + : ,s + :))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + `(:address ,receiver : ,s ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)))) + +;;; A method that returns a structure does so by platform-dependent +;;; means. One of those means (which is fairly common) is to pass a +;;; pointer to an instance of a structure type as a first argument to +;;; the method implementation function (thereby making SELF the second +;;; argument, etc.), but whether or not it's actually done that way +;;; depends on the platform and on the structure type. The special +;;; variable CCL::*TARGET-FTD* holds a structure (of type +;;; CCL::FOREIGN-TYPE-DATA) which describes some static attributes of +;;; the foreign type system on the target platform and contains some +;;; functions which can determine dynamic ABI attributes. One such +;;; function can be used to determine whether or not the "invisible +;;; first arg" convention is used to return structures of a given +;;; foreign type; another function in *TARGET-FTD* can be used to +;;; construct a foreign function call form that handles +;;; structure-return and structure-types-as-arguments details. In the +;;; Apple ObjC runtime, #_objc_msgSend_stret must be used if the +;;; invisible-first-argument convention is used to return a structure +;;; and must NOT be used otherwise. (The Darwin ppc64 and all +;;; supported x86-64 ABIs often use more complicated structure return +;;; conventions than ppc32 Darwin or ppc Linux.) We should use +;;; OBJC-MESSAGE-SEND-STRET to send any message that returns a +;;; structure or union, regardless of how that structure return is +;;; actually implemented. + +(defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs) + #+apple-objc + (let* ((return-typespec (car (last argspecs))) + (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) + "_objc_msgSend_stret" + "_objc_msgSend"))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) + `(,structptr :address ,receiver : (@selector ,selector-name) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)) + #+gnu-objc + (let* ((r (gensym)) + (s (gensym)) + (imp (gensym))) + `(with-macptrs ((,r ,receiver) + (,s (@selector ,selector-name)) + (,imp (external-call "objc_msg_lookup" + :id ,r + : ,s + :))) + , (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + `(,structptr :address ,receiver : ,s ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)))) + +(defmacro objc-message-send-stret-with-selector (structptr receiver selector &rest argspecs) + #+apple-objc + (let* ((return-typespec (car (last argspecs))) + (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) + "_objc_msgSend_stret" + "_objc_msgSend"))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) + `(,structptr :address ,receiver : (%get-selector ,selector) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)) + #+gnu-objc + (let* ((r (gensym)) + (s (gensym)) + (imp (gensym))) + `(with-macptrs ((,r ,receiver) + (,s (%get-selector ,selector)) + (,imp (external-call "objc_msg_lookup" + :id ,r + : ,s + :))) + , (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + `(,structptr :address ,receiver : ,s ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)))) + +;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument +;;; is a pointer to a structure of type objc_super {self, the defining +;;; class's superclass}. It only makes sense to use this inside an +;;; objc method. +(defmacro objc-message-send-super (super selector-name &rest argspecs) + (when (evenp (length argspecs)) + (setq argspecs (append argspecs '(:id)))) + #+apple-objc + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper")))) + `(:address ,super : (@selector ,selector-name) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce) + #+gnu-objc + (let* ((sup (gensym)) + (sel (gensym)) + (imp (gensym))) + `(with-macptrs ((,sup ,super) + (,sel (@selector ,selector-name)) + (,imp (external-call "objc_msg_lookup_super" + :uper_t ,sup + : ,sel + :))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + `(:id (pref ,sup :uper.self) + : ,sel + ,@argspecs))))) + +(defmacro objc-message-send-super-with-selector (super selector &rest argspecs) + (when (evenp (length argspecs)) + (setq argspecs (append argspecs '(:id)))) + #+apple-objc + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper")))) + `(:address ,super : ,selector ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce) + #+gnu-objc + (let* ((sup (gensym)) + (sel (gensym)) + (imp (gensym))) + `(with-macptrs ((,sup ,super) + (,sel ,selector) + (,imp (external-call "objc_msg_lookup_super" + :uper_t ,sup + : ,sel + :))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + `(:id (pref ,sup :uper.self) + : ,sel + ,@argspecs))))) + +;;; Send to superclass method, returning a structure. See above. +(defmacro objc-message-send-super-stret + (structptr super selector-name &rest argspecs) + #+apple-objc + (let* ((return-typespec (car (last argspecs))) + (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) + "_objc_msgSendSuper_stret" + "_objc_msgSendSuper"))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) + `(,structptr :address ,super : (@selector ,selector-name) ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)) + #+gnu-objc + (let* ((sup (gensym)) + (sel (gensym)) + (imp (gensym))) + `(with-macptrs ((,sup ,super) + (,sel (@selector ,selector-name)) + (,imp (external-call "objc_msg_lookup_super" + :uper_t ,sup + : ,sel + :))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + ,structptr + :id (pref ,sup :uper.self) + : ,sel + ,@argspecs)))) + +(defmacro objc-message-send-super-stret-with-selector + (structptr super selector &rest argspecs) + #+apple-objc + (let* ((return-typespec (car (last argspecs))) + (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec) + "_objc_msgSendSuper_stret" + "_objc_msgSendSuper"))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name)))) + `(,structptr :address ,super : ,selector ,@argspecs) + :arg-coerce 'objc-arg-coerce + :result-coerce 'objc-result-coerce)) + #+gnu-objc + (let* ((sup (gensym)) + (sel (gensym)) + (imp (gensym))) + `(with-macptrs ((,sup ,super) + (,sel ,selector) + (,imp (external-call "objc_msg_lookup_super" + :uper_t ,sup + : ,sel + :))) + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,imp) + ,structptr + :id (pref ,sup :uper.self) + : ,sel + ,@argspecs)))) + +(defun message-send-form-for-call (receiver selector args super-p struct-return-var) + (if struct-return-var + (if super-p + `(objc-message-send-super-stret-with-selector ,struct-return-var ,receiver ,selector ,@args) + `(objc-message-send-stret-with-selector ,struct-return-var ,receiver ,selector ,@args)) + (if super-p + `(objc-message-send-super-with-selector ,receiver ,selector ,@args) + `(objc-message-send-with-selector ,receiver ,selector ,@args)))) + + +#+(and apple-objc x8664-target) +(defun %process-varargs-list (gpr-pointer fpr-pointer stack-pointer ngprs nfprs nstackargs arglist) + (dolist (arg-temp arglist) + (typecase arg-temp + ((signed-byte 64) + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* (:signed 64)) nstackargs) arg-temp) + (incf nstackargs)))) + ((unsigned-byte 64) + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* (:unsigned 64)) nstackargs) arg-temp) + (incf nstackargs)))) + (macptr + (if (< ngprs 6) + (progn + (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) + (incf ngprs)) + (progn + (setf (paref stack-pointer (:* :address) nstackargs) arg-temp) + (incf nstackargs)))) + (single-float + (if (< nfprs 8) + (progn + (setf (%get-single-float fpr-pointer (* nfprs 16)) + arg-temp) + (incf nfprs)) + (progn + (setf (paref stack-pointer (:* :float) (* 2 nstackargs)) arg-temp) + (incf nstackargs)))) + (double-float + (if (< nfprs 8) + (progn + (setf (%get-double-float fpr-pointer (* nfprs 16)) + arg-temp) + (incf nfprs)) + (progn + (setf (paref stack-pointer (:* :double) nstackargs) + arg-temp) + (incf nstackargs))))))) + +#+(and apple-objc ppc32-target) +(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist) + (dolist (arg-temp arglist) + (typecase arg-temp + ((signed-byte 32) + (setf (paref gpr-pointer (:* (:signed 32)) ngprs) arg-temp) + (incf ngprs)) + ((unsigned-byte 32) + (setf (paref gpr-pointer (:* (:unsigned 32)) ngprs) arg-temp) + (incf ngprs)) + (macptr + (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) + (incf ngprs)) + (single-float + (when (< nfprs 13) + (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0)) + (incf nfprs)) + (setf (paref gpr-pointer (:* :single-float) ngprs) arg-temp) + (incf ngprs)) + (double-float + (when (< nfprs 13) + (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp) + (incf nfprs)) + (multiple-value-bind (high low) (double-float-bits arg-temp) + (setf (paref gpr-pointer (:* :unsigned) ngprs) high) + (incf ngprs) + (setf (paref gpr-pointer (:* :unsigned) ngprs) low) + (incf nfprs))) + ((or (signed-byte 64) + (unsigned-byte 64)) + (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 32) arg-temp)) + (incf ngprs) + (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 0) arg-temp)) + (incf ngprs))))) + +#+(and apple-objc ppc64-target) +(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist) + (dolist (arg-temp arglist) + (typecase arg-temp + ((signed-byte 64) + (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp) + (incf ngprs)) + ((unsigned-byte 64) + (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp) + (incf ngprs)) + (macptr + (setf (paref gpr-pointer (:* :address) ngprs) arg-temp) + (incf ngprs)) + (single-float + (when (< nfprs 13) + (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0)) + (incf nfprs)) + (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) (single-float-bits arg-temp)) + (incf ngprs)) + (double-float + (when (< nfprs 13) + (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp) + (incf nfprs)) + (setf (paref gpr-pointer (:* :double-float) ngprs) arg-temp) + (incf ngprs))))) + + +#+apple-objc +(eval-when (:compile-toplevel :execute) + #+(and ppc-target (not apple-objc-2.0)) + (def-foreign-type : + (:struct nil + (:fp

arams (:array :double 13)) + (:linkage (:array :uintptr_t 6)) + (:reg

arams (:array :uintptr_t 8)) + (:stack

arams (:array :uintptr_t) 0))) + ) + + +#+(and apple-objc-2.0 x8664-target) +(defun %compile-varargs-send-function-for-signature (sig) + (let* ((return-type-spec (foreign-type-to-representation-type (car sig))) + (op (case return-type-spec + (:address '%get-ptr) + (:unsigned-byte '%get-unsigned-byte) + (:signed-byte '%get-signed-byte) + (:unsigned-halfword '%get-unsigned-word) + (:signed-halfword '%get-signed-word) + (:unsigned-fullword '%get-unsigned-long) + (:signed-fullword '%get-signed-long) + (:unsigned-doubleword '%get-natural) + (:signed-doubleword '%get-signed-natural) + (:single-float '%get-single-float) + (:double-float '%get-double-float))) + (result-offset + (case op + ((:single-float :double-float) 0) + (t -8))) + (arg-type-specs (butlast (cdr sig))) + (args (objc-gen-message-arglist (length arg-type-specs))) + (receiver (gensym)) + (selector (gensym)) + (rest-arg (gensym)) + (arg-temp (gensym)) + (regparams (gensym)) + (stackparams (gensym)) + (fpparams (gensym)) + (cframe (gensym)) + (selptr (gensym)) + (gpr-total (gensym)) + (fpr-total (gensym)) + (stack-total (gensym)) + (n-static-gprs 2) ;receiver, selptr + (n-static-fprs 0) + (n-static-stack-args 0)) + (collect ((static-arg-forms)) + (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) + (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) + (do* ((args args (cdr args)) + (arg-type-specs arg-type-specs (cdr arg-type-specs))) + ((null args)) + (let* ((arg (car args)) + (spec (car arg-type-specs)) + (static-arg-type (parse-foreign-type spec)) + (gpr-base (if (< n-static-gprs 6) regparams stackparams)) + (fpr-base (if (< n-static-fprs 8) fpparams stackparams)) + (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args)) + (fpr-offset (if (< n-static-fprs 8) + (* 8 n-static-fprs) + (* 8 n-static-stack-args)))) + (etypecase static-arg-type + (foreign-integer-type + (if (eq spec :) + (setq arg `(%coerce-to-bool ,arg))) + (static-arg-forms + `(setf (paref ,gpr-base (:* ( + ,(if (foreign-integer-type-signed static-arg-type) + :signed + :unsigned) + ,(foreign-integer-type-bits static-arg-type))) ,gpr-offset) + ,arg)) + (if (< n-static-gprs 6) + (incf n-static-gprs) + (incf n-static-stack-args))) + (foreign-single-float-type + (static-arg-forms + `(setf (%get-single-float ,fpr-base ,fpr-offset) ,arg)) + (if (< n-static-fprs 8) + (incf n-static-fprs) + (incf n-static-stack-args))) + (foreign-double-float-type + (static-arg-forms + `(setf (%get-double-float ,fpr-base ,fpr-offset) ,arg)) + (if (< n-static-fprs 8) + (incf n-static-fprs) + (incf n-static-stack-args))) + (foreign-pointer-type + (static-arg-forms + `(setf (paref ,gpr-base (:* address) ,gpr-offset) ,arg)) + (if (< n-static-gprs 6) + (incf n-static-gprs) + (incf n-static-stack-args)))))) + (compile + nil + `(lambda (,receiver ,selector ,@args &rest ,rest-arg) + (declare (dynamic-extent ,rest-arg)) + (let* ((,selptr (%get-selector ,selector)) + (,gpr-total ,n-static-gprs) + (,fpr-total ,n-static-fprs) + (,stack-total ,n-static-stack-args)) + (dolist (,arg-temp ,rest-arg) + (if (or (typep ,arg-temp 'double-float) + (typep ,arg-temp 'single-float)) + (if (< ,fpr-total 8) + (incf ,fpr-total) + (incf ,stack-total)) + (if (< ,gpr-total 6) + (incf ,gpr-total) + (incf ,stack-total)))) + (%stack-block ((,fpparams (* 8 8))) + (with-macptrs (,regparams ,stackparams) + (with-variable-c-frame + (+ 8 ,stack-total) ,cframe + (%setf-macptr-to-object ,regparams (+ ,cframe 2)) + (%setf-macptr-to-object ,stackparams (+ ,cframe 8)) + (progn ,@(static-arg-forms)) + (%process-varargs-list ,regparams ,fpparams ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg) + (%do-ff-call ,fpr-total ,cframe ,fpparams (%reference-external-entry-point (load-time-value (external "_objc_msgSend")))) + ,@(if op + `((,op ,regparams ,result-offset)) + `(()))))))))))) + + +#+(and apple-objc ppc32-target) +(defun %compile-varargs-send-function-for-signature (sig) + (let* ((return-type-spec (car sig)) + (arg-type-specs (butlast (cdr sig))) + (args (objc-gen-message-arglist (length arg-type-specs))) + (receiver (gensym)) + (selector (gensym)) + (rest-arg (gensym)) + (arg-temp (gensym)) + (marg-ptr (gensym)) + (regparams (gensym)) + (selptr (gensym)) + (gpr-total (gensym)) + (n-static-gprs 2) ;receiver, selptr + (n-static-fprs 0)) + (collect ((static-arg-forms)) + (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) + (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) + (do* ((args args (cdr args)) + (arg-type-specs arg-type-specs (cdr arg-type-specs))) + ((null args)) + (let* ((arg (car args)) + (spec (car arg-type-specs)) + (static-arg-type (parse-foreign-type spec)) + (gpr-base regparams) + (fpr-base marg-ptr) + (gpr-offset (* n-static-gprs 4))) + (etypecase static-arg-type + (foreign-integer-type + (let* ((bits (foreign-type-bits static-arg-type)) + (signed (foreign-integer-type-signed static-arg-type))) + (if (> bits 32) + (progn + (static-arg-forms + `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long) + ,gpr-base ,gpr-offset) + ,arg)) + (incf n-static-gprs 2)) + (progn + (if (eq spec :) + (setq arg `(%coerce-to-bool ,arg))) + (static-arg-forms + `(setf (paref ,gpr-base (:* ( + ,(if (foreign-integer-type-signed static-arg-type) + :signed + :unsigned) + 32)) ,gpr-offset) + ,arg)) + (incf n-static-gprs))))) + (foreign-single-float-type + (static-arg-forms + `(setf (paref ,gpr-base (:* :single-float) ,n-static-gprs) ,arg)) + (when (< n-static-fprs 13) + (static-arg-forms + `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) + (float (paref ,gpr-base (:* :single-float) ,n-static-gprs) 0.0d0))) + (incf n-static-fprs)) + (incf n-static-gprs)) + (foreign-double-float-type + (static-arg-forms + `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg)) + (when (< n-static-fprs 13) + (static-arg-forms + `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) + (%get-double-float ,gpr-base ,gpr-offset))) + (incf n-static-fprs)) + (incf n-static-gprs 2)) + (foreign-pointer-type + (static-arg-forms + `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg)) + (incf n-static-gprs))))) + (compile + nil + `(lambda (,receiver ,selector ,@args &rest ,rest-arg) + (declare (dynamic-extent ,rest-arg)) + (let* ((,selptr (%get-selector ,selector)) + (,gpr-total ,n-static-gprs)) + (dolist (,arg-temp ,rest-arg) + (if (or (typep ,arg-temp 'double-float) + (and (typep ,arg-temp 'integer) + (if (< ,arg-temp 0) + (>= (integer-length ,arg-temp) 32) + (> (integer-length ,arg-temp) 32)))) + (incf ,gpr-total 2) + (incf ,gpr-total 1))) + (if (> ,gpr-total 8) + (setq ,gpr-total (- ,gpr-total 8)) + (setq ,gpr-total 0)) + (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size + : :bytes) + (* 4 ,gpr-total)))) + + (with-macptrs ((,regparams (pref ,marg-ptr :.reg

arams))) + (progn ,@(static-arg-forms)) + (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs ,rest-arg) + (external-call "_objc_msgSendv" + :address ,receiver + :address ,selptr + :size_t (+ 32 (* 4 ,gpr-total)) + :address ,marg-ptr + ,return-type-spec))))))))) + +#+(and apple-objc ppc64-target) +(defun %compile-varargs-send-function-for-signature (sig) + (let* ((return-type-spec (car sig)) + (arg-type-specs (butlast (cdr sig))) + (args (objc-gen-message-arglist (length arg-type-specs))) + (receiver (gensym)) + (selector (gensym)) + (rest-arg (gensym)) + (arg-temp (gensym)) + (marg-ptr (gensym)) + (regparams (gensym)) + (selptr (gensym)) + (gpr-total (gensym)) + (n-static-gprs 2) ;receiver, selptr + (n-static-fprs 0)) + (collect ((static-arg-forms)) + (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver)) + (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr)) + (do* ((args args (cdr args)) + (arg-type-specs arg-type-specs (cdr arg-type-specs))) + ((null args)) + (let* ((arg (car args)) + (spec (car arg-type-specs)) + (static-arg-type (parse-foreign-type spec)) + (gpr-base regparams) + (fpr-base marg-ptr) + (gpr-offset (* n-static-gprs 8))) + (etypecase static-arg-type + (foreign-integer-type + (if (eq spec :) + (setq arg `(%coerce-to-bool ,arg))) + (static-arg-forms + `(setf (paref ,gpr-base (:* ( + ,(if (foreign-integer-type-signed static-arg-type) + :signed + :unsigned) + 64)) ,gpr-offset) + ,arg)) + (incf n-static-gprs)) + (foreign-single-float-type + (static-arg-forms + `(setf (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) ,arg)) + (when (< n-static-fprs 13) + (static-arg-forms + `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) + (float (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) 0.0d0))) + (incf n-static-fprs)) + (incf n-static-gprs)) + (foreign-double-float-type + (static-arg-forms + `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg)) + (when (< n-static-fprs 13) + (static-arg-forms + `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs) + (%get-double-float ,gpr-base ,gpr-offset))) + (incf n-static-fprs)) + (incf n-static-gprs 1)) + (foreign-pointer-type + (static-arg-forms + `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg)) + (incf n-static-gprs))))) + + (progn + nil + `(lambda (,receiver ,selector ,@args &rest ,rest-arg) + (declare (dynamic-extent ,rest-arg)) + (let* ((,selptr (%get-selector ,selector)) + (,gpr-total ,n-static-gprs)) + (dolist (,arg-temp ,rest-arg) + (declare (ignore ,arg-temp)) + (incf ,gpr-total 1)) + (if (> ,gpr-total 8) + (setq ,gpr-total (- ,gpr-total 8)) + (setq ,gpr-total 0)) + (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size + : :bytes) + (* 8 ,gpr-total)))) + + (with-macptrs ((,regparams (pref ,marg-ptr :.reg

arams))) + (progn ,@(static-arg-forms)) + (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs ,rest-arg) + (external-call "_objc_msgSendv" + :address ,receiver + :address ,selptr + :size_t (+ 64 (* 8 ,gpr-total)) + :address ,marg-ptr + ,return-type-spec))))))))) + +#-(and apple-objc (or x8664-target ppc-target)) +(defun %compile-varargs-send-function-for-signature (sig) + (warn "Varargs function for signature ~s NYI" sig)) + + + +(defun %compile-send-function-for-signature (sig &optional super-p) + (let* ((return-type-spec (car sig)) + (arg-type-specs (cdr sig))) + (if (eq (car (last arg-type-specs)) :void) + (%compile-varargs-send-function-for-signature sig) + (let* ((args (objc-gen-message-arglist (length arg-type-specs))) + (struct-return-var nil) + (receiver (gensym)) + (selector (gensym))) + (collect ((call) + (lets)) + (let* ((result-type (parse-foreign-type return-type-spec))) + (when (typep result-type 'foreign-record-type) + (setq struct-return-var (gensym)) + (lets `(,struct-return-var (make-gcable-record ,return-type-spec)))) + + (do ((args args (cdr args)) + (spec (pop arg-type-specs) (pop arg-type-specs))) + ((null args) (call return-type-spec)) + (let* ((arg (car args))) + (call spec) + (case spec + (: (call `(%coerce-to-bool ,arg))) + (:id (call `(%coerce-to-address ,arg))) + (:loat (call `(float ,arg +cgfloat-zero+))) + (t + (call arg))))) + (let* ((call (call)) + (lets (lets)) + (body (message-send-form-for-call receiver selector call super-p struct-return-var))) + (if struct-return-var + (setq body `(progn ,body ,struct-return-var))) + (if lets + (setq body `(let* ,lets + ,body))) + (compile nil + `(lambda (,receiver ,selector ,@args) + ,body))))))))) + +(defun compile-send-function-for-signature (sig) + (%compile-send-function-for-signature sig nil)) + + + + +;;; The first 8 words of non-fp arguments get passed in R3-R10 +#+ppc-target +(defvar *objc-gpr-offsets* + #+32-bit-target + #(4 8 12 16 20 24 28 32) + #+64-bit-target + #(8 16 24 32 40 48 56 64) + ) + + + +;;; The first 13 fp arguments get passed in F1-F13 (and also "consume" +;;; a GPR or two.) It's certainly possible for an FP arg and a non- +;;; FP arg to share the same "offset", and parameter offsets aren't +;;; strictly increasing. +#+ppc-target +(defvar *objc-fpr-offsets* + #+32-bit-target + #(36 44 52 60 68 76 84 92 100 108 116 124 132) + #+64-bit-target + #(68 76 84 92 100 108 116 124 132 140 148 156 164)) + +;;; Just to make things even more confusing: once we've filled in the +;;; first 8 words of the parameter area, args that aren't passed in +;;; FP-regs get assigned offsets starting at 32. That almost makes +;;; sense (even though it conflicts with the last offset in +;;; *objc-gpr-offsets* (assigned to R10), but we then have to add +;;; this constant to the memory offset. +(defconstant objc-forwarding-stack-offset 8) + +(defvar *objc-id-type* (parse-foreign-type :id)) +(defvar *objc-sel-type* (parse-foreign-type :)) +(defvar *objc-char-type* (parse-foreign-type :char)) + + +(defun encode-objc-type (type &optional for-ivar recursive) + (if (or (eq type *objc-id-type*) + (foreign-type-= type *objc-id-type*)) + "@" + (if (or (eq type *objc-sel-type*) + (foreign-type-= type *objc-sel-type*)) + ":" + (if (eq (foreign-type-class type) 'root) + "v" + (typecase type + (foreign-pointer-type + (let* ((target (foreign-pointer-type-to type))) + (if (or (eq target *objc-char-type*) + (foreign-type-= target *objc-char-type*)) + "*" + (format nil "^~a" (encode-objc-type target nil t))))) + (foreign-double-float-type "d") + (foreign-single-float-type "f") + (foreign-integer-type + (let* ((signed (foreign-integer-type-signed type)) + (bits (foreign-integer-type-bits type))) + (if (eq (foreign-integer-type-alignment type) 1) + (format nil "b~d" bits) + (cond ((= bits 8) + (if signed "c" "C")) + ((= bits 16) + (if signed "s" "S")) + ((= bits 32) + ;; Should be some way of noting "longness". + (if signed "i" "I")) + ((= bits 64) + (if signed "q" "Q")))))) + (foreign-record-type + (ensure-foreign-type-bits type) + (let* ((name (unescape-foreign-name + (or (foreign-record-type-name type) "?"))) + (kind (foreign-record-type-kind type)) + (fields (foreign-record-type-fields type))) + (with-output-to-string (s) + (format s "~c~a=" (if (eq kind :struct) #\{ #\() name) + (dolist (f fields (format s "~a" (if (eq kind :struct) #\} #\)))) + (when for-ivar + (format s "\"~a\"" + (unescape-foreign-name + (or (foreign-record-field-name f) "")))) + (unless recursive + (format s "~a" (encode-objc-type + (foreign-record-field-type f) nil nil))))))) + (foreign-array-type + (ensure-foreign-type-bits type) + (let* ((dims (foreign-array-type-dimensions type)) + (element-type (foreign-array-type-element-type type))) + (if dims (format nil "[~d~a]" + (car dims) + (encode-objc-type element-type nil t)) + (if (or (eq element-type *objc-char-type*) + (foreign-type-= element-type *objc-char-type*)) + "*" + (format nil "^~a" (encode-objc-type element-type nil t)))))) + (t (break "type = ~s" type))))))) + +#+ppc-target +(defun encode-objc-method-arglist (arglist result-spec) + (let* ((gprs-used 0) + (fprs-used 0) + (arg-info + (flet ((current-memory-arg-offset () + (+ 32 (* 4 (- gprs-used 8)) + objc-forwarding-stack-offset))) + (flet ((current-gpr-arg-offset () + (if (< gprs-used 8) + (svref *objc-gpr-offsets* gprs-used) + (current-memory-arg-offset))) + (current-fpr-arg-offset () + (if (< fprs-used 13) + (svref *objc-fpr-offsets* fprs-used) + (current-memory-arg-offset)))) + (let* ((result nil)) + (dolist (argspec arglist (nreverse result)) + (let* ((arg (parse-foreign-type argspec)) + (offset 0) + (size 0)) + (typecase arg + (foreign-double-float-type + (setq size 8 offset (current-fpr-arg-offset)) + (incf fprs-used) + (incf gprs-used 2)) + (foreign-single-float-type + (setq size target::node-size offset (current-fpr-arg-offset)) + (incf fprs-used) + (incf gprs-used 1)) + (foreign-pointer-type + (setq size target::node-size offset (current-gpr-arg-offset)) + (incf gprs-used)) + (foreign-integer-type + (let* ((bits (foreign-type-bits arg))) + (setq size (ceiling bits 8) + offset (current-gpr-arg-offset)) + (incf gprs-used (ceiling bits target::nbits-in-word)))) + ((or foreign-record-type foreign-array-type) + (let* ((bits (ensure-foreign-type-bits arg))) + (setq size (ceiling bits 8) + offset (current-gpr-arg-offset)) + (incf gprs-used (ceiling bits target::nbits-in-word)))) + (t (break "argspec = ~s, arg = ~s" argspec arg))) + (push (list (encode-objc-type arg) offset size) result)))))))) + (declare (fixnum gprs-used fprs-used)) + (let* ((max-parm-end + (- (apply #'max (mapcar #'(lambda (i) (+ (cadr i) (caddr i))) + arg-info)) + objc-forwarding-stack-offset))) + (format nil "~a~d~:{~a~d~}" + (encode-objc-type + (parse-foreign-type result-spec)) + max-parm-end + arg-info)))) + +#+x8664-target +(defun encode-objc-method-arglist (arglist result-spec) + (let* ((offset 0) + (arg-info + (let* ((result nil)) + (dolist (argspec arglist (nreverse result)) + (let* ((arg (parse-foreign-type argspec)) + (delta 8)) + (typecase arg + (foreign-double-float-type) + (foreign-single-float-type) + ((or foreign-pointer-type foreign-array-type)) + (foreign-integer-type) + (foreign-record-type + (let* ((bits (ensure-foreign-type-bits arg))) + (setq delta (ceiling bits 8)))) + (t (break "argspec = ~s, arg = ~s" argspec arg))) + (push (list (encode-objc-type arg) offset) result) + (setq offset (* 8 (ceiling (+ offset delta) 8)))))))) + (let* ((max-parm-end offset)) + (format nil "~a~d~:{~a~d~}" + (encode-objc-type + (parse-foreign-type result-spec)) + max-parm-end + arg-info)))) + +;;; In Apple Objc, a class's methods are stored in a (-1)-terminated +;;; vector of method lists. In GNU ObjC, method lists are linked +;;; together. +(defun %make-method-vector () + #+apple-objc + (let* ((method-vector (malloc 16))) + (setf (%get-signed-long method-vector 0) 0 + (%get-signed-long method-vector 4) 0 + (%get-signed-long method-vector 8) 0 + (%get-signed-long method-vector 12) -1) + method-vector)) + + +;;; Make a meta-class object (with no instance variables or class +;;; methods.) +#-apple-objc-2.0 +(defun %make-basic-meta-class (nameptr superptr rootptr) + #+apple-objc + (let* ((method-vector (%make-method-vector))) + (make-record :objc_class + :isa (pref rootptr :objc_class.isa) + :super_class (pref superptr :objc_class.isa) + :name nameptr + :version 0 + :info #$CLS_META + :instance_size 0 + :ivars (%null-ptr) + :methodists method-vector + :cache (%null-ptr) + :protocols (%null-ptr))) + #+gnu-objc + (make-record :objc_class + :class_pointer (pref rootptr :objc_class.class_pointer) + :super_class (pref superptr :objc_class.class_pointer) + :name nameptr + :version 0 + :info #$_CLS_META + :instance_size 0 + :ivars (%null-ptr) + :methods (%null-ptr) + :dtable (%null-ptr) + :subclass_list (%null-ptr) + :sibling_class (%null-ptr) + :protocols (%null-ptr) + :gc_object_type (%null-ptr))) + +#-apple-objc-2.0 +(defun %make-class-object (metaptr superptr nameptr ivars instance-size) + #+apple-objc + (let* ((method-vector (%make-method-vector))) + (make-record :objc_class + :isa metaptr + :super_class superptr + :name nameptr + :version 0 + :info #$CLS_CLASS + :instance_size instance-size + :ivars ivars + :methodists method-vector + :cache (%null-ptr) + :protocols (%null-ptr))) + #+gnu-objc + (make-record :objc_class + :class_pointer metaptr + :super_class superptr + :name nameptr + :version 0 + :info #$_CLS_CLASS + :instance_size instance-size + :ivars ivars + :methods (%null-ptr) + :dtable (%null-ptr) + :protocols (%null-ptr))) + +(defun make-objc-class-pair (superptr nameptr) + #+apple-objc-2.0 + (#_objc_allocateClassPair superptr nameptr 0) + #-apple-objc-2.0 + (%make-class-object + (%make-basic-meta-class nameptr superptr (@class "NSObject")) + superptr + nameptr + (%null-ptr) + 0)) + +(defun superclass-instance-size (class) + (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass class) + #-apple-objc-2.0 (pref class :objc_class.super_class))) + (if (%null-ptr-p super) + 0 + (%objc-class-instance-size super)))) + + + + +#+gnu-objc +(progn +(defloadvar *gnu-objc-runtime-mutex* + (%get-ptr (foreign-symbol-address "__objc_runtime_mutex"))) +(defmacro with-gnu-objc-mutex-locked ((mutex) &body body) + (let* ((mname (gensym))) + `(let ((,mname ,mutex)) + (unwind-protect + (progn + (external-call "objc_mutex_lock" :address ,mname :void) + ,@body) + (external-call "objc_mutex_lock" :address ,mname :void))))) +) + +(defun %objc-metaclass-p (class) + #+apple-objc-2.0 (not (eql #$NO (#_class_isMetaClass class))) + #-apple-objc-2.0 + (logtest (pref class :objc_class.info) + #+apple-objc #$CLS_META + #+gnu-objc #$_CLS_META)) + +;; No way to tell in Objc-2.0. Does anything care ? +#-apple-objc-2.0 +(defun %objc-class-posing-p (class) + (logtest (pref class :objc_class.info) + #+apple-objc #$CLS_POSING + #+gnu-objc #$_CLS_POSING)) + + + + +;;; Create (malloc) class and metaclass objects with the specified +;;; name (string) and superclass name. Initialize the metaclass +;;; instance, but don't install the class in the ObjC runtime system +;;; (yet): we don't know anything about its ivars and don't know +;;; how big instances will be yet. +;;; If an ObjC class with this name already exists, we're very +;;; confused; check for that case and error out if it occurs. +(defun %allocate-objc-class (name superptr) + (let* ((class-name (compute-objc-classname name))) + (if (lookup-objc-class class-name nil) + (error "An Objective C class with name ~s already exists." class-name)) + (let* ((nameptr (make-cstring class-name)) + (id (register-objc-class + (make-objc-class-pair superptr nameptr) +)) + (meta-id (objc-class-id->objc-metaclass-id id)) + (meta (id->objc-metaclass meta-id)) + (class (id->objc-class id)) + (meta-name (intern (format nil "+~a" name) + (symbol-package name))) + (meta-super (canonicalize-registered-metaclass + #+apple-objc-2.0 + (#_class_getSuperclass meta) + #-apple-objc-2.0 + (pref meta :objc_class.super_class)))) + (initialize-instance meta + :name meta-name + :direct-superclasses (list meta-super)) + (setf (objc-class-id-foreign-name id) class-name + (objc-metaclass-id-foreign-name meta-id) class-name + (find-class meta-name) meta) + (%defglobal name class) + (%defglobal meta-name meta) + class))) + +;;; Set up the class's ivar_list and instance_size fields, then +;;; add the class to the ObjC runtime. +#-apple-objc-2.0 +(defun %add-objc-class (class ivars instance-size) + (setf + (pref class :objc_class.ivars) ivars + (pref class :objc_class.instance_size) instance-size) + #+apple-objc + (#_objc_addClass class) + #+gnu-objc + ;; Why would anyone want to create a class without creating a Module ? + ;; Rather than ask that vexing question, let's create a Module with + ;; one class in it and use #___objc_exec_class to add the Module. + ;; (I mean "... to add the class", of course. + ;; It appears that we have to heap allocate the module, symtab, and + ;; module name: the GNU ObjC runtime wants to add the module to a list + ;; that it subsequently ignores. + (let* ((name (make-cstring "Phony Module")) + (symtab (malloc (+ (record-length :objc_symtab) (record-length (:* :void))))) + (m (make-record :objc_module + :version 8 #|OBJC_VERSION|# + :size (record-length :odule) + :name name + :symtab symtab))) + (setf (%get-ptr symtab (record-length :objc_symtab)) (%null-ptr)) + (setf (pref symtab :objc_symtab.sel_ref_cnt) 0 + (pref symtab :objc_symtab.refs) (%null-ptr) + (pref symtab :objc_symtab.cls_def_cnt) 1 + (pref symtab :objc_symtab.cat_def_cnt) 0 + (%get-ptr (pref symtab :objc_symtab.defs)) class + (pref class :objc_class.info) (logior #$_CLS_RESOLV (pref class :objc_class.info))) + (#___objc_exec_class m))) + +#+apple-objc-2.0 +(defun %add-objc-class (class) + (#_objc_registerClassPair class)) + + + + + + + +(let* ((objc-gen-message-args (make-array 10 :fill-pointer 0 :adjustable t))) + (defun %objc-gen-message-arg (n) + (let* ((len (length objc-gen-message-args))) + (do* ((i len (1+ i))) + ((> i n) (aref objc-gen-message-args n)) + (vector-push-extend (intern (format nil "ARG~d" i)) objc-gen-message-args))))) + +(defun objc-gen-message-arglist (n) + (collect ((args)) + (dotimes (i n (args)) (args (%objc-gen-message-arg i))))) + + + +;;; Call get-objc-message-info for all known init messages. (A +;;; message is an "init message" if it starts with the string "init", +;;; and has at least one declared method that returns :ID and is not a +;;; protocol method. +(defun register-objc-init-messages () + (do-interface-dirs (d) + (dolist (init (cdb-enumerate-keys (db-objc-methods d) + #'(lambda (string) + (string= string "init" :end1 (min (length string) 4))))) + (get-objc-message-info init)))) + + +(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal) + "Maps from lists of init keywords to dispatch-functions for init messages") + + + +(defun send-objc-init-message (instance init-keywords args) + (let* ((info (gethash init-keywords *objc-init-messages-for-init-keywords*))) + (unless info + (let* ((name (lisp-to-objc-init init-keywords)) + (name-info (get-objc-message-info name nil))) + (unless name-info + (error "Unknown ObjC init message: ~s" name)) + (setf (gethash init-keywords *objc-init-messages-for-init-keywords*) + (setq info name-info)))) + (apply (objc-message-info-lisp-name info) instance args))) + + + + + + +;;; Return the "canonical" version of P iff it's a known ObjC class +(defun objc-class-p (p) + (if (typep p 'macptr) + (let* ((id (objc-class-id p))) + (if id (id->objc-class id))))) + +;;; Return the canonical version of P iff it's a known ObjC metaclass +(defun objc-metaclass-p (p) + (if (typep p 'macptr) + (let* ((id (objc-metaclass-id p))) + (if id (id->objc-metaclass id))))) + +;;; If P is an ObjC instance, return a pointer to its class. +;;; This assumes that all instances are allocated via something that's +;;; ultimately malloc-based. +(defun objc-instance-p (p) + (when (typep p 'macptr) + (let* ((idx (%objc-instance-class-index p))) + (if idx (id->objc-class idx))))) + + + + +(defun objc-private-class-id (classptr) + (let* ((info (%get-private-objc-class classptr))) + (when info + (or (private-objc-class-info-declared-ancestor info) + (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass classptr) + #-apple-objc-2.0 (pref classptr :objc_class.super_class))) + (loop + (when (%null-ptr-p super) + (return)) + (let* ((id (objc-class-id super))) + (if id + (return (setf (private-objc-class-info-declared-ancestor info) + id)) + (%setf-macptr super #+apple-objc-2.0 (#_class_getSuperclass super) + #-apple-objc-2.0 (pref super :objc_class.super_class)))))))))) + +(defun objc-class-or-private-class-id (classptr) + (or (objc-class-id classptr) + (objc-private-class-id classptr))) + + +(defun %objc-instance-class-index (p) + (unless (%null-ptr-p p) + (if (with-macptrs (q) + (safe-get-ptr p q) + (not (%null-ptr-p q))) + (with-macptrs ((parent #+apple-objc (pref p :objc_object.isa) + #+gnu-objc (pref p :objc_object.class_pointer))) + (or + (objc-class-id parent) + (objc-private-class-id parent)))))) + + +;;; If an instance, return (values :INSTANCE ) +;;; If a class, return (values :CLASS ). +;;; If a metaclass, return (values :METACLASS ). +;;; Else return (values NIL NIL). +(defun objc-object-p (p) + (let* ((instance-p (objc-instance-p p))) + (if instance-p + (values :instance instance-p) + (let* ((class-p (objc-class-p p))) + (if class-p + (values :class class-p) + (let* ((metaclass-p (objc-metaclass-p p))) + (if metaclass-p + (values :metaclass metaclass-p) + (values nil nil)))))))) + + + + + +;;; If the class contains an mlist that contains a method that +;;; matches (is EQL to) the selector, remove the mlist and +;;; set its IMP; return the containing mlist. +;;; If the class doesn't contain any matching mlist, create +;;; an mlist with one method slot, initialize the method, and +;;; return the new mlist. Doing it this way ensures +;;; that the objc runtime will invalidate any cached references +;;; to the old IMP, at least as far as objc method dispatch is +;;; concerned. +#-apple-objc-2.0 +(defun %mlist-containing (classptr selector typestring imp) + #-apple-objc (declare (ignore classptr selector typestring imp)) + #+apple-objc + (%stack-block ((iter 4)) + (setf (%get-ptr iter) (%null-ptr)) + (loop + (let* ((mlist (#_class_nextMethodList classptr iter))) + (when (%null-ptr-p mlist) + (let* ((mlist (make-record :objc_method_list + :method_count 1)) + (method (pref mlist :objc_method_list.method_list))) + (setf (pref method :objc_method.method_name) selector + (pref method :objc_method.method_types) + (make-cstring typestring) + (pref method :objc_method.method_imp) imp) + (return mlist))) + (do* ((n (pref mlist :objc_method_list.method_count)) + (i 0 (1+ i)) + (method (pref mlist :objc_method_list.method_list) + (%incf-ptr method (record-length :objc_method)))) + ((= i n)) + (declare (fixnum i n)) + (when (eql selector (pref method :objc_method.method_name)) + (#_class_removeMethods classptr mlist) + (setf (pref method :objc_method.method_imp) imp) + (return-from %mlist-containing mlist))))))) + + +(defun %add-objc-method (classptr selector typestring imp) + #+apple-objc-2.0 + (with-cstrs ((typestring typestring)) + (or (not (eql #$NO (#_class_addMethod classptr selector imp typestring))) + (let* ((m (if (objc-metaclass-p classptr) + (#_class_getClassMethod classptr selector) + (#_class_getInstanceMethod classptr selector)))) + (if (not (%null-ptr-p m)) + (#_method_setImplementation m imp) + (error "Can't add ~s method to class ~s" selector typestring))))) + #-apple-objc-2.0 + (progn + #+apple-objc + (#_class_addMethods classptr + (%mlist-containing classptr selector typestring imp)) + #+gnu-objc + ;;; We have to do this ourselves, and have to do it with the runtime + ;;; mutex held. + (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*) + (let* ((ctypestring (make-cstring typestring)) + (new-mlist nil)) + (with-macptrs ((method (external-call "search_for_method_in_list" + :address (pref classptr :objc_class.methods) + :address selector + :address))) + (when (%null-ptr-p method) + (setq new-mlist (make-record :objc_method_list :method_count 1)) + (%setf-macptr method (pref new-mlist :objc_method_list.method_list))) + (setf (pref method :objc_method.method_name) selector + (pref method :objc_method.method_types) ctypestring + (pref method :objc_method.method_imp) imp) + (if new-mlist + (external-call "GSObjCAddMethods" + :address classptr + :address new-mlist + :void) + (external-call "__objc_update_dispatch_table_for_class" + :address classptr + :void))))))) + +(defvar *lisp-objc-methods* (make-hash-table :test #'eq)) + +(defstruct lisp-objc-method + class-descriptor + sel + typestring + class-p ;t for class methods + imp ; callback ptr + ) + +(defun %add-lisp-objc-method (m) + (let* ((class (%objc-class-classptr (lisp-objc-method-class-descriptor m))) + (sel (%get-selector (lisp-objc-method-sel m))) + (typestring (lisp-objc-method-typestring m)) + (imp (lisp-objc-method-imp m))) + (%add-objc-method + (if (lisp-objc-method-class-p m) + (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) + class) + sel + typestring + imp))) + +(def-ccl-pointers add-objc-methods () + (maphash #'(lambda (impname m) + (declare (ignore impname)) + (%add-lisp-objc-method m)) + *lisp-objc-methods*)) + +(defun %define-lisp-objc-method (impname classname selname typestring imp + &optional class-p) + (%add-lisp-objc-method + (setf (gethash impname *lisp-objc-methods*) + (make-lisp-objc-method + :class-descriptor (load-objc-class-descriptor classname) + :sel (load-objc-selector selname) + :typestring typestring + :imp imp + :class-p class-p))) + impname) + + + + + +;;; If any of the argspecs denote a value of type :, push an +;;; appropriate SETQ on the front of the body. (Order doesn't matter.) +(defun coerce-foreign-boolean-args (argspecs body) + (do* ((argspecs argspecs (cddr argspecs)) + (type (car argspecs) (car argspecs)) + (var (cadr argspecs) (cadr argspecs))) + ((null argspecs) body) + (when (eq type :) + (push `(setq ,var (not (eql ,var 0))) body)))) + +(defun lisp-boolean->foreign-boolean (form) + (let* ((val (gensym))) + `((let* ((,val (progn ,@form))) + (if (and ,val (not (eql 0 ,val))) 1 0))))) + +;;; Return, as multiple values: +;;; the selector name, as a string +;;; the ObjC class name, as a string +;;; the foreign result type +;;; the foreign argument type/argument list +;;; the body +;;; a string which encodes the foreign result and argument types +(defun parse-objc-method (selector-arg class-arg body) + (let* ((class-name (objc-class-name-string class-arg)) + (selector-form selector-arg) + (selector nil) + (argspecs nil) + (resulttype nil) + (struct-return nil)) + (flet ((bad-selector (why) (error "Can't parse method selector ~s : ~a" + selector-arg why))) + (typecase selector-form + (string + (let* ((specs (pop body))) + (setq selector selector-form) + (if (evenp (length specs)) + (setq argspecs specs resulttype :id) + (setq resulttype (car (last specs)) + argspecs (butlast specs))))) + (cons ;sic + (setq resulttype (pop selector-form)) + (unless (consp selector-form) + (bad-selector "selector-form not a cons")) + (ccl::collect ((components) + (specs)) + ;; At this point, selector-form should be either a list of + ;; a single symbol (a lispified version of the selector name + ;; of a selector that takes no arguments) or a list of keyword/ + ;; variable pairs. Each keyword is a lispified component of + ;; the selector name; each "variable" is either a symbol + ;; or a list of the form ( ), where + ;; an atomic variable is shorthand for (:id ). + (if (and (null (cdr selector-form)) + (car selector-form) + (typep (car selector-form) 'symbol) + (not (typep (car selector-form) 'keyword))) + (components (car selector-form)) + (progn + (unless (evenp (length selector-form)) + (bad-selector "Odd length")) + (do* ((s selector-form (cddr s)) + (comp (car s) (car s)) + (var (cadr s) (cadr s))) + ((null s)) + (unless (typep comp 'keyword) (bad-selector "not a keyword")) + (components comp) + (cond ((atom var) + (unless (and var (symbolp var)) + (bad-selector "not a non-null symbol")) + (specs :id) + (specs var)) + ((and (consp (cdr var)) + (null (cddr var)) + (cadr var) + (symbolp (cadr var))) + (specs (car var)) + (specs (cadr var))) + (t (bad-selector "bad variable/type clause")))))) + (setq argspecs (specs) + selector (lisp-to-objc-message (components))))) + (t (bad-selector "general failure"))) + ;; If the result type is of the form (:STRUCT ), + ;; make be the first argument. + (when (and (consp resulttype) + (eq (car resulttype) :struct)) + (destructuring-bind (typespec name) (cdr resulttype) + (let* ((rtype (%foreign-type-or-record typespec))) + (if (and (typep name 'symbol) + (typep rtype 'foreign-record-type)) + (setq struct-return name + resulttype (unparse-foreign-type rtype)) + (bad-selector "Bad struct return type"))))) + (values selector + class-name + resulttype + argspecs + body + (do* ((argtypes ()) + (argspecs argspecs (cddr argspecs))) + ((null argspecs) (encode-objc-method-arglist + `(:id : ,@(nreverse argtypes)) + resulttype)) + (push (car argspecs) argtypes)) + struct-return)))) + +(defun objc-method-definition-form (class-p selector-arg class-arg body env) + (multiple-value-bind (selector-name + class-name + resulttype + argspecs + body + typestring + struct-return) + (parse-objc-method selector-arg class-arg body) + (%declare-objc-method selector-name + class-name + class-p + (concise-foreign-type resulttype) + (collect ((argtypes)) + (do* ((argspecs argspecs (cddr argspecs))) + ((null argspecs) (mapcar #'concise-foreign-type (argtypes))) + (argtypes (car argspecs))))) + (let* ((self (intern "SELF"))) + (multiple-value-bind (body decls) (parse-body body env) + (unless class-p + (push `(%set-objc-instance-type ,self) body)) + (setq body (coerce-foreign-boolean-args argspecs body)) + (if (eq resulttype :) + (setq body (lisp-boolean->foreign-boolean body))) + (let* ((impname (intern (format nil "~c[~a ~a]" + (if class-p #\+ #\-) + class-name + selector-name))) + (_cmd (intern "_CMD")) + (super (gensym "SUPER")) + (params `(:id ,self : ,_cmd))) + (when struct-return + (push struct-return params)) + (setq params (nconc params argspecs)) + `(progn + (defcallback ,impname + (:without-interrupts nil + #+(and openmcl-native-threads apple-objc) :error-return + #+(and openmcl-native-threads apple-objc) (condition objc-callback-error-return) ,@params ,resulttype) + (declare (ignorable ,_cmd)) + ,@decls + (rlet ((,super :objc_super + #+apple-objc :receiver #+gnu-objc :self ,self + #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class + ,@(if class-p + #+apple-objc-2.0 + `((external-call "_class_getSuperclass" + :address (pref (@class ,class-name) :objc_class.isa) :address)) + #-apple-objc-2.0 + `((pref + (pref (@class ,class-name) + #+apple-objc :objc_class.isa + #+gnu-objc :objc_class.class_pointer) + :objc_class.super_class)) + #+apple-objc-2.0 + `((external-call "_class_getSuperclass" + :address (@class ,class-name) :address)) + #-apple-objc-2.0 + `((pref (@class ,class-name) :objc_class.super_class))))) + (macrolet ((send-super (msg &rest args &environment env) + (make-optimized-send nil msg args env nil ',super ,class-name)) + (send-super/stret (s msg &rest args &environment env) + (make-optimized-send nil msg args env s ',super ,class-name))) + ,@body))) + (%define-lisp-objc-method + ',impname + ,class-name + ,selector-name + ,typestring + ,impname + ,class-p))))))) + +(defmacro define-objc-method ((selector-arg class-arg) + &body body &environment env) + (objc-method-definition-form nil selector-arg class-arg body env)) + +(defmacro define-objc-class-method ((selector-arg class-arg) + &body body &environment env) + (objc-method-definition-form t selector-arg class-arg body env)) + + +(declaim (inline %objc-struct-return)) + +(defun %objc-struct-return (return-temp size value) + (unless (eq return-temp value) + (#_memmove return-temp value size))) + +(defmacro objc:defmethod (name (self-arg &rest other-args) &body body &environment env) + (collect ((arglist) + (arg-names) + (arg-types) + (bool-args) + (type-assertions)) + (let* ((result-type nil) + (struct-return-var nil) + (struct-return-size nil) + (selector nil) + (cmd (intern "_CMD")) + (class-p nil) + (objc-class-name nil)) + (if (atom name) + (setq selector (string name) result-type :id) + (setq selector (string (car name)) result-type (concise-foreign-type (or (cadr name) :id)))) + (destructuring-bind (self-name lisp-class-name) self-arg + (arg-names self-name) + (arg-types :id) + ;; Hack-o-rama + (let* ((lisp-class-name (string lisp-class-name))) + (if (eq (schar lisp-class-name 0) #\+) + (setq class-p t lisp-class-name (subseq lisp-class-name 1))) + (setq objc-class-name (lisp-to-objc-classname lisp-class-name))) + (let* ((rtype (parse-foreign-type result-type))) + (when (typep rtype 'foreign-record-type) + (setq struct-return-var (gensym)) + (setq struct-return-size (ceiling (foreign-type-bits rtype) 8)) + (arglist struct-return-var))) + (arg-types :) + (arg-names cmd) + (dolist (arg other-args) + (if (atom arg) + (progn + (arg-types :id) + (arg-names arg)) + (destructuring-bind (arg-name arg-type) arg + (let* ((concise-type (concise-foreign-type arg-type))) + (unless (eq concise-type :id) + (let* ((ftype (parse-foreign-type concise-type))) + (if (typep ftype 'foreign-pointer-type) + (setq ftype (foreign-pointer-type-to ftype))) + (if (and (typep ftype 'foreign-record-type) + (foreign-record-type-name ftype)) + (type-assertions `(%set-macptr-type ,arg-name + (foreign-type-ordinal (load-time-value (%foreign-type-or-record ,(foreign-record-type-name ftype))))))))) + (arg-types concise-type) + (arg-names arg-name))))) + (let* ((arg-names (arg-names)) + (arg-types (arg-types))) + (do* ((names arg-names) + (types arg-types)) + ((null types) (arglist result-type)) + (let* ((name (pop names)) + (type (pop types))) + (arglist type) + (arglist name) + (if (eq type :) + (bool-args `(setq ,name (not (eql ,name 0))))))) + (let* ((impname (intern (format nil "~c[~a ~a]" + (if class-p #\+ #\-) + objc-class-name + selector))) + (typestring (encode-objc-method-arglist arg-types result-type)) + (signature (cons result-type (cddr arg-types)))) + (multiple-value-bind (body decls) (parse-body body env) + + (setq body `((progn ,@(bool-args) ,@(type-assertions) ,@body))) + (if (eq result-type :) + (setq body `((%coerce-to-bool ,@body)))) + (when struct-return-var + (setq body `((%objc-struct-return ,struct-return-var ,struct-return-size ,@body))) + (setq body `((flet ((struct-return-var-function () + ,struct-return-var)) + (declaim (inline struct-return-var-function)) + ,@body))) + (setq body `((macrolet ((objc:returning-foreign-struct ((var) &body body) + `(let* ((,var (struct-return-var-function))) + ,@body))) + ,@body)))) + (setq body `((flet ((call-next-method (&rest args) + (declare (dynamic-extent args)) + (apply (function ,(if class-p + '%call-next-objc-class-method + '%call-next-objc-method)) + ,self-name + (@class ,objc-class-name) + (@selector ,selector) + ',signature + args))) + (declare (inline call-next-method)) + ,@body))) + `(progn + (%declare-objc-method + ',selector + ',objc-class-name + ,class-p + ',result-type + ',(cddr arg-types)) + (defcallback ,impname ( :error-return (condition objc-callback-error-return) ,@(arglist)) + (declare (ignorable ,self-name ,cmd) + (unsettable ,self-name) + ,@(unless class-p `((type ,lisp-class-name ,self-name)))) + ,@decls + ,@body) + (%define-lisp-objc-method + ',impname + ,objc-class-name + ,selector + ,typestring + ,impname + ,class-p))))))))) + + + + + +(defun class-get-instance-method (class sel) + #+apple-objc (#_class_getInstanceMethod class sel) + #+gnu-objc (#_class_get_instance_method class sel)) + +(defun class-get-class-method (class sel) + #+apple-objc (#_class_getClassMethod class sel) + #+gnu-objc (#_class_get_class_method class sel)) + +(defun method-get-number-of-arguments (m) + #+apple-objc (#_method_getNumberOfArguments m) + #+gnu-objc (#_method_get_number_of_arguments m)) + +#+(and apple-objc (not apple-objc-2.0)) +(progn +(defloadvar *original-deallocate-hook* + #&_dealloc) + +(defcallback deallocate-nsobject (:address obj :int) + (unless (%null-ptr-p obj) + (remhash obj *objc-object-slot-vectors*)) + (ff-call *original-deallocate-hook* :address obj :int)) + +(defun install-lisp-deallocate-hook () + (setf #&_dealloc deallocate-nsobject)) + +#+later +(def-ccl-pointers install-deallocate-hook () + (install-lisp-deallocate-hook)) + +(defun uninstall-lisp-deallocate-hook () + (clrhash *objc-object-slot-vectors*) + (setf #&_dealloc *original-deallocate-hook*)) + +(pushnew #'uninstall-lisp-deallocate-hook *save-exit-functions* :test #'eq + :key #'function-name) +) + + + + + +(defloadvar *nsstring-newline* #@" +") + + +;;; Execute BODY with an autorelease pool + +(defmacro with-autorelease-pool (&body body) + (let ((pool-temp (gensym))) + `(let ((,pool-temp (create-autorelease-pool))) + (unwind-protect + (progn ,@body) + (release-autorelease-pool ,pool-temp))))) + + +(defun %make-nsstring (string) + (with-encoded-cstrs :utf-8 ((s string)) + (%make-nsstring-from-utf8-c-string s))) + + + +#+apple-objc-2.0 +;;; New!!! Improved!!! At best, half-right!!! +(defmacro with-ns-exceptions-as-errors (&body body) + `(progn ,@body)) + + + +#-apple-objc-2.0 +(defmacro with-ns-exceptions-as-errors (&body body) + #+apple-objc + (let* ((nshandler (gensym)) + (cframe (gensym))) + `(rletZ ((,nshandler :andler2)) + (unwind-protect + (progn + (external-call "__NSAddHandler2" :address ,nshandler :void) + (catch ,nshandler + (with-c-frame ,cframe + (%associate-jmp-buf-with-catch-frame + ,nshandler + (%fixnum-ref (%current-tcr) target::tcr.catch-top) + ,cframe) + (progn + ,@body)))) + (check-ns-exception ,nshandler)))) + #+gnu-objc + `(progn ,@body) + ) + + + + + +#+(and apple-objc (not apple-objc-2.0)) +(defun check-ns-exception (nshandler) + (with-macptrs ((exception (external-call "__NSExceptionObjectFromHandler2" + :address nshandler + :address))) + (if (%null-ptr-p exception) + (external-call "__NSRemoveHandler2" :address nshandler :void) + (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))) + + + + Index: /branches/experimentation/later/source/objc-bridge/objc-support.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/objc-support.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/objc-support.lisp (revision 8058) @@ -0,0 +1,490 @@ +;;;-*-Mode: LISP; Package: CCL -*- + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "BRIDGE")) + +(defun allocate-objc-object (class) + (#/alloc class)) + +(defun conforms-to-protocol (thing protocol) + (#/conformsToProtocol: thing (objc-protocol-address protocol))) + + + + +#+apple-objc +(defun iterate-over-objc-classes (fn) + (let* ((n (#_objc_getClassList (%null-ptr) 0))) + (declare (fixnum n)) + (%stack-block ((buffer (the fixnum (ash n target::word-shift)))) + (#_objc_getClassList buffer n) + (do* ((i 0 (1+ i))) + ((= i n) (values)) + (declare (fixnum i)) + (funcall fn (paref buffer (:* :id) i)))))) + +#+apple-objc +(defun count-objc-classes () + (#_objc_getClassList (%null-ptr) 0)) + +#+gnu-objc +(defun iterate-over-objc-classes (fn) + (rletZ ((enum-state :address)) + (loop + (let* ((class (#_objc_next_class enum-state))) + (if (%null-ptr-p class) + (return) + (funcall fn class)))))) + +#+gnu-objc +(defun count-objc-classes () + (let* ((n 0)) + (declare (fixnum n)) + (rletZ ((enum-state :address)) + (if (%null-ptr-p (#_objc_next_class enum-state)) + (return n) + (incf n))))) + +(defun %note-protocol (p) + (with-macptrs ((cname (objc-message-send p "name" :address))) + (let* ((namelen (%cstrlen cname)) + (name (make-string namelen))) + (declare (dynamic-extent name)) + (%str-from-ptr cname namelen name) + (let* ((proto (or (gethash name *objc-protocols*) + (progn + (setq name (subseq name 0)) + (setf (gethash name *objc-protocols*) + (make-objc-protocol :name name)))))) + (unless (objc-protocol-address proto) + (setf (objc-protocol-address proto) (%inc-ptr p 0))) + proto)))) + +(defun note-class-protocols (class) + #-apple-objc-2.0 + (do* ((protocols (pref class :objc_class.protocols) + (pref protocols :objc_protocol_list.next))) + ((%null-ptr-p protocols)) + (let* ((count (pref protocols :objc_protocol_list.count))) + (with-macptrs ((list (pref protocols :objc_protocol_list.list))) + (dotimes (i count) + (with-macptrs ((p (paref list (:* (:* (:struct :

rotocol))) i))) + (%note-protocol p)))))) + #+apple-objc-2.0 + (rlet ((p-out-count :int)) + (with-macptrs ((protocols (#_class_copyProtocolList class p-out-count))) + (let* ((n (pref p-out-count :int))) + (dotimes (i n) + (with-macptrs ((p (paref protocols (:* (:* (:struct :

rotocol))) i))) + (%note-protocol p)))) + (unless (%null-ptr-p protocols) (#_free protocols))))) + + +(defun map-objc-classes (&optional (lookup-in-database-p t)) + (iterate-over-objc-classes + #'(lambda (class) + (note-class-protocols class) + (install-foreign-objc-class class lookup-in-database-p)))) + +(let* ((nclasses 0)) + (declare (fixnum nclasses)) + (defun maybe-map-objc-classes (&optional use-db) + (let* ((new (count-objc-classes))) + (declare (fixnum new)) + (unless (= nclasses new) + (setq nclasses new) + (map-objc-classes use-db) + t))) + (defun reset-objc-class-count () + (setq nclasses 0))) + +(register-objc-class-decls) +(maybe-map-objc-classes t) +(register-objc-init-messages) + +#+gnu-objc +(defun iterate-over-class-methods (class method-function) + (do* ((mlist (pref class :objc_class.methods) + (pref mlist :objc_method_list.method_next))) + ((%null-ptr-p mlist)) + (do* ((n (pref mlist :objc_method_list.method_count)) + (i 0 (1+ i)) + (method (pref mlist :objc_method_list.method_list) + (%incf-ptr method (record-length :objc_method)))) + ((= i n)) + (declare (fixnum i n)) + (funcall method-function method class)))) + +#+gnu-objc +(progn + ;; Er, um ... this needs lots-o-work. + (let* ((objc-class-count 0)) + (defun reset-objc-class-count () (setq objc-class-count 0)) + (defun note-all-library-methods (method-function) + (do* ((i objc-class-count (1+ i)) + (class (id->objc-class i) (id->objc-class i))) + ((eq class 0)) + (iterate-over-class-methods class method-function) + (iterate-over-class-methods (id->objc-metaclass i) method-function)))) + (def-ccl-pointers revive-objc-classes () + (reset-objc-class-count))) + +(defun retain-obcj-object (x) + (objc-message-send x "retain")) + + +#+apple-objc-2.0 +(progn +(defun setup-objc-exception-globals () + (flet ((set-global (offset name) + (setf (%get-ptr (%int-to-ptr (+ target::nil-value (%kernel-global-offset offset)))) + (foreign-symbol-address name)))) + (set-global 'x86::objc-2-personality "___objc_personality_v0") + (set-global 'x86::objc-2-begin-catch "_objc_begin_catch") + (set-global 'x86::objc-2-end-catch "_objc_end_catch") + (set-global 'x86::unwind-resume "__Unwind_Resume"))) + + +(def-ccl-pointers setup-objc-exception-handling () + (setup-objc-exception-globals)) + +(setup-objc-exception-globals) +) + + +(defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers") + +;;; Encapsulate an NSException in a lisp condition. +(define-condition ns-exception (error) + ((ns-exception :initarg :ns-exception :accessor ns-exception)) + (:report (lambda (c s) + (format s "Objective-C runtime exception: ~&~a" + (nsobject-description (ns-exception c)))))) + + + +(defclass ns-lisp-exception (ns::ns-exception) + ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition)) + (:metaclass ns::+ns-object)) + +(objc:defmethod #/init ((self ns-lisp-exception)) + (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+)) + + +(defun recognize-objc-exception (x) + (if (typep x 'ns:ns-exception) + (ns-exception->lisp-condition x))) + +(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*) + +(defun %make-nsstring-from-utf8-c-string (s) + (#/initWithUTF8String: (#/alloc ns:ns-string) s)) + + +(defun retain-objc-instance (instance) + (#/retain instance)) + + +(defun create-autorelease-pool () + (#/init (#/alloc ns:ns-autorelease-pool))) + +(defun release-autorelease-pool (p) + (#/release p)) + + +#-ascii-only +(defun lisp-string-from-nsstring (nsstring) + ;; The NSData object created here is autoreleased. + (let* ((data (#/dataUsingEncoding:allowLossyConversion: + nsstring + #+little-endian-target #x9c000100 + #+big-endian-target #x98000100 + nil))) + (unless (%null-ptr-p data) + (let* ((nbytes (#/length data)) + (string (make-string (ash nbytes -2)))) + ;; BLT the 4-byte code-points from the NSData object + ;; to the string, return the string. + (%copy-ptr-to-ivector (#/bytes data) 0 string 0 nbytes))))) + + + +#+ascii-only +(defun lisp-string-from-nsstring (nsstring) + (with-macptrs (cstring) + (%setf-macptr cstring + (#/cStringUsingEncoding: nsstring #$NSASCIIStringEncoding)) + (unless (%null-ptr-p cstring) + (%get-cstring cstring)))) + + +(objc:defmethod #/reason ((self ns-lisp-exception)) + (with-slots (condition) self + (if condition + (%make-nsstring (format nil "~A" condition)) + (call-next-method)))) + +(objc:defmethod #/description ((self ns-lisp-exception)) + (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self))) + + + +(defun ns-exception->lisp-condition (nsexception) + (if (typep nsexception 'ns-lisp-exception) + (ns-lisp-exception-condition nsexception) + (make-condition 'ns-exception :ns-exception nsexception))) + + +(defmethod ns-exception ((c condition)) + "Map a lisp condition object to an NSException. Note that instances +of the NS-EXCEPTION condition class implement this by accessing an +instance variable." + ;;; Create an NSLispException with a lispid that encapsulates + ;;; this condition. + + ;; (dbg (format nil "~a" c)) + ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c))) + (make-instance 'ns-lisp-exception :condition c)) + + + +#+apple-objc +(progn + + +#+ppc-target +(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) + ;; On PPC, the "address" of an external entry point is always + ;; aligned on a 32-bit word boundary. On PPC32, it can always + ;; be represented as a fixnum; on PPC64, it might be a pointer + ;; instead. + ;; Note that this clobbers the actual (foreign) return address, + ;; replacing it with the address of #__NSRaiseError. Note also + ;; that storing the NSException object as the return value has + ;; the desired effect of causing #__NSRaiseError to be called + ;; with that NSException as its argument (because r3 is used both + ;; as the canonical return value register and used to pass the + ;; first argument on PPC.) + (process-debug-condition *current-process* condition (%get-frame-ptr)) + (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError"))))) + (if (typep addr 'fixnum) + (%set-object return-address-pointer 0 addr) + (setf (%get-ptr return-address-pointer 0) addr))) + (setf (%get-ptr return-value-pointer 0) (ns-exception condition)) + nil) + +#+x8664-target +(progn +(defloadvar *x8664-objc-callback-error-return-trampoline* + (let* ((code-bytes '(#x48 #x89 #xc7 ; movq %rax %rdi + #x66 #x48 #x0f #x7e #xc0 ; movd %xmm0,%rax + #x52 ; pushq %rdx + #xff #xe0)) ; jmp *rax + (nbytes (length code-bytes)) + (ptr (%allocate-callback-pointer 16))) + (dotimes (i nbytes ptr) + (setf (%get-unsigned-byte ptr i) (pop code-bytes))))) + +(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) + ;; The callback glue reserves space for %rax at return-value-pointer-8, + ;; for %rdx at -16, for %xmm0 at -24. Store NS-EXCEPTION in the + ;; %rax slot, the address of #_objc_exception_throw in the %rdx slot, the + ;; original return address in the %xmm0 slot, and force a return to + ;; the trampoline code above. + (process-debug-condition *current-process* condition (%get-frame-ptr)) + (setf (%get-ptr return-value-pointer -8) (ns-exception condition) + (%get-ptr return-value-pointer -16) (%get-ptr return-address-pointer 0) + (%get-ptr return-address-pointer 0) *x8664-objc-callback-error-return-trampoline*) + ;; A foreign entry point is always an integer on x8664. + (let* ((addr (%reference-external-entry-point (load-time-value (external "_objc_exception_throw"))))) + (if (< addr 0) ;unlikely + (setf (%%get-signed-longlong return-value-pointer -24) addr) + (setf (%%get-unsigned-longlong return-value-pointer -24) addr))) + nil) + + +) + + +) + + + +(defun open-main-bundle () + (#/mainBundle ns:ns-bundle)) + +;;; Create a new immutable dictionary just like src, replacing the +;;; value of each key in key-value-pairs with the corresponding value. +(defun copy-dictionary (src &rest key-value-pairs) + (declare (dynamic-extent key-value-pairs)) + ;(#_NSLog #@"src = %@" :id src) + (let* ((count (#/count src)) + (enum (#/keyEnumerator src)) + (keys (#/arrayWithCapacity: ns:ns-mutable-array count)) + (values (#/arrayWithCapacity: ns:ns-mutable-array count))) + (loop + (let* ((nextkey (#/nextObject enum))) + (when (%null-ptr-p nextkey) + (return)) + (do* ((kvps key-value-pairs (cddr kvps)) + (newkey (car kvps) (car kvps)) + (newval (cadr kvps) (cadr kvps))) + ((null kvps) + ;; Copy the key, value pair from the src dict + (#/addObject: keys nextkey) + (#/addObject: values (#/objectForKey: src nextkey))) + (when (#/isEqualToString: nextkey newkey) + (#/addObject: keys nextkey) + (#/addObject: values newval) + (return))))) + (make-instance 'ns:ns-dictionary + :with-objects values + :for-keys keys))) + + +(defun nsobject-description (nsobject) + "Returns a lisp string that describes nsobject. Note that some +NSObjects describe themselves in more detail than others." + (with-autorelease-pool + (lisp-string-from-nsstring (#/description nsobject)))) + + + + +;;; This can fail if the nsstring contains non-8-bit characters. +(defun lisp-string-from-nsstring-substring (nsstring start length) + (%stack-block ((cstring (1+ length))) + (#/getCString:maxLength:range:remainingRange: + nsstring cstring length (ns:make-ns-range start length) +null-ptr+) + (%get-cstring cstring))) + +(def-standard-initial-binding *listener-autorelease-pool* nil) + +(setq *listener-autorelease-pool* (create-autorelease-pool)) + +(define-toplevel-command :global rap () "Release and reestablish *LISTENER-AUTORELEASE-POOL*" + (when (eql *break-level* 0) + (without-interrupts + (when (boundp '*listener-autorelease-pool*) + (let* ((old *listener-autorelease-pool*)) + (if old (release-autorelease-pool old)) + (setq *listener-autorelease-pool* (create-autorelease-pool))))))) + +#+apple-objc +(defun show-autorelease-pools () + (objc-message-send (@class ns-autorelease-pool) "showPools" :void)) + +#+gnu-objc +(defun show-autorelease-pools () + (do* ((current (objc-message-send (@class ns-autorelease-pool) "currentPool") + (objc-message-send current "_parentAutoreleasePool")) + (i 0 (1+ i))) + ((%null-ptr-p current) (values)) + (format t "~& ~d : ~a [~d]" + i + (nsobject-description current) + (pref current :utorelease

ool._released_count)))) + +(define-toplevel-command :global sap () "Log information about current thread's autorelease-pool(s) to C's standard error stream" + (show-autorelease-pools)) + +(define-toplevel-command :global kap () "Release (but don't reestablish) *LISTENER-AUTORELEASE-POOL*" + (when (eql *break-level* 0) + (without-interrupts + (when (boundp '*listener-autorelease-pool*) + (let* ((p *listener-autorelease-pool*)) + (setq *listener-autorelease-pool* nil) + (release-autorelease-pool p)))))) + +;;; Use the interfaces for an add-on ObjC framework. We need to +;;; tell the bridge to reconsider what it knows about the type +;;; signatures of ObjC messages, since the new headers may define +;;; a method whose type signature differs from the message's existing +;;; methods. (This probably doesn't happen too often, but it's +;;; possible that some SENDs that have already been compiled would +;;; need to be recompiled with that augmented method type info, e.g., +;;; because ambiguity was introduced.) + +(defun augment-objc-interfaces (dirname) + (use-interface-dir dirname) + (register-objc-class-decls) + (update-objc-method-info)) + +;;; A list of "standard" locations which are known to contain +;;; framework bundles. We should look in ~/Library/Frameworks/" first, +;;; if it exists. +(defparameter *standard-framework-directories* + (list #p"/Library/Frameworks/" + #p"/System/Library/Frameworks/")) + + + +;;; This has to run during application (re-)initializtion, so it +;;; uses lower-level bridge features. +(defun %reload-objc-framework (path) + (when (probe-file path) + (let* ((namestring (native-translated-namestring path))) + (with-cstrs ((cnamestring namestring)) + (with-nsstr (nsnamestring cnamestring (length namestring)) + (with-autorelease-pool + (let* ((bundle (send (@class "NSBundle") + :bundle-with-path nsnamestring))) + (unless (%null-ptr-p bundle) + (coerce-from-bool + (objc-message-send bundle "load" :)))))))))) + + +(defun load-objc-extension-framework (name) + (let* ((dirs *standard-framework-directories*) + (home-frameworks (make-pathname :defaults nil + :directory + (append (pathname-directory + (user-homedir-pathname)) + '("Library" "Frameworks")))) + (fname (list (format nil "~a.framework" name)))) + (when (probe-file home-frameworks) + (pushnew home-frameworks dirs :test #'equalp)) + (dolist (d dirs) + (let* ((path (probe-file (make-pathname :defaults nil + :directory (append (pathname-directory d) + fname))))) + (when path + (let* ((namestring (native-translated-namestring path))) + (with-cstrs ((cnamestring namestring)) + (with-nsstr (nsnamestring cnamestring (length namestring)) + (with-autorelease-pool + (let* ((bundle (#/bundleWithPath: ns:ns-bundle nsnamestring)) + (winning (unless (%null-ptr-p bundle) + t))) + (when winning + (let* ((libpath (#/executablePath bundle))) + (unless (%null-ptr-p libpath) + (open-shared-library (lisp-string-from-nsstring + libpath)))) + (#/load bundle) + (pushnew path *extension-framework-paths* + :test #'equalp) + (map-objc-classes) + ;; Update info about init messages. + (register-objc-init-messages)) + (return winning))))))))))) + +(defun objc:load-framework (framework-name interfaces-name) + (use-interface-dir interfaces-name) + (or (load-objc-extension-framework framework-name) + (error "Can't load ObjC framework ~s" framework-name)) + (augment-objc-interfaces interfaces-name)) + + +(defmethod print-object ((p ns:protocol) stream) + (print-unreadable-object (p stream :type t) + (format stream "~a (#x~x)" + (%get-cstring (#/name p)) + (%ptr-to-int p)))) + + + + +(provide "OBJC-SUPPORT") Index: /branches/experimentation/later/source/objc-bridge/process-objc-modules.lisp =================================================================== --- /branches/experimentation/later/source/objc-bridge/process-objc-modules.lisp (revision 8058) +++ /branches/experimentation/later/source/objc-bridge/process-objc-modules.lisp (revision 8058) @@ -0,0 +1,217 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(#-(or apple-objc gnu-objc) + (eval-when (:compile-toplevel :load-toplevel :execute) + #+darwinppc-target (pushnew :apple-objc *features*) + #+linuxppc-target (pushnew :gnu-objc *features*) + #-(or darwinppc-target linuxppc-target) + (error "Not sure what ObjC runtime system to use."))) + +#+apple-objc +(progn +(defvar *objc-module-verbose* nil) + + +(defun process-section-in-all-libraries (segname sectionname function) + "For every loaded shared library, find the section named SECTIONNAME +in the segment named SEGNAME. If this section exists, call FUNCTION with +a pointer to the section data and the section's size in bytes as arguments." + (with-cstrs ((seg segname) + (sect sectionname)) + (rlet ((size :unsigned)) + (with-macptrs (mach-header sectdata) + (dotimes (i (#_ _dyld_image_count)) + (%setf-macptr mach-header (#_ _dyld_get_image_header i)) + ;; Paranoia: this should never be null + (unless (%null-ptr-p mach-header) + ;; The one instance of an MH_BUNDLE I've encountered + ;; hasn't had its section data relocated. I'm not sure + ;; if that's generally true of MH_BUNDLEs; for the time + ;; being, ignore them and concentrate on MH_DYLIBs. + (when (eql (pref mach-header :mach_header.filetype) #$MH_DYLIB) + (%setf-macptr sectdata (#_getsectdatafromheader + mach-header + seg + sect + size)) + ;; This pointer may be null, unless the shared object + ;; file denoted by "mach_header" contains a segment and + ;; section matching those we're looking for. + (unless (%null-ptr-p sectdata) + (funcall function sectdata (pref size :unsigned)))))))))) + +(defun process-objc-modules (f) + (process-section-in-all-libraries #$SEG_OBJC #$SECT_OBJC_MODULES f)) + +;;; A not-too-interesting test of the mechanism. +(defun show-objc-module-sections () + (process-objc-modules #'(lambda (sect size) + (format t "~& module section @~s, size = ~d" + sect size)))) + +(defun process-module-classes (module classfn) + (when *objc-module-verbose* + (format t "~& processing classes in module ~s" module) + (force-output t)) + (with-macptrs ((symtab (pref module :objc_module.symtab))) + (with-macptrs ((defsptr (pref symtab :objc_symtab.defs)) + (classptr)) + (dotimes (i (pref symtab :objc_symtab.cls_def_cnt)) + (%setf-macptr classptr (%get-ptr defsptr (* i (record-length :address)))) + (when *objc-module-verbose* + (format t "~& processing class ~a, info = #x~8,'0x" + (%get-cstring (pref classptr :objc_class.name)) + (pref classptr :objc_class.info)) + (force-output t)) + ;; process the class + (funcall classfn classptr) + ;; process the metaclass + (funcall classfn (pref classptr :objc_class.isa)))))) + +(defun process-module-categories (module catfn) + (with-macptrs ((symtab (pref module :objc_module.symtab))) + (with-macptrs ((catptr + (%inc-ptr (pref symtab :objc_symtab.defs) + (* (pref symtab :objc_symtab.cls_def_cnt) + (record-length :address))))) + (dotimes (i (pref symtab :objc_symtab.cat_def_cnt)) + (when *objc-module-verbose* + (format t "~& processing category ~s " + (%get-cstring (pref (%get-ptr catptr) + :objc_category.category_name)))) + (funcall catfn (%get-ptr catptr)) + (%incf-ptr catptr (record-length :address)))))) + + +;;; This is roughly equivalent to the inner loop in DO-OBJC-METHODS. +(defun process-methods-in-method-list (mlist class mfun) + (unless (%null-ptr-p mlist) + (with-macptrs ((method (pref mlist :objc_method_list.method_list))) + (dotimes (i (pref mlist :objc_method_list.method_count)) + (funcall mfun method class) + (%incf-ptr method (record-length :objc_method)))))) + +;;; Categories push method lists onto the "front" of the class. +;;; The methods that belong to the class are in the last method list, +;;; so we skip everything else here. +(defun process-class-methods (class methodfun) + (%stack-block ((iter 4)) + (setf (%get-ptr iter) (%null-ptr)) + (with-macptrs ((next) + (mlist )) + (loop + (%setf-macptr next (#_class_nextMethodList class iter)) + (when (%null-ptr-p next) + (process-methods-in-method-list mlist class methodfun) + (return)) + (%setf-macptr mlist next))))) + +(defun process-category-methods (category methodfun) + (with-macptrs ((classname (pref category :objc_category.class_name)) + (class (#_objc_lookUpClass classname)) + (metaclass (pref class :objc_class.isa)) + (instance-methods + (pref category :objc_category.instance_methods)) + (class-methods + (pref category :objc_category.class_methods))) + (process-methods-in-method-list instance-methods class methodfun) + (process-methods-in-method-list class-methods metaclass methodfun))) + +(defun process-module-methods (sectptr size methodfun) + "Process all modules in the ObjC module section SECTPTR, whose size +in bytes is SIZE. For each class and each category in each module, +call METHODFUN on each method defined in a class or category. The +METHODFUN will be called with a stack-allocated/mutable pointer to the +method, and a stack-allocated/mutable pointer to the method receiver's +class or metaclass object." + (when *objc-module-verbose* + (format t "~& processing classes in section ~s" sectptr) + (force-output t)) + (with-macptrs ((module sectptr)) + (let* ((nmodules (/ size (record-length :objc_module)))) + (dotimes (i nmodules) + (process-module-classes + module + #'(lambda (class) + (when *objc-module-verbose* + (format t "~& == processing class #x~8,'0x ~a, (#x~8,'0x) info = #x~8,'0x" + (%ptr-to-int class) + (%get-cstring (pref class :objc_class.name)) + (%ptr-to-int (pref class :objc_class.name)) + (pref class :objc_class.info))) + #+nope + (unless (logtest #$CLS_META (pref class :objc_class.info)) + (map-objc-class class)) + (process-class-methods class methodfun))) + (process-module-categories + module + #'(lambda (category) + (process-category-methods category methodfun))) + (%incf-ptr module (record-length :objc_module)))))) + +(defun iterate-over-module-classes (sectptr size classfn) + (when *objc-module-verbose* + (format t "~& processing classes in section ~s" sectptr) + (force-output t)) + (with-macptrs ((module sectptr)) + (let* ((nmodules (/ size (record-length :objc_module)))) + (dotimes (i nmodules) + (process-module-classes module classfn) + (%incf-ptr module (record-length :objc_module)))))) + + +(defun process-section-methods (sectptr size methodfun &optional + (section-check-fun #'true)) + "If SECTION-CHECK-FUN returns true when called with the (stack-allocated, +mutable) Objc modules section SECTPTR, process all methods defined +in all classes/categories in all modules in the section." + (when (funcall section-check-fun sectptr) + (process-module-methods sectptr size methodfun))) + +(defloadvar *sections-already-scanned-for-methods* ()) + +(defun check-if-section-already-scanned (sectptr) + (unless (member sectptr *sections-already-scanned-for-methods* + :test #'eql) + (push (%inc-ptr sectptr 0) ;make a heap-allocated copy! + *sections-already-scanned-for-methods*) + t)) + +(defun note-all-library-methods (method-function) + "For all methods defined in all classes and categories defined in all +ObjC module sections in all loaded shared libraries, call METHOD-FUNCTION +with the method and defining class as arguments. (Both of these arguments +may have been stack-allocated by the caller, and may be destructively +modified by the caller after the METHOD-FUNCTION returns.) + Sections that have already been scanned in the current lisp session are +ignored." + (process-objc-modules + #'(lambda (sectptr size) + (process-section-methods + sectptr + size + method-function + #'check-if-section-already-scanned)))) + + + + +) +(provide "PROCESS-OBJC-MODULES") + Index: /branches/experimentation/later/source/release-notes.txt =================================================================== --- /branches/experimentation/later/source/release-notes.txt (revision 8058) +++ /branches/experimentation/later/source/release-notes.txt (revision 8058) @@ -0,0 +1,2140 @@ +OpenMCL 1.1-pre-070722 +- This will hopefully be the last set of snapshots whose version + number contains the string "pre-"; whether or not the last + 20 months worth of "1.1-pre-yymmdd" snapshot releases are + more or less stable than something without "pre-" in its name + doesn't have too much to do much to do with whether or not "pre-" + is in the version number (and has lots to do with other things.) + I'd like to move to a model that's mostly similar to how things + have been (new version every month or two, old versions become + obsolete soon after, sometimes changes introduce binary incompatiblity) + but drop the "prerelease" designation and change the name of the + "testing" directory to something like "current". +- The FASL version didn't change (for the first time in a long time.) + It's probably a lot easier to bootstrap new sources with a new + lisp and it's probably desirable to recompile your own source + code with the new lisp, but there shouldn't be any user-visible + low-level ABI changes that make that mandatory. +- CCL::WITH-ENCODED-CSTRS (which has been unexported and somewhat + broken) is now exported and somewhat less broken. + + (ccl:with-encoded-cstrs ENCODING-NAME ((varI stringI)*) &body body) + + where ENCODING-NAME is a keyword constant that names a character + encoding executes BODY in an environment where each variable varI + is bound to a nul-terminated, dynamic-extent foreign pointer to + an encoded version of the corresponding stringI. + + (ccl:with-cstrs ((x "x")) (#_puts x)) + + is functionally equivalent to: + + (ccl:with-encoded-cstrs :iso-8859-1 ((x "x")) (#_puts x)) + + + CCL:WITH-ENCODED-CSTRS doesn't automatically prepend byte-order-marks + to its output; the size of the terminating #\NUL depends on the + number of octets-per-code-unit in the encoding. + + There are certainly lots of other conventions for expressing + the length of foreign strings besides NUL-termination (length in + code units, length in octets.) I'm not sure if it's better to + try to come up with high-level interfaces that support those + conventions ("with-encoded-string-and-length-in-octets ...") + or to try to support mid-level primitives ("number of octets + in encoded version of lisp string in specified encoding", etc.) + +- STREAM-ERRORs (and their subclasses, including READER-ERROR) + try to describe the context in which they occur a little better + (e.g., by referencing the file position if available and + by trying to show a few surrounding characters when possible.) + Since streams are usually buffered, this context information + may be incomplete, but it's often much better than nothing. + +- Hashing (where some objects are hashed by address) and OpenMCL's + GC (which often changes the addresses of lisp objects, possibly + invalidating hash tables in which those objects are used as keys) + have never interacted well; to minimize the negative effects of + this interaction, most primitive functions which access hash + tables has disabled the GC while performing that access, secure + in the knowledge that hash table keys won't be moving around + (because of GC activity in other threads) while the hash table + lookup is being performed. + + Disabling and reenabling the GC can be somewhat expensive, both + directly (in terms of the primitive operations used to do so) + and indirectly (in terms of the cost of - temporarily - not being + able to GC when otherwise desirable.) If the GC runs (and possibly + moves a hash-table key) very rarely relative to the frequency of + hash-table access - and that's probably true, much of the time - + then it seems like it'd be desirable to avoid the overhead of + disabling/reenabling the GC on every hash table access, and it'd + be correct to do this as long as we're careful about it. + + I was going to try to change all hash-table primitives to try + to make them avoid inhibiting/enabling the GC for as long as + possible, but wimped out and only did that for GETHASH. (If + another thread could GC while we're accessing a hash table, there + can still be weird intercations between things like the GC's + handling of weak objects and code which looks at the hash table, + and that weirdness seemed easier to deal with in the GETHASH case + than in some others.) + + If GETHASH's performance has improved without loss of correctness, + then it'd likely be worth trying to make similar changes to + REMHASH and CCL::PUTHASH (which implements (SETF (GETHASH ...) ...). + If problems are observed or performance still hasn't improved, it'd + probably be worth re-thinking some of this. + +- Leading tilde (~) characters in physical pathname namestrings + are expanded in the way that most shells do: + + "~user/...." can be used to refer to an absolute pathname rooted + at the home directory of the user named "user" + + "~/..." can be used to refer to an absulte pathname rooted at + the home directory of the current user. + +- The break-loop colon commands for showing the contents of + stack frames try to present the frame's contents in a way that's + (hopefully) more meaningful and useful. For each stack frame + shown in detail, the corresponding function's argument list + is printed, followed by the current values of the function's + arguments (indented slightly), a blank line, and the current + values of the function's local variables (outdented slightly.) + The old method of showing a stack frame's "raw" contents is + still available as the :RAW break loop command. + + The new style of presenting a stack-frame's contents is also + used in the Cocoa IDE. + +- It's historically been possible to create stacks (for threads + other than the original one) whose size exceeds the nominal + OS resource limits for a stack's size. (OpenMCL's threads + use multiple stacks; the stack in question is the one that + OpenMCL generally refers to as the "control" or "C" stack.) + It's not entirely clear what (if anything) the consequences + of exceeding these limits have been, but OpenMCL's GC can + use all of the available (C) stack space that it thinks it + has under some conditions, and, under OSX/Mach/Darwin, there + have been reports of excessive page file creation and paging + activity that don't seem related to heap behavior in environments + where the GC is running on (and possibly using much of) a stack + whose size greatly exceeds the hard resource limit on stack + size. + + Trying to determine exactly what was causing the excessive + pages got me trapped in a twisty maze of Mach kernel sources, + all alike. I tried to pin C stack size to the hard resource + limit on stack size and have not been able to provoke the + excessive paging problems since, but am not confident in + concluding (yet) that the problems had to do with resource + limits being exceeded. + + The hard resource limits on stack size for the OS versions + that I have readily available (in bash, do "ulimit -s -H"; + in tcsh, it's "limit -h s", don't know offhand about other + shells) are: + + unlimited on Linux + ~512M on FreeBSD + ~64M on Darwin + + The effect of observing (rather than exceeding) this limit + on the maximum depth of lisp recursion in OpenMCL is: + + * nothing, on x86-64 (the C stack is not used by lisp code + on x86-64) + + * visible on ppc32, which uses 4 32-bit words on the control + stack for each lisp function invocation + + * more visible on ppc64, which uses 4 64-bit words of control + stack for each lisp function invocation. + + That seems to suggest that (given that the actual stack resource + limit is a bit under 64M and that OpenMCL signals stack overflow + when the stack pointer gets within a few hundred KB of the actual + limit) that ppc64 threads are now limited to a maximum of about + 2000000 function calls. + + (All of this only matters if attempts are made to create threads + with large stacks; the default stack sizes in OpenMCL are usually + 1-2 MB.) + +- On a cheerier (and certainly less confusing) note: for the last few + years, OpenMCL has shipped with an extended example which provides an + integrated development environment (IDE) based on Cocoa; that's often + been described as "the demo IDE" and could also be fairly described as + "slow", "buggy", "incomplete", and "little more than a proof of + concept." + + I think that it's fair to describe the current state of the IDE as + being "less slow", "less buggy", "less incomplete", and "much more + than a proof of concept" than it has been (e.g., there's been some + actual progress over the last few months and there are plans to + try to continue working on the IDE and related tools.) It'd probably + be optimistic to call it "usable" in its current state (that may + depend on how low one's threshold of usability is), but I hope that + people who've been discouraged by the lack of IDE progress over the + last few years will see reason to be encouraged (and that anyone + interested will submit bug reports, patches, feature requests, code ...) + +- There are now "objc-bridge" and "cocoa-ide" subdirectories; by default, + REQUIRE will look in these directories for files whose name matches + a module name. Several files were moved from the "examples" directory + to "objc-bridge"; other example files, the "OpenMCL.app" skeleton + bundle, and the "hemlock" directory were moved to "cocoa-ide". + + +OpenMCL 1.1-pre-070512 +- The FASL version changed (old FASL files won't work with this + lisp version), as did the version information which tries to + keep the kernel in sync with heap images. Note that it's generally + a lot easier to recompile recent sources with recent images, e.g., + trying to compile 070512 sources with an 070407 image is unlikely + to work without tricky bootstrapping. +- Most of the changes in this release involve the calling sequence + used on x86-64. In very general terms, some kinds of function-call + intensive code may see a significant performance boost, most code + should see a slight improvement, some code might see a (hopefully + very slight) degradation, and anything significantly slower than + previous releases should be reported as a bug. + It is -possible- that some of these changes may cause errors to + be reported differently (the function reported as the function + executing when the error ocurred might be different/wrong). I + have not seen as many cases of this as I expected to when making + the change, but am also not sure that I fixed all possible cases. +- The FFI-related reader macros #_, #$, and #& all read a case-sensitive + foreign function, constant, or variable name from the input stream + and try to find the corresponding definition in the interface files. + If the name is prefixed with a #\? - as in #_?foo - the macros + return true if the definition could be found and false otherwise. + (The general idea is that this might be useful for conditionalizing + code in some cases, and there should be -some- way of quietly testing + that something's defined.) +- There is now support for making the contents of (possibly very large) + files accessible as lisp vectors. (This may be many times faster + than something like + + (let* ((stream (open pathname :direction :input :element-type 'whatever)) + (vector (make-array (file-size-to-vector-size stream) + :element-type 'whatever))) + (read-sequence vector stream)) + + but has the similar effect of making the contents of VECTOR match the + contents of the file.) + + CCL:MAP-FILE-TO-IVECTOR pathname element-type [Function] + + "element-type" should be a type specifier such that + (UPGRADED-ARRAY-ELEMENT-TYPE element-type) is a subtype + of either SIGNED-BYTE or UNSIGNED-BYTE. + + Tries to open the file named by "pathname" for reading and to + map its contents into the process's address space via #_mmap; + if successful, returns a lisp vector of element-type + (UPGRADED-ARRAY-ELEMENT-TYPE element-type) which is displaced + to an underlying (SIMPLE-ARRAY element-type (*)) whose contents + match the mapped file's. + + Because of alignment issues, the mapped file's contents will + start a few bytes (4 bytes on 32-bit platforms, 8 bytes on 64-bit + platforms) "into" the vector; the displaced array returned by + CCL:MAP-FILE-TO-IVECTOR hides this overhead, but its usually + more efficient to operate on the underlying simple 1-dimensional + array. Given a displaced array (like the value returned by + CCL:MAP-FILE-TO-IVECTOR), the CL function ARRAY-DISPLACEMENT + returns the underlying array and the displacement index in elements. + + Currently, only read-only file mapping is supported; the underlying + vector will be allocated in read-only memory, and attempts to use + (e.g.) (SETF (AREF ...) ...) to modify the mapped vector's contents + will result in memory faults. + + CCL:MAP-FILE-TO-OCTET-VECTOR pathname [Function] + + Equivalent to (CCL:MAP-FILE-TO-IVECTOR pathname '(UNSIGNED-BYTE 8)). + + CCL:UNMAP-IVECTOR displaced-vector + + If the argument is a mapped vector (as returned by + MAP-FILE-TO-IVECTOR) that has not yet been "unmapped" by this + function, undoes the memory mapping, closes the mapped file, and + adjusts its argument so that it's displaced to a 0-length vector. + + CCL:UNMAP-OCTET-VECTOR is an alias for CCL:UNMAP-IVECTOR + + Note that whether a vector's created by MAKE-ARRAY or by mapping + a file's contents, it can't have ARRAY-TOTAL-SIZE-LIMIT or more + elements. (ARRAY-TOTAL-SIZE-LIMIT is (EXPT 2 24) in 32-bit OpenMCL + and (EXPT 2 56) in 64-bit versions. + +- The lisp kernel now tries to signal memory faults that occur when + running lisp code as lisp errors. As a silly example: + + ? (defun foo (x) + "Crash and burn if X is not a list" + (declare (optimize (speed 3) (safety 0)) (list x)) + (car x)) + FOO + ? (foo 0) + > Error: Fault during read of memory address #x4 + > While executing: FOO, in process listener(1). + + The fact that things are handled this way (rather than going + into the kernel debugger with no easy way of recovering) makes + it possible to continue a session without losing work in many + cases. In a trivial example like the one above, it's relatively + easy to see that no harm has been done and the error should + not be hard to recover from. In some other cases, it may be + true that a buggy function has been scribbling ofer memory for + a while before that scribbling resulted in a machine exception. + + Moral: if you get an unexpected "memory fault" error (the + condition type is actually CCL::INVALID-MEMORY-ACCESS) and + don't understand why the fault occurred and the consequences + of continuing in the lisp session where the fault occurred, + you should view the state of that session with some suspicion. + + Faults in foreign code (should) still trap into the kernel + debugger. (It'd be nice to be able to treat these as lisp + errors with the same caveats as described above, but that + is more complicated in some cases and isn't yet implemented.) + +- An obscure kernel debugger command - (A), which tries to advance + the program counter by one instruction - is now disabled on x86-64. + (On the PPC, "one instruction" always meant "4 bytes"; implementing + this correctly on x86-64 would require the ability to at least + partially disassemble arbitrary x86-64 instructions.) + + On the other hand, the kernel debugger should be able to show + FPU registers on x86-64. + + +OpenMCL 1.1-pre-070408 +- The FASL version changed (old FASL files won't work with this + lisp version), as did the version information which tries to + keep the kernel in sync with heap images. Note that it's generally + a lot easier to recompile recent sources with recent images, e.g., + trying to compile 070408 sources with an 070214 image is unlikely + to work without tricky bootstrapping. +- There's now a Trac bug-tracking/wiki site for OpenMCL at + . It needs bug reports; please + visit that site and use the features there to report any bugs + that you find. +- DEFSTATIC (aka DEFGLOBAL) + (CCL:DEFSTATIC var value &optional doc-string) + is like DEFPARAMETER in that it proclaims the variable "var" to + be special, sets its value to "value", and sets the symbol's + VARIABLE documentation to the optional doc-string. It differs + from DEFPARAMETER in that it further asserts that the variable + should never be bound dynamically in any thread (via LET/LAMBDA/etc.); + the compiler treats any attempts to bind a "static" variable as an + error. + It is legal to change the value of a "static" variable, but since + all threads see the same (static) binding of that variable it may + be necessary to synchronize assignments made from multiple threads. + (A "static" variable binding is effectively a shared, global resource; + a dynamic binding is thread-private.) + Access to the value of a static variable is typically faster than + is access to the value a special variable that's not proclaimed to + be "static". + This functionality has been in MCL/OpenMCL for a long time under + the name CCL:DEFGLOBAL; CCL:DEFGLOBAL is an alias for CCL:DEFSTATIC, + but the latter seemed to be a better name. +- The type of foreign object that a MACPTR points to can now be + asserted (this means that a MACPTR object can contain a small + integer which identifies the alleged FOREIGN-TYPE of the object that + the points to. RLET, MAKE-RECORD, and MAKE-GCABLE-RECORD (see below) + assert the foreign type of the object that the MACPTR object they + create (as do some new features of the ObjC bridge, described further + below.) + PRINT-OBJECT on a MACPTR will try to print information about the + asserted type of that pointer, as well as information about where + the pointer was allocated (heap, stack) and whether it's scheduled + for automatic reclamation by the GC. + A few constructs that conceivable should assert the type of the + pointers they create (e.g., some flavor of PREF, SLOT-VALUE in + the ObjC bridge) don't yet do so. + A rather obvious way of exploiting typed pointers - namely, extending + DESCRIBE and INSPECT to show the contents of foreign records - is + not yet implemented. +- MAKE-GCABLE-RECORD is like MAKE-RECORD, in that it "makes an instance + of a foreign record type". (Or, to be more banal about it, uses + #_malloc to allocate a block of foreign memory of the size of the + foreign record type named by its argument.) MAKE-GCABLE-RECORD + additionally tells the lisp garbage collector that it should free + the foreign memory when the MACPTR object that describes it becomes + garbage. + When using "gcable pointers", it's important to remember the + distinction between a MACPTR object (which is a lisp object, more- + or-less like any other) and the block of foreign memory that the + MACPTR object points to. If a gcable MACPTR is the only thing + in the world ("lisp world" or "foreign world") that references + the underlying block of foreign memory, then freeing the foreign + memory when it becomes impossible to reference it is convenient + and sane. If other lisp MACPTRs reference the underlying block + of foreign memory or if the address of that foreign memory is + passed to and retained by foreign code, having the GC free the + memory may have unpleasant consequences if those other references + are used. +- CCL:FREE (which is mostly just a wrapper around #_free that allows + #_free to be called early in the bootstrapping process) is now + exported; if its argument is a gcable pointer (e.g., created via + MAKE-GCABLE-POINTER), it will tell the GC that the pointer's + foreign memory has been freed "manually" before calling #_free. +- The mechanisms used to implement locks has changed (for the curious, + the changes involve the use of spinlocks rather than a sequence + of atomic additions.) Someone demonstrated a case of deadlock + (where a thread was waiting for a lock that was available) under + the old implementation. I'm not sure that I fully understand how + that could have happened, but the new implementation at least has + the advantage of being a little easier to understand and might be + a tiny bit faster. Please let me know if either of these assumptions + was incorrect. +- An EOF (control-d) in the REPL (when standard input is a tty or pty + device) has traditionally caused an exit to the outer break loop + (or had no effect if the REPL was not in a break loop). If + CCL:*QUIT-ON-EOF* is set, an EOF causes the lisp to quit. (It + actually invokes a listener-specific method, so in a multi-listener + window system environemt, it might simply cause the listener which + receives the EOF to exit.) + None of this has any effect when running under environments like + SLIME, and (as mentioned above) only matters if the standard input + devices is a tty or pseudo-tty (where it's possible to continue + reading after an EOF has been read.) If running under an xterm + or OSX Terminal.app, standard input is probably a pty; if running + in an Emacs shell buffer or under other means under emacs, different + types of IPC mechanisms (pipes, sockets) might be used. +- SAVE-APPLICATION has historically changed the type of all MACPTR + objects (turning them into "dead macptrs", since it's generally + meaningless to refer to a foreign pointer from a previous session + and generally better to get a type error than some more mysterious + or severe failure). This no longer happens for null pointers (pointers + to address 0); COMPILE-FILE also now allows null pointers to be referenced + as constants in compiled code. +- Not entirely coincidentally, CCL:+NULL-PTR+ is now defined as a constant + (whose value is a null pointer.) In some cases, it may be more + efficient or convenient to pass CCL:+NULL-PTR+ to foreign code than + it would be to call (CCL:%NULL-PTR) to "produce" one. +- Historically, OpenMCL (and MCL) have maintained a list of open file + streams in the value of CCL:*OPEN-FILE-STREAMS*; maintaining this + list helps to ensure that streams get closed in as orderly a manner + as possible when the lisp exits. The code which accessed this list + didn't do so in a thread-safe manner. + The list is now maintained in a lexical variable; the function + CCL:OPEN-FILE-STREAMS returns a copy of that list, + CCL:NOTE-OPEN-FILE-STREAM adds its argument (a file stream) to the + list, and CCL:REMOVE-OPEN-FILE-STREAM removes its argument (a file stream) + from the list. (All of these functions use appropriate locking.) +- There were a number of timing-related problems related to PROCESS-INTERRUPT + (usually involving rapidly and repeatedly interrupting a thread over + a long period of time.) This should be a lot more reliable now + (exactly what could go wrong and why and how is all a little hard to + describe.) +- Some Linux distributions may initialize the user's environment in + a way that imposes a soft limit on the amount of virtual memory that + a process is allowed to map. OpenMCL now tries to raise this limit + before reserving what may be a very large amount of address space, + thanks to a patch from Andi Kleen. +- There were a number of problems with UTF-16 streams, found and + fixed by Takehiko Abe. +- Takehiko Abe also provided fixes for some code in "ccl:lib;xref.lisp" + and in source-file recording/reporting that (still) didn't understand + the concept of EQL-SPECIALIZER metaobjects. +- ObjC bridge and ObjC examples + The ObjC bridge provides a few new mechanisms for defining ObjC + methods, for calling ObjC "generic functions" (e.g., message sending), + and for dealing with frequently-used record types and with differences + between 32-bit and (forthcoming) 64-bit ObjC/Cocoa implementations. + + A lot of macros/functions/other things that really should have been + exported from some package for the last few years finally have been + exported from the OBJC or NS packages (and a lot of things that have + historically been internal to CCL are re-imported into CCL). + + Cocoa (and the underlying Core Graphics libraries) have historically + used 32-bit floats and 32-bit integers in data structures that describe + geometry, font sizes and metrics, and elsewhere. 64-bit Cocoa will + use 64-bit floats and 64-bit integers in many cases. + + The bridge defines the type NS:CGFLOAT as the lisp type of the + preferred float type on the platform, and the constant NS:+CGFLOAT+. + On DarwinPPC32, the foreign types :cgfloat, :nteger, and + :nteger are defined by the bridge (as 32-bit float, 32-bit + unsigned integer, and 32-bit signed integer, respectively.); these + types are defined (as 64-bit variants) in the 64-bit interfaces. + + All ObjC classes are properly named, either with a name exported + from the NS package (in the case of a predefined class declared in + the interface files) or with the name provided in the DEFCLASS + form (with :METACLASS NS:+NS-OBJECT) which defines the class from + lisp. The class's lisp name is now proclaimed to be a "static" + variable (as if by DEFSTATIC, as described above) and given the + class object as its value. In other words: + +(send (find-class 'ns:ns-application) 'shared-application) + + and + +(send ns:ns-application 'shared-application) + + are equivalent. (Since it's not legal to bind a "static" variable, + it may be necessary to rename some things so that unrelated + variables whose names coincidentally conflict with ObjC class names + don't do so.) + +- A new reader macro - #/ - reads a sequence of "constituent" characters + (including colons) from the stream on which it appears and interns + that sequence - with case preserved and colons intact - in a new package + whose name is NEXTSTEP-FUNCTIONS, exporting the symbol from that package. + This means that the act of reading "#/alloc" returns the the symbol + NEXTSTEP-FUNCTIONS:|alloc|, and the act of reading "#/initWithFrame:" + returns the symbol NEXTSTEP-FUNCTIONS:|initWithFrame:|. The intent + is that the reader macro can be used to construct symbols whose names + match ObjC message names; the reader macro tries to do some sanity + checks (such as insisting that a name that contains at least one + colon ends in a colon), but isn't totally rigourous about enforcing + ObjC message name conventions. + + A symbol read using this macro can be used as an operand in + most places where an ObjC message name can be used, such as + in the (@SELECTOR ...) construct (which is now OBJC:@SELECTOR, + btw.) + + Marco Baringer proposed the idea of using a reader macro to + construct lisp symbols which matched ObjC message names. + +- The act of interning a new symbol in the NEXTSTEP-FUNCTIONS + package triggers an interface database lookup of Objc methods + with the corresponding message name. If any such information + is found, a special type of dispatching function is created + and initialized and the weird-looking symbol is given that + dispatching function as its function definition. + + The dispatching knows how to call declared ObjC methods defined on + the message. In many cases, all methods have the same foreign type + signature, and the dispatching function merely passes any arguments + that it receives to a function that does an ObjC message send with + the indicated foreign argument and return types. In other cases, + where different ObjC messages have different type signatures, the + dispatching function tries to choose a function that handles the + right type signature based on the class of the dispatching function's + first argument. + + If new information about ObjC methods is introduced (e.g., by + using additional interface files or as ObjC methods are defined + from lisp), the dispatch function is reinitialized to recognize + newly-introduced foreign type signatures. + + The argument and result coercion that the bridge has tradionally + supported is supported by the new mechanism (e.g., : arguments + can be specified as lisp booleans and : results are returned + as lisp boolean values, and an argument value of NIL is coerced to + a null pointer if the corresponding argument type is :ID. + + Some ObjC methods accept variable numbers of arguments; the + foreign types of non-required arguments are determined by the + lisp types of those arguments (e.g., integers are passed as + integers, floats as floats, pointers as pointers, record types + by reference.) + + Some examples: + +;;; #/alloc is a known message. +? #'#/alloc +# +;;; Sadly, #/foo is not ... +? #'#/foo +> Error: Undefined function: NEXTSTEP-FUNCTIONS:|foo| + +;;; We can send an "init" message to a newly-allocated instance of +;;; "NSObject" by: + +(send (send ns:ns-object 'alloc) 'init) + +;;; or by + +(#/init (#/alloc ns:ns-object)) + + ObjC methods that "return" structures return them as gcable pointers + when called via dispatch functions. E.g., if "my-window" is an + NS:NS-WINDOW instance, then + +(#/frame my-window) + + will return a gcable pointer to a structure that describes that window's + frame rectangle. (The good news is that there's no need to use SLET + or special structure-returning message send syntax; the bad news is + that #_malloc, #_free, and the GC are all involved in the creation + and eventual destruction of structure-typed return values. Unless + and until those factors negatively affect performance, the advantages + seem to outweigh the disadvantages.) + +- Since foreign pointers are now (sometimes, somewhat) typed, it's + possible to treat pointers to some foreign types as "instances of + built-in classes." Specifically, a pointer to an :ect is + recognized as an instance of the built-in class NS:NS-RECT, a + pointer to an ize is treated as an instance of NS:NS-SIZE, + oint is recognized as NS:NS-POINT, and ange maps to + NS:NS-RANGE. (There are a few other more obscure structure + types that get this treatment, and with a little more work the + mechanism could be made extensible.) + + For each of these built-in classes: + + - a PRINT-OBJECT method is defined + + - a foreign type name derived from the class name (e.g., :NS-RECT + for NS:NS-RECT) is made an alias for the corresponding type + (so it's possible to say (RLET ((R :NS-RECT)) ...)). + + - the class is is integrated into the type system (so that + (TYPEP R 'NS:NS-RECT) is fairly efficently implemented.) + + - inlined accessor and setf inverses are defined for the structure + type's fields. In the case of an :ect, the fields in question + are the fields of the embedded point and size, so NS:NS-RECT-X, + NS:NS-RECT-Y, NS:NS-RECT-WIDTH, NS-RECT-HEIGHT and SETF inverses + are defined. The accessors and setter functions typecheck their + arguments and the setters handle coercion to the approprate type + of CGFLOAT where applicable. + + - an initialization function is defined; (NS:INIT-NS-SIZE s w h) is + roughly equivalent to (SETF (NS:NS-SIZE-WIDTH s) w + (NS:NS-SIZE-HEIGHT s) h), but might be a little more efficient. + + - a creation function is defined: (NS:NS-MAKE-POINT x y) is basically + equivalent to: + (LET ((P (MAKE-GCABLE-RECORD :NS-POINT))) + (NS:INIT-NS-POINT P X Y) + p) + + - a macro is defined which (much like RLET) stack-allocates an + instance of the foreign record type, optionally iniitializes + that instance, and executes a body of code with a variable + bound to that instance. E.g. + + (ns:with-ns-range (r loc len) + (format t "~& range has location ~s, length ~s" + (ns:ns-range-location r) (ns:ns-range-length r))) + + which is probably not the world's most realistic example. + + Note that it's possible to construct a record + instance that has a very short useful lifetime: + + (#/initWithFrame: new-view (ns:ns-make-rect 100 100 200 200)) + + The rectangle above will -eventually- get reclaimed by the GC; + if you don't want to give the GC so much work to do, you might + prefer to do: + + (ns:with-ns-rect (r 100 100 200 200) + (#/initWithFrame: new-view r)) + + + - The macro OBJC:DEFMETHOD can be used to define ObjC methods. + It looks superficially like CL:DEFMETHOD in some respects. + The syntax is: + + (OBC:DEFMETHOD name-and-result-type ((receiver-arg-and-class) &rest other-args) &body body) + + where: + + "name-and-result-type" is either an ObjC message name (use #/ !) + for methods that return a value of type :ID, or a list of an ObjC + message name and a foreign type specifier for methods with a different + foreign result type + + "receiver-type-and-class" is a two-element list whose CAR is + a variable name and whose CADR is the lisp name of an ObjC class + or metaclass. The receiver variable name can be any bindable + lisp variable name, but SELF (in some package) might be a reasonable + choice. The receiver variable is declared to be "unsettable", i.e., + it is an error to try to change the value of the receiver in the + body of the method definition. + + "other-args" are either variable names (denoting parameters of type + :ID) or 2-element lists whose first element is a variable name and + whose second element is a foreign type specifier. + + For example: + +(objc:defmethod (#/characterAtIndex: :unichar) + ((self hemlock-buffer-string) (index :nteger)) + ...) + + The method "characterAtIndex:", when invoked on an object of class + HEMLOCK-BUFFER-STRING with an additional argument of type :integer + returns a value of type :unichar.) + + Arguments that wind up as some non-:ID pointer type (pointers, + records passed by value) are represented as typed foreign pointers + (so the higher-level, type-checking accessors can be used on + arguments of type :ns-rect, :ns-pointe, etc.) + + Within the body of methods defined via OBJC:DEFMETHOD, the local + function CL:CALL-NEXT-METHOD is defined. It isn't quite as + general as CL:CALL-NEXT-METHOD is when used in a CLOS method, + but it has some of the same semantics. It accepts as many arguments + as are present in the containing method's "other args" list and + invokes version of the containing method that would have been + invoked on instances of the receiver's class's superclass with + the receiver and other provided arguments. (The idiom of passing + the current method's arguments to the next method is common enough + that the CALL-NEXT-METHOD in OBJC:DEFMETHODs should probably do + this if it receives no arguments.) + + A method defined via OBJC:DEFMETHOD that returns a structure "by value" + can do so by returning a record created via MAKE-GCABLE-RECORD, by + returning the value returned via CALL-NEXT-METHOD, or by other similar + means. Behind the scenes, there may be a pre-allocated instance of + the record type (used to support native structure-return conventions), + and any value returned by the method body will be copied to this + internal record instance. Within the body of a method defined with + OBJC:DEFMETHOD that's declared to return a structure type, the local + macro OBJC:RETURNING-FOREIGN-STRUCT can be used to access the internal + structure: + + (objc:defmethod (#/reallyTinyRectangleAtPoint: :ns-rect) + ((self really-tiny-view) (where :ns-point)) + (objc:returning-foreign-struct (r) + (ns:init-ns-rect r (ns:ns-point-x where) (ns:ns-point-y where) + single-float-epsilon single-float-epsilon) + r)) + + - If OBJC:DEFMETHOD introduces a new ObjC message, a ... message + to that effect. Sometimes, these messages are merely informative + (and barely informative, at that ...), but they may also indicate + that a message name is misspelled (or possibly missing a trailing + colon.) If a method is redefined in such a way that it's type + signature changes, a continuable error is signaled. + + - there used to be some fairly obscure reasons that led to + MAKE-OBJC-INSTANCE being a bit more efficient than MAKE-INSTANCE + in some cases (some of the methods invoked by MAKE-INSTANCE did + some extra work to handle Lisp slots even if the class didn't + define any Lisp slots. This work isn't done anymore, and consequently + there's less reason to prefer MAKE-OBJC-INSTANCE. (MAKE-OBJC-INSTANCE + is still defined and exported from the OBJC:PACKAGE). + + - the preferred means of loading an add-on framework and processing + the declarations in its interfaces has changed several times over + the last several months. The currently preferred (new) way to + do that is via the new function OBJC:LOAD-FRAMEWORK + + (OBJC:LOAD-FRAMEWORK framework-name interface-dir) + + where "framework-name" is a string which names the framework and + "interface-dir" is a keyword that names the associated set of + interfaces. OBJC:LOAD-FRAMEWORK should find and initialize the + framework bundle (looking in standard framework search paths), + introduce new ObjC classes to CLOS, update information about + declared messages and their methods' type signatures, adjust + affected dispatch functions, and make the interfaces other + definitions available. The order in which it does these + things isn't specified, and may change in the future. + + - Most Cocoa-related examples (the demo IDE, the Rubix and Webkit + examples) have been rewritten to use the new bridge features. + (I may have missed some contributed examples; if people want + to convert these, that'd be great.) It's too early to say + whether the new approach is better or worse than the old, but + I've (so far) found some of the code easier to read and maintain. + We might find that some things that (for instance) SEND does + more efficiently could and should be done via SEND (I'm thinking + mostly of struct-return stuff), but so far I haven't seen the + new stuff keel over. + + The converted code looks like "lisp code with strange-looking + function names" at first glance, and that seems about right. + The function names might get to look more familiar as the + reader becomes more familiar with Cocoa; as someone here pointed + out, it's arguably good that the function names are distinctive + in that that helps to remind the reader that these are likely + lower-level functions that are less tolerant of type- and other + errors than the typical lisp function would be. + + + +OpenMCL 1.1-pre-070214 +- The FASL version changed (old FASL files won't work with this + lisp version), as did the version information which tries to + keep the kernel in sync with heap images. +- There are new interface files for all platforms. These files + encode some foreign type information a little differently + than older ones did (notably information about foreign functions + that return structures or accept structure args by value.) The + new .cdb files can't be used by older versions of OpenMCL; using + older .cdb files with this version is "allowed, but not supported + or recommended." +- Almost all of the changes in functionality since the last (061231) + snapshots and since the CVS freeze on 070117 have to do with + relatively obscure issues having to do with passing structures + to foreign functions by value and/or returning structures from foreign + function calls. + + These idioms are fairly rare in traditional C code (though it's + fairly common to pass -pointers- to structures by reference + and sometimes to return pointers to structures. There are + a few C compiler runtime routines that perform some flavor + of integer division and return a two-element structure that + contains "quotient" and "remainder" fields, but that's typically + about the extent of the use of this idiom.) The idioms are used + much more often in Apple's Carbon and Cooca libraries and in + some of the frameworks (CoreGraphics, CoreFoundation) that those + libraries are based on. + + OpenMCL's FFI has provided some support for this in the past; + notably, it's provided support for (most of the) structure-returning + and struct-by-value conventions used on 32-bit PPC Darwin. In these + conventions, a foreign function that returned a structure received + a pointer to an instance of that structure type as a first argument, + and a function that received a structure argument by value received + the structure's contents in 32-bit word-size integer chunks (regardless + of the types or sizes of the structure's fields.) Knowledge of these + conventions was hardwired into various parts of the system (e.g., + the interface database), so that it was not generally possible to + tell whether a given foreign function returned a structure type + (or just happened to take an extra pointer argument.) + + Unfortunately, there are at least 4 other sets of conventions for + dealing with structure arguments/return values on the platforms + that OpenMCL runs on (and even the DarwinPPC32 conventions weren't + fully/correctly implemented.) OpenMCL's FFI is generally pretty + low-level, but to the extent that it's reasonable to talk about + "higher level" constructs (EXTERNAL-CALL, SEND, FF-CALL, #_), those + higher-level constructs try to enforce uniform syntax and try + to hide the platform-specific details in backend-specific functions. + + The impact of these changes should generally be pretty minimal. + In a "higher-level" construct used to call a foreign function that + returns a structure type, the first parameter in the call should + be a pointer to an instance of that structure type. + + For example, if a :rect structure is defined as: + + (def-foreign-type nil + (:struct :rect + (:width :int) + (:height :int) + (:x :int) ; x coordinate of origin + (:y :int))) + + and a foreign function named "inset_rect" takes a rect and an integer + delta and returns a new :rect "inset" by that delta, a call to that + foreign function might look like: + + (rlet ((result :rect)) + (ff-call *address-of-inset-rect* result (:struct :rect) r :int delta :(:struct rect)) + ;; or, if "inset_rect" was declared in the interface database: + (#_inset_rect result r delta)) + + + A callback that returns a :rect likewise should accept a pointer + to an instance of the :rect type as a first (unqualified) argument + and explicitly declare that it returns a (:STRUCT :RECT). + + (defcallback *address-of-inset-rect (result (:struct :rect) r :int delta (:struct :rect)) + (setf (pref result :rect.x) (+ (pref r :rect.x) delta) + (pref result :rect.y) (+ (pref r :rect.y) delta) + (pref result :rect.width) (- (pref r :rect.width) (* 2 delta)) + (pref result :rect.height) (- (pref r :rect.height) (* 2 delta)))) + + Note that this is very similar to what's been (implicitly) supported + on DarwinPPC32; the basic difference is that the return type + ("(:STRUCT :RECT)") is explicitly specified (or, in the case of #_, + specified in the interface database). Whether the "result" pointer + is actually passed as an argument or not is platform-dependent (on + DarwinPPC64, the :rect structure would be "returned" by returning + 4 :int values in 4 different machine registers), but the same syntax + can be used (and hides those details) on all platforms. + + In the examples above, we said that the (presumed source) rectangle + was passed by value as a value of type (:struct :rect), and we let + the FFI deal with the details. Historically, this parameter could + have been specified as a small unsigned integer N (denoting the + DarwinPPC32 convention of passing the structure value a N + native-word-size integer arguments.) Again, there are several + different conventions for passing and receiving structure values, + and it's best to let the FFI decide how to follow those conventions. + (Some of those conventions are quite complicated, and depend on + the size of the structure as well as the types of its fields.) + + In all cases, a callback which declares a parameter to be of a + structure type can treat that parameter as a pointer an instance of + that structure type with fields initialized by the caller (as in + the case of "r" in the example above.) + + In the ObjC bridge, the DEFINE-OBJC-METHOD macro has always provided + syntax for specifiying that the method "returns" a structure. (That + syntax is (:struct ). That continues + to be supported. + + Apple's ObjC runtime provides different functions (#_objc_msgSend and + #_objc_msgSend_stret) to handle the cases of sending messages which + return non-structure and structure results. These low-level functions + are very sensitive to whether the structure is actually returned via + an "invisible" first argument or not (this is only one of a few different + conventions on some platforms.) OpenMCL's ObjC bridge makes similar + distinctions, but uses simple, consistent rules: a message that returns + a structure should always be sent via SEND/STRET (or some variant of + SEND/STRET) and should have a first parameter of type "pointer to + returned structure type", regardless of whether or not that pointer + is actually passed to the method implementation or just used as by + some platform-specific code to transfer register values.) + + The end result of all of this (several weeks of bootstrapping) is + that most things are pretty much the same, at least on DarwinPPC32; + only foreign function calls/callbacks that involve passing structures + by value or returning structures need change at all, and the changes + generally involve being more explicit/declarative about what's going + on. These changes -do- allow these idioms to be used on other + (64-bit) platforms, and since they're heavily used in Apple GUI + libraries and since 64-bit versions of Carbon and Cocoa are announced + features of Leopard, it seemed appropriate to get support for this + stuff into the FFI on those platforms and to try to do it in a way + that hid the platform-dependent details. (I didn't expect all of + this to take so long.) + +- The initial listener PROCESS now persists across SAVE-APPLICATION. + This means that (for instance): + + ? (defvar *listener-process* (current-process)) + *LISTENER-PROCESS* + ? (save-application "new.image") + shell> openmcl new.image + ? (eq (current-process) *listener-process*) + T + ;; though of course the underlying OS thread, stacks, etc are unlikely + ;; to be "equal" in any sense. + + The current process is sometimes used to mark "ownership" of thread-private + hash-tables and streams. (Even though it doesn't make much sense for + STREAMs to persist across SAVE-APPLICATION, it does make sense for + HASH-TABLEs to do so; HASH-TABLES created with the :PRIVATE T option + and "owned" by the initial listener process continue to be owned by + that the current listener process in the new image.) + +- All of the FFI changes above do seem to allow the Cocoa IDE example + to run on ppc64/x86-64 (as well as ppc32) under Leopard, and + hopefully that'll soon be true of applications generated via Mikel + Evins' Bosco system as well. The bridge and demo code have been + conditionalized to support ObjC 2.0 on 64-bit systems, to avoid + deprecated functions and methods, and to support 64-bit Cocoa + changes. Hopefully, this has been done in a way that doesn't break + PPC32 Cocoa under Tiger (he said, quickly rushing to the nearest + PPC32 Tiger machine and breathing a sigh of relief when the Cocoa + listener appeared ..) 64-bit Cocoa sometimes used 64-bit signed and + unsigned integers in place of 32-bit integers; accordingly, the + foreign types :nteger and :nteger are defined (as 32-bit + signed/unsigned integers) on 32-bit platforms, and these types are + used in some method and type definitions. (Those integer types are + predefined in Objc 2.0, and are 64 bits wide on 64-bit platforms.) + + More pervasively (and a little more problematically), CoreGraphics + (and things built on top of it, including Cocoa) uses double-floats + instead of single-floats for many things on 64-bit hardware; the + difference is abstracted (a little) via the new CGFloat type. + This means that (for instance) code which initializes a constant-sized + NSRect on a 32-bit machines and has traditionally done so via + something like: + + (ns-make-rect 0.0 0.0 500.0 200.0) + + now needs to do something like: + + (ns-make-rect (float 0.0 ccl::+cgfloat-zero+) ..) + + in order to compile and run on both 32-bit and 64-bit platforms. + + where ccl::+cgfloat-zero+ is defined as 1.0f0 on 32-bit platforms + and as 1.0d0 on 64-bit machines. Cases involving constants won't + incur any runtime overhead and the occasional runtime overhead in + other cases -probably- isn't that great in context (compared to + initializing a view hierarchy ...) but it's certainly ugly to + look at. It's possible that some of this ugliness could be + hidden in the bridge/FFI (by making them do the necessary coercions + for you), but there are tradeoffs there. + +- The ObjC bridge has had a long-standing bug whereby a standalone + Cocoa application may have needed to find the interface databases + at runtime in order for MAKE-OBJC-INSTANCE and MAKE-INSTANCE of + an ObjC class to work. (These functions needed to be able to + send an "init" message to the newly-allocated instance, and needed + to know the type signature of that init message in order to do that.) + The current scheme tries to avoid this by pre-compiling helper + functions to enable calling all known "init" message signatures. + (More accurately, all fixed-argument "init" message signatures.) + This scheme avoids the need to send messages whose argument + and result types are computed at runtime (via %SEND), and %SEND + (a) was known to be inefficient and (b) would have a lot of + difficulty handling all known structure return/passing conventions + on supported platforms. Accordingly, %SEND has been deprecated + (with extreme prejudice, e.g., removed.) + +- a couple of little functions are defined (but their names are + not yet exported) on x86-64: ccl::rdtsc and ccl::rdtsc64 provide + access to the values returned by on-chip cycle counting instructions. + For instance: + +? (let* ((start (ccl::rdtsc))) + (sleep 1) + (- (ccl::rdtsc) start)) +1995065244 + + Hmm. Apparently, the 2.0GHz MacBook I tried that on is actually + a 1.995GHz MacBook. + + There are all kinds of ways for rdtsc to lose (and return + inaccurate or misleading results): the cycle counters for + each CPU core in a multi-core system aren't necessarily + kept in sync, and many modern systems allow CPU clock rates + to vary (for power-management reasons) and/or allow the CPU + to sleep/hibernate. OSes seem to offer some support for + compensating for these effects, and it seems like ccl::rdtsc + and ccl::rdtsc64 can be used to obtain interesting results. + + The RDTSC instruction actually returns an unsigned 64-bit + result; apparently, some Intel documentation claims that this + value will not "wrap around" to 0 at contemporary clock rates + for at least 10 years after the system was booted. (If you can + keep an Intel system running for 9 years between reboots, you + might consider telling Intel that the RDTSC counter wrapped around + a year early; they might give you a refund. Or maybe not.) + A non-negative OpenMCL64 fixnum is limited to 60 bits; the + ccl::rdtsc function truncates the 64-bit counter value so + that it fits in a non-negative fixnum; if the 10 year limit + for the 64-bit value is accurate, the 60-bit value would + wrap around after about 223 days of uptime. + + ccl::rdtsc64 returns the full 64-bit counter value, but + may return a bignum after 223 days of uptime. + +- lots of bug fixes (not all of which involved the FFI or ObjC + bridge.) + + + +openmcl 1.1-pre-061231 +- The FASL version changed (old FASL files won't work with this + lisp version), as did the version information which tries to + keep the kernel in sync with heap images. + The binary incompatibility has to do with how a few pages of + low memory in the lisp kernel's address space are mapped and + used. OpenMCL was generally assuming that these pages were + otherwise unused and could be used to map a small static data + area from the heap image file; on some platforms, the dynamic + linker may have already allocated data in those unused pages + before the lisp kernel even starts to run. Fixing this involved + changing the address of that small static data area slightly, + and this caused the addresses of some objects contained within + that static data area - notably NIL - to change, as well. +- This snapshot is otherwise just a set of bug fixes/work-in-progress + changes. +- Even though no supported filesystem actually supports versioned files, + OpenMCL now tries to retain PATHNAME-VERSION informaton for physical + pathnames. (The fact that it didn't caused several ANSI test failures.) + This change introduced/exposed a few other bugs; I think that I've + caught at least the most obvious ones, but it's possible that some + new pathname-related bugs have been introduced. +- The cron job that runs on clozure.com and updates the ChangeLog from + CVS commit info stopped running as of a system upgrade in late November. + The problem was fixed a couple of weeks ago, so it's once again meaningful + to refer to the ChangeLog for details of bug fixes. +- FSQRT and FSQRTS instructions are "optional" on the PPC. In practice, + that often meant that they are implemented on chips made by IBM and + not on chips made by Motorola/FreeScale. This version of OpenMCL + assumes that they're implemented and emulates them if they aren't. +- OSX 10.2 (Jaguar) and earlier versions are officially no longer + supported. (I honestly don't know if things have actually worked + on Jaguar in a while, but some recent changes are known not to + work on Jaguar and the kernel now inists on at least Panther on + startup. +OpenMCL 1.1-pre-061205 +- This release is intended to package up the bug fixes since + the 061110 tarballs. There aren't too many changes in + functionality or any deep architectural changes since 061110, + and it should be easy to bootstrap from current sources with + 061110 images. + (It'd still be a good idea to recompile your code with + up-to-date images, whether you download those images or + build them yourself from CVS.) +- The one (barely) notable change in functionality has to do + with how the lisp sets up pathname translations for the + "ccl" logical host when the "CCL_DEFAULT_DIRECTORY" environment + variable isn't set (e.g., when a shell script isn't used to + invoke the lisp.) Previous versions just used the current + directory; this version tries to use the directory containing + the current heap image. The new scheme might get fooled by + symbolic links (either following them or not following them + could be wrong), but it's more likely to work for people + who don't read or understand the discussion of the shell script + in the documentation. +- All (knock wood) bugs that have been reported since the 061110 + images were released should be fixed. Well, almost all. The + fixes include: + + - a typo (wrong register) in the "generic" version of the + code which implements (SETF AREF) on 2-dimensional arrays + on x86-64 + - incorrect bounds checking on vector references on x86-64, + which caused some invalid indices to be treated as valid + (usually leading to a segfault). IIRC, the invalid indices + that were erroneously accepted were fixnums whose absolute + value was > (expt 2 56). (More or less.). + - Missing stream methods (especially involving string streams) + affecting all platforms. + - Several bugs involving GCD, some of which were specific to + 64-bit platforms and some of which affected all platforms. + (These bugs sometimes affected results returned by #'/, + LCM, and other funtions.) + + - OpenMCL has only ever supported an ELEMENT-TYPE argument of + ([signed,unsigned]-byte 8|16|32|64) on binary file streams (with + 64-bit types supported only on 64-bit platforms.) It has not + previously tried to upgrade a supplied element-type to a supported + one (it does now) and any errors that resulted from supplying an + element-type that was not supported (and could not be upgraded) were + either obscure side-effects or quiet misbehavior; an error (a + SIMPLE-ERROR complaining about the unsupported element type) is now + signaled as soon as attempts to upgrade to a supported element type + fail. I believe that the current behavior is both compliant and + reasonable; it's probably better to discuss that issue on + openmcl-devel than to do so here. + + +OpenMCL 1.1-pre-061110 +- The FASL version changed (old FASL files won't work with this + lisp version), as did the version information which tries to + keep the kernel in sync with heap images. +- Several bug fixes (see ChangeLog), and modest-to-moderate + performance improvements. Notably, AREF and (SETF AREF) + of 2- and 3-dimensional arrays are open-coded in more cases + and are usually at least 5x faster than in previous versions. + If the compiler knows that the array in question is a + SIMPLE-ARRAY of appropiate dimensionality and knows the + array's element-type, the speedup can be much greater. + There are certainly opportunities for further improvements + here, both in breadth (handling more cases) and depth + (eliminating some type-and-bounds checking in safe code, + doing parts of index calculations at compile-time when + bounds and indices are constants ...), but things are + generally improved. +- QUIT and SAVE-APPLICATION work a little differently; in + particular, SAVE-APPLICATION sometimes runs after #_exit + is called (via the #_atexit mechanism). + The motivation for this change has to do with how some + environments (Cocoa, to name one) conflate the ideas of + "shutting down the GUI" with "exiting the application". + Previous versions of OpenMCL tried to work around this + by overriding some internal Cocoa methods; that approach + was never particularly attractive and (predictably) it'll + break in future OSX releases. + The new scheme (which involves letting code run after #_exit + has been called) certainly offers other ways to lose; so + far, I haven't seen evidence of such lossage. +- For historical reasons (forgotten historical reasons, in fact) + the PPC versions of OpenMCL run with floating-point underflow + exceptions disabled (the x86-64 versions enable these exceptions + by default.) This should change soon (as soon as I remember + to change it ...); it's unlikely that this will affect much + user code, but it's possible that it'll do so. +OpenMCL 1.1-pre-061024 +- The FASL version changed (old FASL files won't work with this + lisp version), as did the version information which tries to + keep the kernel in sync with heap images. +- Linux users: it's possible (depending on the distribution that + you use) that the lisp kernel will claim to depend on newer + versions of some shared libraries than the versions that you + have installed. This is mostly just an artifact of the GNU + linker, which adds version information to dependent library + references even though no strong dependency exists. If you + run into this, you should be able to simply cd to the appropriate + build directory under ccl/lisp-kernel and do a "make". +- There's now a port of OpenMCL to FreeBSD/amd64; it claims to be + of beta quality. (The problems that made it too unstable + to release as of a few months ago have been fixed; I stil run + into occasional FreeBSD-specific issues, and some such issues + may remain.) +- The Darwin X8664 port is a bit more stable (no longer generates + obscure "Trace/BKPT trap" exits or spurious-looking FP exceptions.) + I'd never want to pass up a chance to speak ill of Mach, but both + of these bugs seemed to be OpenMCL problems rather than Mach kernel + problems, as I'd previously more-or-less assumed. +- I generally don't use SLIME with OpenMCL, but limited testing + with the 2006-04-20 verson of SLIME seems to indicate that no + changes to SLIME are necessary to work with this version. +- CHAR-CODE-LIMIT is now #x110000, which means that all Unicode + characters can be directly represented. There is one CHARACTER + type (all CHARACTERs are BASE-CHARs) and one string type (all + STRINGs are BASE-STRINGs.) This change (and some other changes + in the compiler and runtime) made the heap images a few MB larger + than in previous versions. +- As of Unicode 5.0, only about 100,000 of 1114112./#x110000 CHAR-CODEs + are actually defined; the function CODE-CHAR knows that certain + ranges of code values (notably #xd800-#xddff) will never be valid + character codes and will return NIL for arguments in that range, + but may return a non-NIL value (an undefined/non-standard CHARACTER + object) for other unassigned code values. +- The :EXTERNAL-FORMAT argument to OPEN/LOAD/COMPILE-FILE has been + extended to allow the stream's character encoding scheme (as well + as line-termination conventions) to be specified; see more + details below. MAKE-SOCKET has been extended to allow an + :EXTERNAL-FORMAT argument with similar semantics. +- Strings of the form "u+xxxx" - where "x" is a sequence of one + or more hex digits- can be used as as character names to denote + the character whose code is the value of the string of hex digits. + (The + character is actually optional, so #\u+0020, #\U0020, and + #\U+20 all refer to the #\Space character.) Characters with codes + in the range #xa0-#x7ff (IIRC) also have symbolic names (the + names from the Unicode standard with spaces replaced with underscores), + so #\Greek_Capital_Letter_Epsilon can be used to refer to the character + whose CHAR-CODE is #x395. +- The line-termination convention popularized with the CP/M operating + system (and used in its descendants) - e.g., CRLF - is now supported, + as is the use of Unicode #\Line_Separator (#\u+2028). +- About 15-20 character encoding schemes are defined (so far); these + include UTF-8/16/32 and the big-endian/little-endian variants of + the latter two and ISO-8859-* 8-bit encodings. (There is not + yet any support for traditional (non-Unicode) ways of externally + encoding characters used in Asian languages, support for legacy + MacOS encodings, legacy Windows/DOS/IBM encodings, ...) It's hoped + that the existing infrastructure will handle most (if not all) of + what's missing; that may not be the case for "stateful" encodings + (where the way that a given character is encoded/decoded depend + on context, like the value of the preceding/following character.) +- There isn't yet any support for Unicode-aware collation (CHAR> + and related CL functions just compare character codes, which + can give meaningless results for non-STANDARD-CHARs), case-inversion, + or normalization/denormalization. There's generally good support + for this sort of thing in OS-provided libraries (e.g., CoreFoundation + on MacOSX), and it's not yet clear whether it'd be best to duplicate + that in lisp or leverage library support. +- Unicode-aware FFI functions and macros are still in a sort of + embryonic state if they're there at all; things like WITH-CSTRs + continue to exist (and continue to assume an 8-bit character + encoding.) +- Characters that can't be represented in a fixed-width 8-bit + character encoding are replaced with #\Sub (= (code-char 26) = + ^Z) on output, so if you do something like: + +? (format t "~a" #\u+20a0) + + you might see a #\Sub character (however that's displayed on + the terminal device/Emacs buffer) or a Euro currency sign or + practically anything else (depending on how lisp is configured + to encode output to *TERMINAL-IO* and on how the terminal/Emacs + is configured to decode its input. + + On output to streams with character encodings that can encode + the full range of Unicode - and on input from any stream - + "unencodable characters" are represented using the Unicode + #\Replacement_Character (= #\U+fffd); the presence of such a + character usually indicates that something got lost in translation + (data wasn't encoded properly or there was a bug in the decoding + process.) +- Streams encoded in schemes which use more than one octet per code unit + (UTF-16, UTF-32, ...) and whose endianness is not explicit will be + written with a leading byte-order-mark character on (new) output and + will expect a BOM on input; if a BOM is missing from input data, + that data will be assumed to have been serialized in big-endian order. + Streams encoded in variants of these schemes whose endianness is + explicit (UTF-16BE, UCS-4LE, ...) will not have byte-order-marks written + on output or expected on input. (UTF-8 streams might also contain + encoded byte-order-marks; even though UTF-8 uses a single octet per + code unit - and possibly more than one code unit per character - this + convention is sometimes used to advertise that the stream is UTF-8- + encoded. The current implementation doesn't skip over/ignore leading + BOMs on UTF8-encoded input, but it probably should.) + + If the preceding paragraph made little sense, a shorter version is + that sometimes the endianness of encoded data matters and there + are conventions for expressing the endianness of encoded data; I + think that OpenMCL gets it mostly right, but (even if that's true) + the real world may be messier. +- By default, OpenMCL uses ISO-8859-1 encoding for *TERMINAL-IO* + and for all streams whose EXTERNAL-FORMAT isn't explicitly specified. + (ISO-8859-1 just covers the first 256 Unicode code points, where + the first 128 code points are equivalent to US-ASCII.) That should + be pretty much equivalent to what previous versions (that only + supported 8-bit characters) did, but it may not be optimal for + users working in a particular locale. The default for *TERMINAL-IO* + can be set via a command-line argument (see below) and this setting + persists across calls to SAVE-APPLICATION, but it's not clear that + there's a good way of setting it automatically (e.g., by checking + the POSIX "locale" settings on startup.) Thing like POSIX locales + aren't always set correctly (even if they're set correctly for + the shell/terminal, they may not be set correctly when running + under Emacs ...) and in general, *TERMINAL-IO*'s notion of the + character encoding it's using and the "terminal device"/Emacs subprocess's + notion need to agree (and fonts need to contain glyphs for the + right set of characters) in order for everything to "work". Using + ISO-8859-1 as the default seemed to increase the likelyhood that + most things would work even if things aren't quite set up ideally + (since no character translation occurs for 8-bit characters in + ISO-8859-1.) +- In non-Unicode-related news: the rewrite of OpenMCL's stream code + that was started a few months ago should now be complete (no more + "missing method for BASIC-STREAM" errors, or at least there shouldn't + be any.) +- I haven't done anything with the Cocoa bridge/demos lately, besides + a little bit of smoke-testing. + +Some implementation/usage details: + +Character encodings. + +CHARACTER-ENCODINGs are objects (structures) that're named by keywords +(:ISO-8859-1, :UTF-8, etc.). The structures contain attributes of +the encoding and functions used to encode/decode external data, but +unless you're trying to define or debug an encoding there's little +reason to know much about the CHARACTER-ENCODING objects and it's +generally desirable (and sometimes necessary) to refer to the encoding +via its name. + +Most encodings have "aliases"; the encoding named :ISO-8859-1 can +also be referred to by the names :LATIN1 and :IBM819, among others. +Where possible, the keywordized name of an encoding is equivalent +to the preferred MIME charset name (and the aliases are all registered +IANA charset names.) + +NIL is an alias for the :ISO-8859-1 encoding; it's treated a little +specially by the I/O system. + +The function CCL:DESCRIBE-CHARACTER-ENCODINGS will write descriptions +of all defined character encodings to *terminal-io*; these descriptions +include the names of the encoding's aliases and a doc string which +briefly describes each encoding's properties and intended use. + +Line-termination conventions. + +As noted in the <=1.0 documentation, the keywords :UNIX, :MACOS, and +:INFERRED can be used to denote a stream's line-termination conventions. +(:INFERRED is only useful for FILE-STREAMs that're open for :INPUT or +:IO.) In this release, the keyword :CR can also be used to indicate +that a stream uses #\Return characters for line-termination (equivalent +to :MACOS), the keyword :UNICODE denotes that the stream uses Unicode +#\Line_Separator characters to terminate lines, and the keywords :CRLF, +:CP/M, :MSDOS, :DOS, and :WINDOWS all indicate that lines are terminated +via a #\Return #\Linefeed sequence. + +In some contexts (when specifying EXTERNAL-FORMATs), the keyword :DEFAULT +can also be used; in this case, it's equivalent to specifying the value +of the variable CCL:*DEFAULT-LINE-TERMINATION*. The initial value of +this variable is :UNIX. + +Note that the set of keywords used to denote CHARACTER-ENCODINGs and +the set of keywords used to denote line-termination conventions is +disjoint: a keyword denotes at most a character encoding or a line +termination convention, but never both. + +External-formats. + +EXTERNAL-FORMATs are also objects (structures) with two read-only +fields that can be accessed via the functions EXTERNAL-FORMAT-LINE-TERMINATION +and EXTERNAL-FORMAT-CHARACTER-ENCODING; the values of these fields are +line-termination-convention-names and character-encoding names as described +above. + +An EXTERNAL-FORMAT object via the function MAKE-EXTERNAL-FORMAT: + +MAKE-EXTERNAL-FORMAT &key domain character-encoding line-termination + +(Despite the function's name, it doesn't necessarily create a new, +unique EXTERNAL-FORMAT object: two calls to MAKE-EXTERNAL-FORMAT +with the same arguments made in the same dynamic environment will +return the same (eq) object.) + +Both the :LINE-TERMINATION and :CHARACTER-ENCODING arguments default +to :DEFAULT; if :LINE-TERMINATION is specified as or defaults to +:DEFAULT, the value of CCL:*DEFAULT-LINE-TERMINATION* is used to +provide a concrete value. + +When the :CHARACTER-ENCODING argument is specifed as/defaults to +:DEFAULT, the concrete character encoding name that's actually used +depends on the value of the :DOMAIN argument to MAKE-EXTERNAL-FORMAT. +The :DOMAIN-ARGUMENT's value can be practically anything; when it's +the keyword :FILE and the :CHARACTER-ENCODING argument's value is +:DEFAULT, the concrete character encoding name that's used will be +the value of the variable CCL:*DEFAULT-FILE-CHARACTER-ENCODING*; the +initial value of this variable is NIL (which is an alias for :ISO-8859-1). +If the value of the :DOMAIN argument is :SOCKET and the :CHARACTER-ENCODING +argument's value is :DEFAULT, the value of +CCL:*DEFAULT-SOCKET-CHARACTER-ENCODING* is used as a concrete character +encoding name. The initial value of CCL:*DEFAULT-SOCKET-CHARACTER-ENCODING* +is NIL, again denoting the :ISO-8859-1 encoding. +If the value of the :DOMAIN argument is anything else, :ISO-8859-1 is +also used (but there's no way to override this.) + +The result of a call to MAKE-EXTERNAL-FORMAT can be used as the value +of the :EXTERNAL-FORMAT argument to OPEN, LOAD, COMPILE-FILE, and +MAKE-SOCKET; it's also possible to use a few shorthand constructs +in these contexts: + +* if ARG is unspecified or specified as :DEFAULT, the value of the + variable CCL:*DEFAULT-EXTERNAL-FORMAT* is used. Since the value + of this variable has historically been used to name a default + line-termination convention, this case effectively falls into + the next one: +* if ARG is a keyword which names a concrete line-termination convention, + an EXTERNAL-FORMAT equivalent to the result of calling + (MAKE-EXTERNAL-FORMAT :line-termination ARG) + will be used +* if ARG is a keyword which names a character encoding, an EXTERNAL-FORMAT + equvalent to the result of calling + (MAKE-EXTERNAL-FORMAT :character-encoding ARG) + will be used +* if ARG is a list, the result of (APPLY #'MAKE-EXTERNAL-FORMAT ARG) + will be used + +(When MAKE-EXTERNAL-FORMAT is called to create an EXTERNAL-FORMAT +object from one of these shorthand designators, the value of the +:DOMAIN keyword argument is :FILE for OPEN,LOAD, and COMPILE-FILE +and :SOCKET for MAKE-SOCKET.) + +STREAM-EXTERNAL-FORMAT. +The CL function STREAM-EXTERNAL-FORMAT - which is portably defined +on FILE-STREAMs - can be applied to any open stream in this release +and will return an EXTERNAL-FORMAT object when applied to an open +CHARACTER-STREAM. For open CHARACTER-STREAMs (other than STRING-STREAMs), +SETF can be used with STREAM-EXTERNAL-FORMAT to change the stream's +character encoding, line-termination, or both. + +If a "shorthand" external-format designator is used in a call to +(SETF STREAM-EXTERNAL-FORMAT), the "domain" used to construct an +EXTERNAL-FORMAT is derived from the class of the stream in the +obvious way (:FILE for FILE-STREAMs, :SOCKET for ... well, for +sockets ...) + +Note that the effect or doing something like: + +(let* ((s (open "foo" ... :external-format :utf-8))) + ... + (unread-char ch s) + (eetf (stream-external-format s) :us-ascii) + (read-char s)) + +might or might not be what was intended. The current behavior is +that the call to READ-CHAR will return the previously unread character +CH, which might surprise any code which assumes that the READ-CHAR +will return something encodable in 7 or 8 bits. Since functions +like READ may call UNREAD-CHAR "behind your back", it may or may +not be obvious that this has even occurred; the best approach to +dealing with this issue might be to avoid using READ or explicit +calls to UNREAD-CHAR when processing content encoded in multiple +external formats. + +There's a similar issue with "bivalent" streams (sockets) which +can do both character and binary I/O with an :ELEMENT-TYPE of +(UNSIGNED-BYTE 8). Historically, the sequence: + + (unread-char ch s) + (read-byte s) + +caused the READ-BYTE to return (CHAR-CODE CH); that made sense +when everything was implicitly encoded as :ISO-8859-1, but may not +make any sense anymore. (The only thing that seems to make sense +in that case is to clear the unread character and read the next +octet; that's implemented in some cases but I don't think that +things are always handled consistently.) + +Command-line argument for specifying the character encoding to +be used for *TERMINAL-IO*. + +Shortly after a saved lisp image starts up, it creates the standard +CL streams (like *STANDARD-OUTPUT*, *TERMINAL-IO*, *QUERY-IO*, etc.); +most of these streams are usually SYNONYM-STREAMS which reference +the TWO-WAY-STREAM *TERMINAL-IO*, which is itself comprised of +a pair of CHARACTER-STREAMs. The character encoding used for +any CHARACTER-STREAMs created during this process is the one +named by the value of the variable CCL:*TERMINAL-CHARACTER-ENCODING-NAME*; +this value is initially NIL. + +The -K or --terminal-encoding command-line argument can be used to +set the value of this variable (the argument is processed before the +standard streams are created.) The string which is the value of +the -K/--terminal-encoding argument is uppercased and interned in +the KEYWORD package; if an encoding named by that keyword exists, +CCL:*TERMINAL-CHARACTER-ENCODING-NAME* is set to the name of that +encoding. For example: + +shell> openmcl -K utf-8 + +will have the effect of making the standard CL streams use :UTF-8 +as their character encoding. + +(It's probably possible - but a bit awkward - to use (SETF EXTERNAL-FORMAT) +from one's init file or --eval arguments or similar to change existing +streams' character encodings; the hard/awkward parts of doing so include +the difficulty of determining which standard streams are "real" character +streams and which are aliases/composite streams.) + +OpenMCL 1.1-pre-069826 +- There's an (alpha-quality, maybe) port to x86-64 Darwin (e.g., the + Mac Pro.) Some known problems include: + + * infrequently (but not infrequently enough) the lisp dies on + startup with a spurious "Trace/BKPT trap" error message. This + seems to be timing-dependent and (very generally) seems to + involve the Mach exception thread not recognizing an exception + used to effect exception return. Sometimes, this shows up + as a (:SIGNALED 5) error when REBUILD-CCL runs the lisp to + create a new image. + + * some math library primitives (#_asin, for one) generate + spurious incidental FP exceptions that have nothing to + do with the validity of the arguments or result. To work around + this, the lisp ignores FP exceptions which might have occurred + during a call into the math library; that means that it doesn't + detect -real- FP exceptions when they're signaled. (This bug + only affects things that call into the system math library; + lisp arithmetic operations that're done inline are not affected.) + + * The version of OSX/Darwin that shipped with the Mac Pro is missing + some functionality that from OpenMCL's point of view is highly + desirable (namely, the ability to keep application-level thread- + specific data in a per-thread block of memory addressed by an + otherwise unused segment register.) To get things working (as + well as they are), the lisp "shares" the segment register that + the pthreads library uses to access thread data. This scheme + isn't intended to be long-lived (and negatively affects + performance of things like foreign-function calls, callbacks, + and exception handling). + + * The .cdb files (libc only for Tiger) in ccl:darwin-x86-headers64; + were cross-developed on a Linux x86-64 system, since Apple + has not yet released the sources to their x86-64 enabled gcc. + +- On all platforms, stream code has been rewritten and often offers + better (sometimes substantially better) performance. OPEN and + MAKE-SOCKET have each been extended to take additional keyword + arguments. + + :SHARING, which can have the values :PRIVATE (the default), :LOCK, + or :EXTERNAL (NIL is also accepted as synonym for :EXTERNAL) + + :PRIVATE specifies that the stream can only be accessed by + the thread that created it. (There was some discussion on openmcl-devel + about the idea of "transferring ownership" of a stream; this has + not yet been implemented.) Attempts to do I/O on a stream with + :PRIVATE sharing from a thread other than the stream's owner yield + an error. + + :LOCK specifies that all access to the stream require the calling + thread to obtain a lock; there are separate "read" and "write" + locks for IO streams (so it's possible for one thread to read + from such a stream while another thread writes to it, for instance.) + :LOCK was the implicit default for all streams prior to this change. + (See below - under the discussion of the AUTO-FLUSH mechanism - + for a discussion of one of the implications of this change that + affects SLIME users.) + + :EXTERNAL (or NIL) specifies that I/O primitives enforce no + access protocol. This may be appropriate for some types of application + which can control stream access via application-level protocols. Note + that since even the act of reading from a stream changes its internal + state (and simultaneous access from multiple threads can therefore + lead to corruption of that state), some care must be taken in the + design of such protocols. + + The :BASIC keyword argument influences whether or not the stream + will be an instance of the class FUNDAMENTAL-STREAM (the superclass + from which all Gray stream classes inherit) or a subclass of the + built-in class CCL::BASIC-STREAM. The default value of :BASIC + is T and this has effect for FILE-STREAMs created via OPEN; + SOCKETs are still always implemented as FUNDAMENTAL (Gray) streams, + though this should change soon. + + The tradeoff between FUNDAMENTAL and BASIC streams is entirely + between flexibility and (potential or actual) performance. I/O + primitives can recognize BASIC-STREAMs and exploit knowledge of + implementation details; FUNDAMENTAL stream classes can be + subclassed in a semi-standard way (the Gray streams protocol.) + + For existing stream classes (FILE-STREAMs, SOCKETs, and the + internal CCL::FD-STREAM classes used to implement file streams + and sockets), a lot of code can be shared between the + FUNDAMENTAL and BASIC implementations. The biggest difference + should be that that code can be reached from I/O primitives + like READ-CHAR without going through some steps that're there + to support generality and extensibility, and skipping those + steps when that support isn't needed can improve I/O performance. + + Gray stream methods (STREAM-READ-CHAR) should work on + appropriate BASIC-STREAMs. (There may still be cases where + such methods are undefined; such cases should be considered + bugs.) It is not guaranteed that Gray stream methods would + ever be called by I/O primitives to read a character from + a BASIC-STREAM (though there are still cases where this happens.) + + A simple loop reading 2M characters from a text file runs about + 10X faster when the file is opened the new defaults (:SHARING :PRIVATE + :BASIC T) than it had before these changes were made. That sounds + good, until one realizes that the "equivalent" C loop can be about + 10X faster still ... + + - Forcing output to interactive streams. + + OpenMCL has long had a (mostly undocumented) mechanism whereby + a mostly idle thread wakes up a few (~3) times per second and + calls FORCE-OUTPUT on specified OUTPUT-STREAMS; this helps to + ensure that streams with which a user would be expected to + interact (the output side of *TERMINAL-IO*, listener windows + in a GUI, etc.) have all buffered output flushed without + requiring application or I/O library code to be concerned about + that. + + The SLIME lisp interaction mode for Emacs uses this mechanism, + but the changes described above interfere with SLIMEs use of + it: in order to be safely accessed from multiple threads (the + SLIME REPL thread and the thread which does the background + periodic flushing of buffered output), a stream must have + been created with :SHARING :LOCK in effect. This is no longer + the effective default; the code which does the periodic + output flushing ignores streams which do not use locks as an + access/sharing mechanism. THIS MEANS THAT BUFFERRED OUTPUT + TO SLIME REPLs WILL NOT BE AUTOMATICALLY FLUSHED TO THE SCREEN. + A small change to SLIME's "swank-openmcl.lisp" is required + to restore this functionality. First, a brief description of + a couple of new primitives: + + (CCL:ADD-AUTO-FLUSH-STREAM s) + + Adds "s", which should be a "simple" OUTPUT-STREAM as returned + by OPEN or MAKE-SOCKET, to a list of streams whose buffered + output should be periodically flushed. If S was not created + with :SHARING :LOCK in effect, the stream will have its + :SHARING mode changed to put :SHARING :LOCK into effect. + + (CCL:REMOVE-AUTO-FLUSH-STREAM s) + + Removes S from the internal list of automatically flushed + streams. Does not restore the stream's :SHARING mode, which + may have been changed by a previous call to ADD-AUTO-FLUSH-STREAM. + + - SLIME changes + In slime:swank-openmcl.lisp, around line 182, the method + +(defmethod make-stream-interactive ((stream ccl:fundamental-output-stream)) + (push stream ccl::*auto-flush-streams*)) + + should be changed to use CCL:ADD-AUTOFLUSH-STREAM if it's defined: + +(defmethod make-stream-interactive ((stream ccl:fundamental-output-stream)) + (if (fboundp 'ccl::add-auto-flush-stream) + (ccl::add-auto-flush-stream stream) + (push stream ccl::*auto-flush-streams*))) + + That's adequate for the moment, since sockets are still + FUNDAMENTAL-STREAMs. When that changes, some more extensive changes + to swank-openmcl.lisp may become necessary. + +- on x86-64, floating-point-underflow exceptions are now enabled + by default. (They really should be on ppc as well.) Again, + this affects FP operations that are done in lisp code and + the results of FP operations that are reported in response + to calls to reasonable (non-Darwin) math libraries. This + can affect whether or not some "potential number" reader + tokens are representable as numbers, e.g., whether or not + attempts to read something like "1.0f-50" signal underflow + or are quietly mapped to 0.0f0. + +- examples: Phil (from the mailing list) has added code which + supports some of the ffi examples from the documentation. + +- Bug fixes: see ChangeLog + + + +OpenMCL 1.1-pre-060705 +- Bug fixes again. Some internal changes to support a FreeBSD/AMD64 + port that's not quite ready. + +- :MCL is back on *features*; there seem to be too many packages out + there that expect it to be, and there hasn't been enough advance + notice of its pending removal. + +OpenMCL 1.1-pre-060623 +- Mostly bug fixes (a CLOS bug that prevented the ObjC bridge from + working, FIXNUM arrays weren't quite finished on PPC) + +- Use Tiger inferfaces (from XCode 10.4u SDK) on DarwinPPC32 + +- Add gl, gtk2, gnome2 interfaces for x86-64. Add a tiny + "gtk2-clock" example, tweak the opengl-ffi (GLUT) example + so that it works on x86-64. + +- Some changes to the ObjC bridge to support loading additional + frameworks; update the WebKit example to use these new features. + +- Still an outstanding issue where things like MAKE-OBJC-INSTANCE + need access to the interfaces at runtime (and can crash if they + aren't available.) + +- Build snapshots for LinuxPPC{32,64}. + +OpenMCL 1.1-pre-060608 +- The FASL version changed, as did the version number which pairs + the lisp kernel with heap images. Images saved with older kernels + can't be loaded on this one; the images/kernels in the 060608 + snapshot tarballs should match. + + Most of the ABI changes that caused these version changes were + x86-64 specific; some auxiliary stack pointers that had been + kept in MMX registers are now kept in per-thread memory. (Signal/ + exception handlers generally need to be able to access these + stack pointers, but at least some versions of the Linux kernel + don't reliably pass correct values of the MMX registers in the + signal contexts passed to signal handlers. Moral: some kinds + of stack-allocation and foreign-function operations may (or may not) + be a few cycles slower, but OpenMCL should be a bit less prone + to fatal segfault exceptions.) + + Other than that, most changes since the 060530 snapshots are + bugfixes (see the ChangeLog for details). The x86-64 port has been + exercised fairly heavily (if somewhat narrowly) and its welcome + banner now claims that it's a beta release. I think that that's + probably fair, and hope that anyone who may have been reluctant to + test an alpha release will agree and be less reluctant. + +- There's still much more to be done, but some preliminary 1.1 documentation + is now online at: + + + + Note that some relative links on "newsite" may be invalid, but the + internal links in the Doc directory should work. + + As noted above, it still needs a lot of work; feedback, criticism, + and help would all be appreciated. + +OpenMCL 1.1-pre-060530 + +- These release notes have gotten woefully out of date. + +- OpenMCL now runs on x86-64 (AMD64, Intel EM64T) systems under Linux. + It announces itself as an alpha release in the Welcome banner; it should + in fact be very nearly feature-complete (but possibly still buggy.) + There's a chicken-and-egg issue in that it needs more testing before + it can be formally released and some people may be waiting for a more + stable version. + + The build process and most user-visible things should behave the same + way as on PPC; using REBUILD-CCL (described below) is generally the + simplest way to rebuild from sources. A few (intentional) differences: + + * the lisp kernel is named "lx86cl64", the default heap image is + named "LX86CL64" (e.g., the kernel name, case-inverted) and the + bootstrapping image is conventionally named "x86-boot64". + + * FASL files have the extension "lx64fsl" + + * the kernel build directory is "ccl/lisp-kernel/linuxx8664" + + * the "openmcl64" shell script can be used to invoke the + lisp, as on 64-bit PPC platforms. + +Other changes tend to be a little more modest: + +- there is now a specialized FIXNUM array element type on all platforms. + (distinct from T or (SIGNED-BYTE )). Access to + such vectors is a little cheaper than the SIGNED-BYTE case (since + elements are known to be fixnums) and a little easier on the GC + than the T case (the GC can avoid looking at their contents and + there are no associated EGC write-barrier issues.) + +- "colon" commands entered into the REPL/break loops don't need to + be parenthesized if the command and all operands are on the same + line. E.g. + +1> :f 0 + + and + +1> (:f 0) + + are equivalent (and have the effect of examining the raw contents of + the 0th stack frame) + +- the syntax of the :B (backtrace) break-loop has changed; rather + than taking an optional argument which specifies whether or not + frame details should be shown, it now accepts keyword arguments + for specifying: + + :start ; unsigned integer: the index of the first frame to show + :count ; unsigned integer: the maximum number of frames to show + :detailed-p ; boolean: whether or not to show frame detail + +- a new break-loop command :NFRAMES returns the number of stack frames + accessible to backtrace. (Both this change and the previous + are intended to help deal with deep recursion/stack overflow cases.) + +- any command-line arguments that follow a "--" pseudo-argument + are not processed by the lisp startup code and are stored + (as a list of strings) in CCL:*UNPROCESSED-COMMAND-LINE-ARGUMENTS*. + E.g.: + +shell> openmcl -- -foo 17 +[...] +? ccl:*UNPROCESSED-COMMAND-LINE-ARGUMENTS* +=> ("-foo" "17") + +OpenMCL 1.1-pre-060226 + +- The --thread-stack-size (or -Z) command-line argument changes the values + of the variables used to determine the sizes of the listener thread. + The values of these variables will persist accross SAVE-APPLICATION; + these values have no effect on the sizes of stacks in threads created + under explicit user control. + +- New functions: + + (CCL:GC-VERBOSE on-full-gc &optional (on-egc on-full-gc)) + + Causes the GC to print (or stop printing ...) informational messages + on entry and exit. The ON-FULL-GC argument controls whether or + not these messages are printed on ... a full GC, and the ON-EGC + argument (which defaults to the value of the ON-FULL-GC argument) + controls whether messages are printed on ephemeral GCs. + + (CCL:GC-VERBOSE-P) + + Returns two values (corresponding to the arguments of the last call + to CCL:GC-VERBOSE.) + + (CCL:REBUILD-CCL &key :FULL :CLEAN :KERNEL :FORCE :RELOAD :EXIT + :RELOAD-ARGUMENTS) + + Depending on the values of its arguments, recompiles lisp and/or + kernel sources and optionallly re-generates ("reloads") a heap + image. + + Arguments: + + clean deletes FASL and .o files before performing other steps + kernel rebuilds the lisp kernel + force forces recompilation, even if binary is newer than source + reload tries to rebuild a full heap image after other build steps + exit quits after all other steps + full equivalent to :CLEAN T :KERNEL T :RELOAD T + reload-arguments a list of strings, passed as additional arguments + to the reload step. E.g. '("--thread-stack-size" "128M"). + + Output from the :KERNEL and :RELOAD steps is ordinarily only displayed + if an error occurs. + + +- Changes + + TRACE now prints an integer (corresponding to the level of indentation) + on each line of output. + + Tracing callbacks is currently broken (it may be reimplemented; if so, + it'd be implemented somewhat differently ...) + +- Bugs + + Several bugs involving interactions between the GC and (many) active + threads have been fixed; at least one such bug remains (the symptom + involves a recently allocated array somehow getting trashed or GCed + incorrectly; the cause has been under investigation for weeks but is + still not known.) + +OpenMCL 1.1-pre-060125 + +- FASL version changed; delete old FASL (.dfsl, .pfsl, .dfsl64, .pfsl64) files + +- "kernel ABI version" changed; build a new lisp kernel before trying to load/use + 060125 images. + +- Changes: (see also ChangeLog) + + New variable: + + CCL:*HOST-PAGE-SIZE* + + Initialized on application startup to contain the MMU/OS page size in bytes. + This is 4K on PPC platforms (and likely on most? all? x86 platforms). + + New functions: + + CCL:DEFAULT-ALLOCATION-QUANTUM + + Returns an integer, the value of which is used by the lisp kernel when + mapping heap memory from the OS. Mapping requests are usually made in + multiples of this value. + + This value is read-only; currently, it's 64KB on 32-bit platforms and + 128KB on 64-bit platforms. + + + CCL:PROCESS-ALLOCATION-QUANTUM p + + Returns the (per-thread) allocation quantum of the process P. By default, + this is the same value as that returned by CCL:DEFAULT-ALLOCATION-QUANTUM, + but lower values can be specified on a per-process basis (see below.) + + This value is read-only. + + CCL:CURRENT-PROCESS-ALLOCATION-QUANTUM + + Equivalent to (CCL:PROCESS-ALLOCATION-QUANTUM *CURRENT-PROCESS*), + but can be used with SETF to change the current processes's + allocation quantum to a value which is between *HOST-PAGE-SIZE* and + (DEFAULT-ALLOCATION-QUANTUM), inclusive, and which is a power of 2. + + + Changes to existing functions: + + Both PROCESS-RUN-FUNCTION and MAKE-PROCESS accept an :ALLOCATION-QUANTUM + &key argument, which defaults to the value returned by (DEFAULT-ALLOCATION-QUANTUM). + If provided, the value of the argument should should satisfy the same + constraints that (SETF (CURRENT-PROCESS-ALLOCATION-QUANTUM) is subject to. + +Discussion + +In general, larger per-thread allocation quanta are appropriate for programs +where a relatively small number of threads need to allocate memory frequently +and small per-thread quanta are appropriate for larger numbers of threads +that are expected to do small, infrequent memory allocations. + +The worst-case scenarios would involve a large number of threads doing +incidental memory allocation with large quanta (that wastes memory and may +trigger the GC too frequently) or a small number of threads doing frequent +memory allocation with small quanta (since such threads could be expected +to fill up their small per-thread memory allocations quickly and frequently +and would waste time frequently allocating more small chunks.) + +All of these values interact with the GC and EGC thresholds; the ability +to exercise some control over how much per-threads memory is allocated +at a time can help to ensure that those interactions are appropriate. +When these mechanisms are insufficient, applications should consider the +use of available mechanisms for adjusting GC and EGC thresholds. + + + + +OpenMCL 1.1-pre-051027 + +- A lot of internal changes in the way that special bindings, UNWIND-PROTECT, + and WITHOUT-INTERRUPTS are implemented (and in how they interact with + each other. + + One user-visible aspect of this is that UNWIND-PROTECT cleanup forms + are run with interrupts disabled (the protected form is run with + interrupts enabled if they were enabled on entry to the UNWIND-PROTECT.) + This means that something like: + + (unwind-protect + nil + (loop)) + + will loop uninterruptibly. + +- CCL:WITH-INTERRUPTS-ENABLED &body body executes the body with interrupts + enabled. The example above could be rewritten as: + + (unwind-protect + nil + (with-interrupts-enabled (loop))) + + and the loop would be interruptible. + + These changes introduce binary incompatibility (the FASL version changed, + as did an internal version number that tries to keep the kernel and + heap image in synch.) + + Things basically work, but there may be lingering bugs (e.g., as of + a little while ago, QUIT didn't work because the initial process + was running with interrupts disabled.) + +- PROCESS-TERMINATION-SEMAPHORE + MAKE-PROCESS and PROCESS-RUN-FUNCTION accept a :TERMINATION-SEMAPHORE + argument; processes have a PROCESS-TERMINATION-SEMAPHORE accessor + method. If the argument is specified and non-null, its value should + of type SEMAPHORE. + + If a process dies by any means after it's been successfully enabled + and it has a non-null termination semaphore "at the time of its death", + that semaphore will be signaled just before the underlying OS thread + is destroyed. + + SETF can be used with PROCESS-TERMINATION-SEMAPHORE to change or + clear a the termination semaphore of a process. If the target + process is not the current process when this happens, it's possible + that the process could die before the SETF takes effect; this + possibility must be addressed at the application level (i.e., the + implementation doesn't try to synchronize the calling thread and + the target in any way. + + A simple example: + + (let* ((s (make-semaphore))) + (process-run-function `(:name "sleepy" :termination-semaphore ,s) + #'(lambda () (sleep 10))) + (wait-on-semaphore s)) + + The calling thread will wait for (roughly) 10 seconds (until the + "sleepy" thread has had its nap and signals its termination semaphore.) + +- A change that was introduced prior to 0.14.3 led to strange, usually + fatal crashes (usually an unhandled bus error, occasionally a cryptic + "can't find active area" message and a trip to the kernel debugger) + under Darwin. This was caused by an attempt to use certain Mach + primitives to suspend and resume threads (the way that those + primitives were used, Mach exception messages were sometimes sent + twice if the first send was interrupted, and the second send occurred + after the exception had already been handled (because the first send + was recieved but not replied to ...) + + 1.0 backed out of this change, and used signal handling primitives + (instead of Mach primitives) to suspend and resume threads. I -think- + that I understand the issue with the Mach primitives + (#_thread_abort_safely isn't necessary and caused the duplicate + exception messages to be sent) and have tried to revert to using + the Mach thread suspension mechanisms. (If unhandled bus errors - + that exit to the shell - or cryptic "can't find active area" messages + reappear, this experiment will be shown to be a failure.) + + There are some obscure but good reasons for favoring the Mach + primiitves, so it'd be good to know if the problem with using them + has indeed been identified. + + (The test case involves bad luck and bad timing: two or more + threads having pending exceptions at the same time and the thread + whose exception is handled first tries to suspend the others, typically + on behalf of the GC. It was possible to run stress tests for many + hours in 0.14.3 without encountering the bug, and possible to + encounter it under seemingly light loads.) + +- INCF and DECF argument order and fixnum arithmetic. + + Bryan fixed some ANSI test failures related to the order in which INCF + and DECF evaluate their args. (One example is: + + (let* ((x 3)) + (incf x (setq x 5))) + + where the correct answer is 10, not 8.) We both found that fixing + some cases involving INCF caused some OpenMCL code to compile + incorrectly and were nervous about introducing these changes fairly + late in the development cycle, so we backed out of them prior to + the 1.0 code freeze. + + The reasons for the miscompiled code have to do with how the + compiler interprets fixnum declarations under typical optimization + settings. If A and B are both declared to be FIXNUMS, then + the expression + + (setq a (+ a b)) + + will usually compile to a simple ADD instruction (with no overflow + checking); if A and B are fixnums, the result will be a fixnum, + though if an undetected overflow occurred in the addition, the + result might be missing a significant bit. + + There was code in OpenMCL that assumed that + + (incf a b) + + was exactly the same as + + (setq a (+ a b)) + + and in fact that was true under the old (incorrect) definition of + INCF. The new definition introduced some temporary bindings: + + (let* ((...) + (#:temp (+ a b)) + (...)) + (setq a #:temp)) + + In this case, the addition was allowed to generate an overflow + (no type declaration on #:temp), and the SETQ quietly violated + a type declaration (assigning a non-FIXNUM value to A), leading + to further problems. + + So far, I found a couple of cases of this in the OpenMCL sources. + (FWIW, both functions were originally transliterated from C code + and were trying to mimic C's silent overflow behavior.) + + Moral: if you have code that assumes that INCF or DECF expand + into simple assignments and are trying to exploit the ways that + those assignments interact with type declarations, you may + want to review those assumptions. If you write code that has + side effects in the DELTA arguments of INCF or DECF rorms, + you'll (hopefully) be pleased to see that Bryan's changes + allow these side-effects to be handled correctly (at the + right time.) If you don't fall into either of these categories, + you probably won't notice any difference ... + +- 64-bit Linux support + + There's a 64-bit LinuxPPC heap image and some rudimentary (libc-only) + 64-bit Linux interfaces in the testing directory. + + (Unlike 64-bit Darwin, 64-bit Linux distributions typically provide + 64-bit versions of "all" standard libraries; I haven't gotten around + to building 64-bit gnome/gtk/X11/... interfaces yet, but wouldn't + expect there to be a problem.) + + The 64-bit Linux OpenMCL seems to basically work, but ... OpenMCL + likes to map its kernel into low addresses (around #x5000); this + allows compiled lisp code to use conditional branches to "short" + (16-bit) absolute addresses. Newer Linux kernels provide a + "vdso" shared library that's intended to simply communication + between the OS kernel and userspace libraries and programs; when + a program is mapped at "non-standard" addresses, the vdso gets + mapped at address 0. + + I don't fully understand the imlications of this (beyond the fact that + indirecting through a NULL pointer will access bits and pieces + of the vdso instead of segfaulting.) As far as I know, this is + seen as a minor bug in the Linux kernel, and I -think- that I've + seen kernel ChangeLog entries that indicate that the problem's been + fixed in the relatively recent past (and will likely start to + make it into Linux distributions in the near future.) + + That said - and seeing a library at address 0 certainly makes me a + little nervous - the LinuxPPC64 port seems to work at least as + well as the DarwinPPC64 port does (i.e., there may be word-size + or other bugs lurking around or hiding in plain sight, but it's + not usually easy to encounter them.) + +- As documented (and as hasn't been true in a long time), EOF + from *STANDARD-INPUT* terminates the REPL when the --batch argument + is in effect (even if *STANDARD-INPUT* is a tty.) + +- QUIT does a FRESH-LINE on and FORCE-OUTPUT to the standard output + stream (people had reported that output wasn't always flushed + when --batch or --eval was used; 1.0 was better about this than + previous versions were, but it still wasn't reliable.) + +OpenMCL 1.1-pre-051028 +I had been doing development on G5s, and hadn't noticed that the +32-bit lisp had been using a 64-bit instruction. (I'm a little +confused about how that could have worked; perhaps the 64-bit +instruction gets emulated by the OS, or perhaps my model of +whether 64-bit instructions can be executed in 32-bit mode +is simply incorrect.) + +In any case, the 32-bit images produced yesterday don't run on +G4s (or presumably G3s or older systems.) Ooops. New images. + +OpenMCL 1.1-pre-051029 + A function used by both SET-USER-ENVIRONMENT +and SET-DEVELOPMENT-ENVIRONMENT wasn't properly changing saved bindings +of *PACKAGE*; the last few 1.1-pre releases have come up in the CCL +package, as a result. Ooops again; new images, again. + + +OpenMCL 1.1-pre-051204 +Not a lot of user-visible changes, but the changes that're there +are a little hard to bootstrap. +Note that new kernel build directories (darwinppc, darwinppc64, +linuxppc, linuxppc64, ...) repace the old versions that don't +have "ppc" in their names. CVS may not prune the old directories, +especially if they contain files (.o, random junk). Index: /branches/experimentation/later/source/scripts/.cvsignore =================================================================== --- /branches/experimentation/later/source/scripts/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/scripts/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/scripts/ccl =================================================================== --- /branches/experimentation/later/source/scripts/ccl (revision 8058) +++ /branches/experimentation/later/source/scripts/ccl (revision 8058) @@ -0,0 +1,42 @@ +#!/bin/sh +# +# Change the definition of CCL_DEFAULT_DIRECTORY below to refer to +# your OpenMCL installation directory. +# Any definition of CCL_DEFAULT_DIRECTORY already present in the environment +# takes precedence over definitions made below. + +if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then + CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl +fi + +# This is shorter (& easier to type), making the invocation below +# a little easier to read. + +DD=${CCL_DEFAULT_DIRECTORY} + +# If you don't want to guess the name of the OpenMCL kernel on +# every invocation (or if you want to use a kernel with a +# non-default name), you might want to uncomment and change +# the following line: +#OPENMCL_KERNEL=some_name + +# Set the CCL_DEFAULT_DIRECTORY environment variable; +# the lisp will use this to setup translations for the CCL: logical host. + +if [ -z "$OPENMCL_KERNEL" ]; then + case `uname -s` in + Darwin) + OPENMCL_KERNEL=dppccl + ;; + Linux) + OPENMCL_KERNEL=ppccl + ;; + *) + echo "Can't determine host OS. Fix this." + exit 1 + ;; + esac +fi + +CCL_DEFAULT_DIRECTORY=${DD} exec ${DD}/${OPENMCL_KERNEL} "$@" + Index: /branches/experimentation/later/source/scripts/ccl64 =================================================================== --- /branches/experimentation/later/source/scripts/ccl64 (revision 8058) +++ /branches/experimentation/later/source/scripts/ccl64 (revision 8058) @@ -0,0 +1,71 @@ +#!/bin/sh +# +# Change the definition of CCL_DEFAULT_DIRECTORY below to refer to +# your OpenMCL installation directory. +# Any definition of CCL_DEFAULT_DIRECTORY already present in the environment +# takes precedence over definitions made below. + +if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then + CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl +fi + +# This is shorter (& easier to type), making the invocation below +# a little easier to read. + +DD=${CCL_DEFAULT_DIRECTORY} + +# If you don't want to guess the name of the OpenMCL kernel on +# every invocation (or if you want to use a kernel with a +# non-default name), you might want to uncomment and change +# the following line: +#OPENMCL_KERNEL=some_name + +# Set the CCL_DEFAULT_DIRECTORY environment variable; +# the lisp will use this to setup translations for the CCL: logical host. + +if [ -z "$OPENMCL_KERNEL" ]; then + case `uname -s` in + Darwin) + case `arch` in + ppc*) + OPENMCL_KERNEL=dppccl64 + ;; + i386|x86_64) + OPENMCL_KERNEL=dx86cl64 + ;; + esac + ;; + Linux) + case `uname -m` in + ppc64) + OPENMCL_KERNEL=ppccl64 + ;; + x86_64) + OPENMCL_KERNEL=lx86cl64 + ;; + *) + echo "Can't determine machine architecture. Fix this." + exit 1 + ;; + esac + ;; + FreeBSD) + case `uname -m` in + amd64) + OPENMCL_KERNEL=fx86cl64 + ;; + *) + echo "unsupported architecture" + exit 1 + ;; + esac + ;; + *) + echo "Can't determine host OS. Fix this." + exit 1 + ;; + esac +fi + +CCL_DEFAULT_DIRECTORY=${DD} exec ${DD}/${OPENMCL_KERNEL} "$@" + Index: /branches/experimentation/later/source/scripts/http-to-ssh =================================================================== --- /branches/experimentation/later/source/scripts/http-to-ssh (revision 8058) +++ /branches/experimentation/later/source/scripts/http-to-ssh (revision 8058) @@ -0,0 +1,23 @@ +#!/bin/sh + +# This script can be used to rewrite the schema in svn working copy URLs, +# changing URLs that use 'http' as an access method to use 'svn+ssh' instead. +# (The http: access method allows read-only access; 'svn+ssh' allows people +# with appropriate permission to commit changes to the repository.) + +HTTP_URL=http://svn.clozure.com +SSH_URL=svn+ssh://svn.clozure.com/usr/local +CCLDIR=`dirname $0`/.. + +# This assumes that all directories under CCL are under svn control +# That's a reasonable assumption after a fresh checkout; if it's +# violated, svn will warn and we'll move on. + +for d in `ls $CCLDIR` +do + if [ -d $CCLDIR/$d ]; then + (cd $CCLDIR/$d ; + echo Relocating `pwd` ; + svn switch --relocate $HTTP_URL $SSH_URL) + fi +done Index: /branches/experimentation/later/source/scripts/openmcl =================================================================== --- /branches/experimentation/later/source/scripts/openmcl (revision 8058) +++ /branches/experimentation/later/source/scripts/openmcl (revision 8058) @@ -0,0 +1,42 @@ +#!/bin/sh +# +# Change the definition of CCL_DEFAULT_DIRECTORY below to refer to +# your OpenMCL installation directory. +# Any definition of CCL_DEFAULT_DIRECTORY already present in the environment +# takes precedence over definitions made below. + +if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then + CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl +fi + +# This is shorter (& easier to type), making the invocation below +# a little easier to read. + +DD=${CCL_DEFAULT_DIRECTORY} + +# If you don't want to guess the name of the OpenMCL kernel on +# every invocation (or if you want to use a kernel with a +# non-default name), you might want to uncomment and change +# the following line: +#OPENMCL_KERNEL=some_name + +# Set the CCL_DEFAULT_DIRECTORY environment variable; +# the lisp will use this to setup translations for the CCL: logical host. + +if [ -z "$OPENMCL_KERNEL" ]; then + case `uname -s` in + Darwin) + OPENMCL_KERNEL=dppccl + ;; + Linux) + OPENMCL_KERNEL=ppccl + ;; + *) + echo "Can't determine host OS. Fix this." + exit 1 + ;; + esac +fi + +CCL_DEFAULT_DIRECTORY=${DD} exec ${DD}/${OPENMCL_KERNEL} "$@" + Index: /branches/experimentation/later/source/scripts/openmcl64 =================================================================== --- /branches/experimentation/later/source/scripts/openmcl64 (revision 8058) +++ /branches/experimentation/later/source/scripts/openmcl64 (revision 8058) @@ -0,0 +1,71 @@ +#!/bin/sh +# +# Change the definition of CCL_DEFAULT_DIRECTORY below to refer to +# your OpenMCL installation directory. +# Any definition of CCL_DEFAULT_DIRECTORY already present in the environment +# takes precedence over definitions made below. + +if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then + CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl +fi + +# This is shorter (& easier to type), making the invocation below +# a little easier to read. + +DD=${CCL_DEFAULT_DIRECTORY} + +# If you don't want to guess the name of the OpenMCL kernel on +# every invocation (or if you want to use a kernel with a +# non-default name), you might want to uncomment and change +# the following line: +#OPENMCL_KERNEL=some_name + +# Set the CCL_DEFAULT_DIRECTORY environment variable; +# the lisp will use this to setup translations for the CCL: logical host. + +if [ -z "$OPENMCL_KERNEL" ]; then + case `uname -s` in + Darwin) + case `arch` in + ppc*) + OPENMCL_KERNEL=dppccl64 + ;; + i386|x86_64) + OPENMCL_KERNEL=dx86cl64 + ;; + esac + ;; + Linux) + case `uname -m` in + ppc64) + OPENMCL_KERNEL=ppccl64 + ;; + x86_64) + OPENMCL_KERNEL=lx86cl64 + ;; + *) + echo "Can't determine machine architecture. Fix this." + exit 1 + ;; + esac + ;; + FreeBSD) + case `uname -m` in + amd64) + OPENMCL_KERNEL=fx86cl64 + ;; + *) + echo "unsupported architecture" + exit 1 + ;; + esac + ;; + *) + echo "Can't determine host OS. Fix this." + exit 1 + ;; + esac +fi + +CCL_DEFAULT_DIRECTORY=${DD} exec ${DD}/${OPENMCL_KERNEL} "$@" + Index: /branches/experimentation/later/source/tools/.cvsignore =================================================================== --- /branches/experimentation/later/source/tools/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/tools/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/experimentation/later/source/tools/README-OpenMCL.txt =================================================================== --- /branches/experimentation/later/source/tools/README-OpenMCL.txt (revision 8058) +++ /branches/experimentation/later/source/tools/README-OpenMCL.txt (revision 8058) @@ -0,0 +1,46 @@ +This directory contains various third-party opensourced +system-building tools. + +The code here is current as of February 1, 2005; you may want +to check the originating project's homepages to see if more recent +versions are available. + +"defsystem.lisp" is part of the clocc project on SourcForge: +. It's a "system definition +facility" which provides functionality similar to that offered by +the Unix "make" program. It was originally written by Mark Kantrowitz +and has been maintained and enhanced by many people; I believe that +Marco Antoniotti is currently the principal developer. This is +version 3.4i of DEFSYSTEM (which is often called "MK-DEFSYSTEM"). +Note that, for historical reasons, DEFSYSTEM will try to redefine +the CL:REQUIRE function. + +"asdf.lisp" is Another System Definition Facility and is available as +part of the cclan project on SourceForge: +. It was written by and +is maintained by Daniel Barlow. + +"asdf-install" is a library which can be used to download CL packages +from the Internet and which uses ASDF to build and install them. It's +also part of the cclan project and was originally written (for SBCL) +by Dan Barlow. It's since been ported to several other CL +implementations; Marco Baringer did the OpenMCL port. + +There's excellent documentation on asdf-install in the asdf-install/doc +directory. As that document mentions, asdf-install is designed to use +the GnuPG package to validate cryptographic signatures associated with +asdf-install-able packages, though it can apparently be configured to +work in an environment in which GnuPG is not available. + +Downloading code from publicly-writable Internet sites - without the +ability to verify that that code's really what it claims to be and +from the author who claims to have provided it - is obviously a +dangerous and unwise thing to do. It's strongly recommended that +people ensure that GnuPG is installed (and ensure that asdf-install is +configured to use it) before using asdf-install to download packages. + +(GnuPG packages for OSX are available from . +Most Linux distributions offer GnuPG through their packaging system; +further information on GnuPG is available at . + + Index: /branches/experimentation/later/source/tools/asdf-install/.cvsignore =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +asdf-install +test-passed +*~.* Index: /branches/experimentation/later/source/tools/asdf-install/COPYRIGHT =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/COPYRIGHT (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/COPYRIGHT (revision 8058) @@ -0,0 +1,46 @@ +The original ASDF-INSTALL code (the files Makefile, README, +asdf-install.asd, defpackage.lisp, and installer.lisp) was written by +Daniel Barlow and is distributed with SBCL and +therefore in the public domain. The SBCL Common Lisp implementation +can be obtained from Sourceforge: . + +The initial port of ASDF-INSTALL to other Lisps was done by Dr. Edmund +Weitz and included the file port.lisp and some +changes to the files mentioned above. More code was provided by Marco +Baringer (OpenMCL port), James Anderson + (MCL port, including the file digitool.lisp), +Kiyoshi Mizumaru , Robert P. Goldman +, and Raymond Toy +(bugfixes). Marco Antoniotti added support for +MK:DEFSYSTEM which includes the files load-asdf-install.lisp, +loader.lisp, and finally split-sequence.lisp which has its own +copyright notice. + +The complete code distributed with this archive (asdf-install.tar.gz) +is copyrighted by the above-mentioned authors and governed by the +following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + Index: /branches/experimentation/later/source/tools/asdf-install/Makefile =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/Makefile (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/Makefile (revision 8058) @@ -0,0 +1,13 @@ +SYSTEM=asdf-install +EXTRA_INSTALL_TARGETS=asdf-install-install + +include ../asdf-module.mk + +asdf-install-install: asdf-install + if test -f $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install ; then \ + mv $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install.old ; \ + fi +# KLUDGE: mv rather than cp because keeping asdf-install in that +# directory interferes with REQUIRE, and this is done before the tar +# in ../asdf-module.mk. Better solutions welcome. + mv asdf-install $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install Index: /branches/experimentation/later/source/tools/asdf-install/README =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/README (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/README (revision 8058) @@ -0,0 +1,121 @@ +Downloads and installs an ASDF or a MK:DEFSYSTEM system or anything +else that looks convincingly like one. It updates the +ASDF:*CENTRAL-REGISTRY* symlinks for all the toplevel .asd files it +contains, and it also MK:ADD-REGISTRY-LOCATION for the appropriate +directories for MK:DEFSYSTEM. + +Please read this file before use: in particular: this is an automatic +tool that downloads and compiles stuff it finds on the 'net. Please +look at the SECURITY section and be sure you understand the +implications + + += USAGE + +This can be used either from within a CL implementation: + +cl-prompt> (load "/path/to/load-asdf-install.lisp") +cl-prompt> (asdf-install:install 'xlunit) ; for example + +With SBCL you can also use the standalone command `sbcl-asdf-install' +from the shell: + +$ sbcl-asdf-install xlunit + + +Each argument may be - + + - The name of a cliki page. asdf-install visits that page and finds + the download location from the `:(package)' tag - usually rendered + as "Download ASDF package from ..." + + - A URL, which is downloaded directly + + - A local tar.gz file, which is installed + + += SECURITY CONCERNS: READ THIS CAREFULLY + +When you invoke asdf-install, you are asking your CL implementation to +download, compile, and install software from some random site on the +web. Given that it's indirected through a page on CLiki, any +malicious third party doesn't even need to hack the distribution +server to replace the package with something else: he can just edit +the link. + +For this reason, we encourage package providers to crypto-sign their +packages (see details at the URL in the PACKAGE CREATION section) and +users to check the signatures. asdf-install has three levels of +automatic signature checking: "on", "off" and "unknown sites", which +can be set using the configuration variables described in +CUSTOMIZATION below. The default is "unknown sites", which will +expect a GPG signature on all downloads except those from +presumed-good sites. The current default presumed-good sites are +CCLAN nodes, and two web sites run by SBCL maintainers: again, see +below for customization details + + += CUSTOMIZATION + +If the file $HOME/.asdf-install exists, it is loaded. This can be +used to override the default values of exported special variables. +Presently these are + +*PROXY* + defaults to $http_proxy environment variable +*CCLAN-MIRROR* + preferred/nearest CCLAN node. See the list at + http://ww.telent.net/cclan-choose-mirror +*ASDF-INSTALL-DIRS* + Set from ASDF_INSTALL_DIR environment variable. If you are running + SBCL, then *ASDF-INSTALL-DIRS* may be set form the environment variable + SBCL_HOME, which should already be correct for whatever SBCL is + running, if it's been installed correctly. This is done for + backward compatibility with SBCL installations. +*SBCL-HOME* + This is actually a symbol macro for *ASDF-INSTALL-DIRS* +*VERIFY-GPG-SIGNATURES* + Verify GPG signatures for the downloaded packages? + NIL - no, T - yes, :UNKNOWN-LOCATIONS - only for URLs which aren't in CCLAN + and don't begin with one of the prefixes in *SAFE-URL-PREFIXES* +*LOCATIONS* + Possible places in the filesystem to install packages into. See default + value for format +*SAFE-URL-PREFIXES* + List of locations for which GPG signature checking /won't/ be done when + *verify-gpg-signatures* is :unknown-locations + + += PACKAGE CREATION + +If you want to create your own packages that can be installed using this +loader, see the "Making your package downloadable..." section at + + + += HACKERS NOTE + +Listen very carefully: I will say this only as often as it appears to +be necessary to say it. asdf-install is not a good example of how to +write a URL parser, HTTP client, or anything else, really. +Well-written extensible and robust URL parsers, HTTP clients, FTP +clients, etc would definitely be nice things to have, but it would be +nicer to have them in CCLAN where anyone can use them - after having +downloaded them with asdf-install - than in SBCL contrib where they're +restricted to SBCL users and can only be updated once a month via SBCL +developers. This is a bootstrap tool, and as such, will tend to +resist changes that make it longer or dependent on more other +packages, unless they also add to its usefulness for bootstrapping. + + += TODO + +a) gpg signature checking would be better if it actually checked against +a list of "trusted to write Lisp" keys, instead of just "trusted to be +who they say they are" + +e) nice to have: resume half-done downloads instead of starting from scratch +every time. but right now we're dealing in fairly small packages, this is not +an immediate concern + + Index: /branches/experimentation/later/source/tools/asdf-install/asdf-install.asd =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/asdf-install.asd (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/asdf-install.asd (revision 8058) @@ -0,0 +1,44 @@ +;;; -*- Lisp -*- + +(defpackage #:asdf-install-system + (:use #:cl #:asdf)) + +(in-package #:asdf-install-system) +#+:sbcl +(require 'sb-executable) + +;;; this is appalling misuse of asdf. please don't treat it as any +;;; kind of example. this shouldn't be a compile-op, or if it is, should +;;; define output-files properly instead of leaving it be the fasl +#+:sbcl +(defclass exe-file (cl-source-file) ()) +#+:sbcl +(defmethod perform :after ((o compile-op) (c exe-file)) + (sb-executable:make-executable + (make-pathname :name "asdf-install" + :type nil + :defaults (component-pathname c)) + (output-files o c) + :initial-function "RUN")) + +#+:sbcl +(defmethod perform ((o load-op) (c exe-file)) nil) + +(defsystem asdf-install + #+:sbcl :depends-on + #+:sbcl (sb-posix sb-bsd-sockets) + :version "0.3" + :components ((:file "defpackage") + #+:sbcl + (:exe-file "loader" :depends-on ("installer")) + (:file "split-sequence") + (:file "port" :depends-on ("defpackage")) + #+:digitool + (:file "digitool" :depends-on ("port")) + (:file "installer" :depends-on ("port" "split-sequence" #+:digitool "digitool")))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :asdf-install)))) + (provide 'asdf-install)) + +(defmethod perform ((o test-op) (c (eql (find-system :asdf-install)))) + t) Index: /branches/experimentation/later/source/tools/asdf-install/defpackage.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/defpackage.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/defpackage.lisp (revision 8058) @@ -0,0 +1,36 @@ +(cl:in-package :cl-user) + +(defpackage :asdf-install + (:use "CL") + (:export + + ;; Customizable variables. + #:*proxy* + #:*cclan-mirror* + #:*sbcl-home* ; Deprecated. + #:asdf-install-dirs + #:private-asdf-install-dirs + + #:*verify-gpg-signatures* + #:*locations* + #:*safe-url-prefixes* + #:*preferred-location* + + #+(or :win32 :mswindows) + #:*cygwin-bin-directory* + + #+(or :win32 :mswindows) + #:*cygwin-bash-command* + + ;; External entry points. + #:add-locations + #+(and asdf (or :win32 :mswindows)) + #:sysdef-source-dir-search + #:uninstall + #:install + ;; proxy authentication + #:*proxy-user* + #:*proxy-passwd*)) + +(defpackage :asdf-install-customize + (:use "CL" "ASDF-INSTALL")) Index: /branches/experimentation/later/source/tools/asdf-install/digitool.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/digitool.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/digitool.lisp (revision 8058) @@ -0,0 +1,230 @@ +;;; -*- package: asdf-install; -*- +;;; +;;; Digitool-specific bootstrapping +;;; +;;; 2004-01-18 james.anderson@setf.de additions for MCL +;;; 2008-01-22 added exit-code checks to call-system + +(in-package :asdf-install) + +#+:digitool +(let ((getenv-fn 0) + (setenv-fn 0) + (unsetenv-fn 0) + (popen-fn 0) + (pclose-fn 0) + (fread-fn 0) + (feof-fn 0)) + (ccl::with-cfstrs ((framework "System.framework")) + (let ((err 0) + (baseURL nil) + (bundleURL nil) + (bundle nil)) + (ccl::rlet ((folder :fsref)) + ;; Find the folder holding the bundle + (setf err (ccl::require-trap traps::_FSFindFolder + (ccl::require-trap-constant traps::$kOnAppropriateDisk) + (ccl::require-trap-constant traps::$kFrameworksFolderType) + t folder)) + ;; if everything's cool, make a URL for it + (when (zerop err) + (setf baseURL (ccl::require-trap traps::_CFURLCreateFromFSRef (ccl::%null-ptr) folder))) + (if (ccl::%null-ptr-p baseURL) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if everything's cool, make a URL for the bundle + (when (zerop err) + (setf bundleURL (ccl::require-trap traps::_CFURLCreateCopyAppendingPathComponent (ccl::%null-ptr) baseURL framework nil)) + (if (ccl::%null-ptr-p bundleURL) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if everything's cool, create it + (when (zerop err) + (setf bundle (ccl::require-trap traps::_CFBundleCreate (ccl::%null-ptr) bundleURL)) + (if (ccl::%null-ptr-p bundle) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if everything's cool, load it + (when (zerop err) + (if (not (ccl::require-trap traps::_CFBundleLoadExecutable bundle)) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if there's an error, but we've got a pointer, free it and clear result + (when (and (not (zerop err)) (not (ccl::%null-ptr-p bundle))) + (ccl::require-trap traps::_CFRelease bundle) + (setf bundle nil)) + ;; free the URLs if here non-null + (when (not (ccl::%null-ptr-p bundleURL)) + (ccl::require-trap traps::_CFRelease bundleURL)) + (when (not (ccl::%null-ptr-p baseURL)) + (ccl::require-trap traps::_CFRelease baseURL)) + (cond (bundle + ;; extract the necessary function id's + (flet ((get-addr (name) + (ccl::with-cfstrs ((c-name name)) + (let* ((addr (ccl::require-trap traps::_CFBundleGetFunctionPointerForName bundle c-name))) + (when (ccl::%null-ptr-p addr) + (error "Couldn't resolve address of foreign function ~s" name)) + (ccl::rlet ((buf :long)) + (setf (ccl::%get-ptr buf) addr) + (ash (ccl::%get-signed-long buf) -2)))))) + (setf getenv-fn (get-addr "getenv")) + (setf setenv-fn (get-addr "setenv")) + (setf unsetenv-fn (get-addr "unsetenv")) + (setf popen-fn (get-addr "popen")) + (setf pclose-fn (get-addr "pclose")) + (setf fread-fn (get-addr "fread")) + (setf feof-fn (get-addr "feof"))) + (ccl::require-trap traps::_CFRelease bundle) + (setf bundle nil)) + (t + (error "can't resolve core framework entry points."))))) + + (defun ccl::getenv (variable-name) + (ccl::with-cstrs ((c-variable-name variable-name)) + (let* ((env-ptr (ccl::%null-ptr))) + (declare (dynamic-extent env-ptr)) + (ccl::%setf-macptr env-ptr (ccl::ppc-ff-call getenv-fn + :address c-variable-name + :address)) + (unless (ccl::%null-ptr-p env-ptr) + (ccl::%get-cstring env-ptr))))) + + (defun ccl::setenv (variable-name variable-value) + (ccl::with-cstrs ((c-variable-name variable-name) + (c-variable-value variable-value)) + (ccl::ppc-ff-call setenv-fn + :address c-variable-name + :address c-variable-value + :signed-fullword 1 + :signed-fullword))) + + (defun ccl::unsetenv (variable-name) + (ccl::with-cstrs ((c-variable-name variable-name)) + (ccl::ppc-ff-call unsetenv-fn + :address c-variable-name + :void))) + + (labels ((fread (fp buffer length) + (ccl::ppc-ff-call fread-fn + :address buffer + :unsigned-fullword 1 + :unsigned-fullword length + :address fp + :signed-fullword)) + (feof-p (fp) + (not (zerop (ccl::ppc-ff-call feof-fn + :address fp + :signed-fullword)))) + (popen (command) + (ccl::with-cstrs ((read "r") + (cmd command)) + (ccl::ppc-ff-call popen-fn + :address cmd + :address read + :address))) + (pclose (fp) + (ccl::ppc-ff-call pclose-fn + :address fp + :signed-fullword)) + + (fread-decoded (fp io-buffer io-buffer-length string-buffer script) + (cond ((feof-p fp) + (values nil string-buffer)) + (t + (let ((io-count (fread fp io-buffer io-buffer-length))) + (cond ((and io-count (plusp io-count)) + (if script + (multiple-value-bind (chars fatp) (ccl::pointer-char-length io-buffer io-count script) + (cond ((not fatp) + (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count)) + (t + (unless (>= (length string-buffer) chars) + (setf string-buffer (make-string chars :element-type 'base-character))) + (ccl::pointer-to-string-in-script io-buffer string-buffer io-count script) + (setf io-count chars)))) + (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count)) + (values io-count string-buffer)) + (t + (values 0 string-buffer)))))))) + + (defun ccl::call-system (command) + (let* ((script (ccl::default-script nil)) + (table (ccl::get-char-byte-table script)) + (result (make-array 128 :element-type 'character :adjustable t :fill-pointer 0)) + (string-buffer (unless table (make-string 512 :element-type 'base-character))) + (io-count 0) + (fp (popen command)) + (exit-code 0)) + (unless (ccl::%null-ptr-p fp) + (unwind-protect + (ccl::%stack-block ((io-buffer 512)) + (loop (multiple-value-setq (io-count string-buffer) + (fread-decoded fp io-buffer 512 string-buffer (when table script))) + (unless io-count (return)) + (let ((char #\null)) + (dotimes (i io-count) + (case (setf char (schar string-buffer i)) + ((#\return #\linefeed) (setf char #\newline))) + (vector-push-extend char result))))) + (setf exit-code (pclose fp)) + (setf fp nil)) + (if (zerop exit-code) + (values result 0) + (values nil exit-code result))))) + + ;; need a function to avoid both the reader macro and the compiler + (setf (symbol-function '%new-ptr) #'ccl::%new-ptr) + + (defclass popen-input-stream (ccl::input-stream) + ((io-buffer :initform nil) + (fp :initform nil ) + (string-buffer :initform nil) + (length :initform 0) + (index :initform 0) + (script :initarg :script :initform (ccl::default-script nil))) + (:default-initargs :direction :input)) + + (defmethod initialize-instance :after ((instance popen-input-stream) &key command) + (with-slots (io-buffer string-buffer fp script) instance + (setf fp (popen command) + io-buffer (%new-ptr 512 nil) + string-buffer (make-string 512 :element-type 'base-character)) + (when script (unless (ccl::get-char-byte-table script) (setf script nil))))) + + (defmethod ccl::stream-close ((stream popen-input-stream)) + (declare (ignore abort)) + (with-slots (io-buffer string-buffer fp ccl::direction) stream + (when (and fp (not (ccl::%null-ptr-p fp))) + (pclose fp) + (setf fp nil) + (setf ccl::direction :closed) + (ccl::disposeptr io-buffer) + (setf io-buffer nil)))) + + (defmethod stream-element-type ((stream popen-input-stream)) + 'character) + + (defmethod ccl::stream-tyi ((stream popen-input-stream)) + ;; despite the decoding provisions, unix input comes with linefeeds + ;; and i don't know what decoding one would need. + (with-slots (io-buffer fp string-buffer length index script) stream + (when fp + (when (>= index length) + (multiple-value-setq (length string-buffer) + (fread-decoded fp io-buffer 512 string-buffer script)) + (unless (and length (plusp length)) + (setf length -1) + (return-from ccl::stream-tyi nil)) + (setf index 0)) + (let ((char (schar string-buffer index))) + (incf index) + (case char + ((#\return #\linefeed) #\newline) + (t char)))))) + + (defmethod ccl::stream-untyi ((stream popen-input-stream) char) + (with-slots (string-buffer length index) stream + (unless (and (plusp index) (eql char (schar (decf index) string-buffer))) + (error "invalid tyi character: ~s." char)) + char)) + + (defmethod ccl::stream-eofp ((stream popen-input-stream)) + (with-slots (length) stream + (minusp length))))) Index: /branches/experimentation/later/source/tools/asdf-install/doc/.cvsignore =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/doc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/doc/.cvsignore (revision 8058) @@ -0,0 +1,1 @@ +*~.* Index: /branches/experimentation/later/source/tools/asdf-install/doc/index.html =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/doc/index.html (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/doc/index.html (revision 8058) @@ -0,0 +1,1059 @@ + + + + + + A tutorial for ASDF-INSTALL + + + + + +

A tutorial for ASDF-INSTALL

+ +
+
 

Abstract

+ +This tutorial is intended for people who are relatively new to Common +Lisp. It describes an easy way to install third-party libraries into a +Lisp implementation. + +
+ +
 

Contents

+
    +
  1. Introduction +
  2. What is ASDF? +
  3. What is ASDF-INSTALL? +
  4. Prerequisites +
      +
    1. Installing ASDF +
    2. Loading ASDF automatically +
    3. Installing ASDF-INSTALL +
    4. Loading ASDF-INSTALL automatically +
    +
  5. Optional: Using MK:DEFSYSTEM instead of (or in addition to) ASDF +
  6. How to install a library +
      +
    1. Installing a library by name +
    2. Installing a library by URL +
    3. Installing from a local file +
    4. Where to store the library +
    5. The security check +
    +
  7. How to use an installed library +
  8. How ASDF-INSTALL resolves dependencies +
  9. Customizing ASDF-INSTALL +
      +
    1. Special variable *GNU-TAR-PROGRAM* +
    2. Special variable *PROXY* +
    3. Special variable *PROXY-USER* +
    4. Special variable *PROXY-PASSWD* +
    5. Special variable *CCLAN-MIRROR* +
    6. Special variable *VERIFY-GPG-SIGNATURES* +
    7. Special variable *SAFE-URL-PREFIXES* +
    8. Special variable *LOCATIONS* +
    9. Special variable *PREFERRED-LOCATION* +
    10. Environment variable ASDF_INSTALL_DIR +
    11. Environment variable PRIVATE_ASDF_INSTALL_DIR +
    +
  10. The list of trusted code suppliers +
  11. How to uninstall a library +
  12. Changelog +
  13. Copyright +
  14. License +
+ +
 

Introduction

+ +If you're reading this you're probably already convinced that Common +Lisp is a very fine programming language. However, while the ANSI standard +is huge and provides tons of functionality there are a couple of +things (like, say, XML parsers, web servers, GUIs, regular +expressions) that aren't included and must either be provided by your +particular implementation or otherwise by a third-party library. +

+Hitherto these libraries had to be installed manually, an often +complex process. However, many library authors are now packaging their +systems using the new ASDF-INSTALL standard, allowing for automatic +installation on any Lisp system that supports it. + +
 

What is ASDF?

+ +In order to understand what ASDF-INSTALL does we first have to +understand what ASDF is and why we need it. ASDF ("Another System +Definition Facility"), written by Daniel Barlow, is a library to +automate the compilation and loading of "systems", i.e. Lisp +programs which are usually composed of a couple of files which have to +be compiled and loaded in a certain order. This is similar to the Unix +make program. ASDF works with the majority of CL +implementations in use today. +

+A similar system which precedes ASDF is MK:DEFSYSTEM. You don't +need it for ASDF-INSTALL but it won't hurt to have it available for +libraries which aren't aware of ASDF. However, this document makes no +effort to explain how MK:DEFSYSTEM is used. See Henrik Motakef's +article "Fight The System." +

+Update: Marco Antoniotti has patched +ASDF-INSTALL to make it work with MK:DEFSYSTEM as well. See the section about MK:DEFSYSTEM below. + +
 

What is ASDF-INSTALL?

+ +ASDF-INSTALL, also +written by Dan Barlow, is layered atop ASDF and can automatically +download Lisp libraries from the Internet and install them for you. It +is also able to detect and resolve dependencies on other +libraries. (These libraries have to be prepared for ASDF-INSTALL by +their author. See more below.) +

+ASDF-INSTALL was originally written for the SBCL Common Lisp implementation. It has +been recently ported to CMUCL, Allegro Common +Lisp, Xanalys LispWorks, +and CLISP by Edi Weitz. Marco Baringer added +support for OpenMCL, James Anderson added support for Macintosh Common Lisp (MCL). +

+It'd be nice if users of other Lisps (like Corman Lisp, ECL, or Scieneer Common Lisp) could provide patches to make ASDF-INSTALL +available on more platforms. +

+The original ASDF-INSTALL is distributed with SBCL. The +"portable" version is +available from http://weitz.de/files/asdf-install.tar.gz and also +from CCLAN. + +
 

Prerequisites

+ +This tutorial is aimed at Unix-like systems which should include Linux and Mac OS X. +If you're on MS Windows make sure to read the Windows notes at the end of each section. +

+Apart from one of the supported Lisps you +will need GnuPG (which is probably pre-installed on +most Linux distributions). Install it first if you don't have it already. You may also need to install the GNU version of tar if you're not on Linux. +

+(GnuPG is not strictly necessary - see below - but it is recommended if +you want to be reasonable sure that you're not installing arbitrary +malicious code.) + +

Update: Beginning with version 0.14.1 +ASDF-INSTALL is already included with the OpenMCL distribution. Also, +AllegroCL 7.0 and higher include ASDF (but not ASDF-INSTALL.) See +below for details. + +

+Note: For MCL you must start +your Lisp from a terminal. + +

+Windows note: If you want to use +ASDF-INSTALL on Windows you must install Cygwin first. You can also install +GnuPG from the Cygwin setup program. If you want to use CLISP you +currently have to +use the Cygwin version (which can also be installed from the setup +application). The good news is that if you use Cygwin you can pretty +much pretend you're on Unix and skip all the Windows notes below. +

(Update: Alex Mizrahi posted some notes about using the native Win32 version of CLISP to comp.lang.lisp. I asked him to send patches but he hasn't sent them yet.) + +

+Whenever I use ~/ (the Unix shell notation for the user's +home directory) in the following text what is actually meant is the +value of (USER-HOMEDIR-PATHNAME). While +on Unix/Linux all implementations seem to agree what this value should +be, on Windows this is not the case. Read the docs of your Lisp. + +

Installing ASDF

+ +(Skip this section if you use SBCL or OpenMCL or AllegroCL 7.0 or higher.) Download ASDF and put the +file asdf.lisp in a place where you want it to +stay. Change into this directory and, from your Lisp, issue the +command + +
+(load (compile-file "asdf.lisp"))
+
+ +You should now have a new file the name of which depends on your +implementation - probably something like asdf.fasl, +asdf.fas, asdf.fsl, asdf.ufsl, +asdf.x86f, or asdf.so. + +

+Note: The download link above is provided for your +convenience. The real home of ASDF can be found via http://www.cliki.net/asdf. I +cannot guarantee that the version available from my server will always +be in sync with bleeding-edge ASDF but the program seems to be mature +enough to warrant the usage of a version that may be slightly out-dated. + +

+Note: LispWorks 4.2 (and probably earlier versions) has a bug +that prevents it from loading the compiled ASDF correctly. It is +recommended that you upgrade to 4.3 but if for some +reason you must use an older version you can skip the compilation step +above and later just load the .lisp file instead in which +case you'll use interpreted code. + +

+Note: CLISP 2.32 cannot compile ASDF due to being not +fully ANSI-compliant. You can download a compiled version (which +should work with all operating systems supported by CLISP) from http://weitz.de/files/asdf.fas. +Newer versions (like 2.33.2) can compile ASDF, though. + +

Loading ASDF automatically

+ +We want to make sure that ASDF is loaded whenever we start our +Lisp. For this we'll use an initialization file. Most +Lisps will read and execute the contents of a certain file on +startup. This file is usually located in your home directory and might +be called .clinit.cl (for Allegro Common Lisp), +.cmucl-init (for CMUCL), .lispworks (for +Xanalys LispWorks), .clisprc (for CLISP), or +openmcl-init.lisp (for OpenMCL). Consult your Lisp's +documentation for details. +

+Open this file (create it if it doesn't exist) and add this line + +

+#-:asdf (load "/path/where/asdf/is/located/asdf")
+
+ +where of course you have replaced +/path/where/asdf/is/located/ with the correct path to +ASDF - see last section. We wrote +(load ".../asdf") and not, say, +(load ".../asdf.x86f") because this way +your Lisp will load the compiled file if it is available and otherwise +asdf.lisp if for some reason you didn't compile the code. +

+Why the #-:asdf? After ASDF has been loaded it adds the +symbol :ASDF to the features +list. Our use of the read-time conditional Sharpsign +Minus thus makes sure that ASDF isn't loaded a second time if it's +already there. (So you can safely save and use an image with ASDF +pre-loaded without changing your init file.) +

+If you're using SBCL or OpenMCL or AllegroCL 7.0 or higher don't add the line from above but use + +

+(require :asdf)
+
+ +instead. + +

+ASDF maintains a list of places where it will look for system +definitions when it is asked to load or compile a system. (System +definitions are the files ending with .asd.) This list is +stored in the special +variable ASDF:*CENTRAL-REGISTRY* and you can add new +directories to it. Open your initialization file once again and add +the following line after the line which loads ASDF: + +

+(pushnew "/path/to/your/registry/" asdf:*central-registry* :test #'equal)
+
+ +You can use a directory of your choice but you should make sure it +exists. You can also add several of these lines with different +directories so ASDF will look into each directory in turn until it has +found a system definition. Use the directory +~/.asdf-install-dir/systems/ if you can't make a decision +and make sure to create it. (Replace ~/ with an absolute +path to your home directory because not all Lisps support the tilde +notation.) We will call the directory you've chosen your registry from now on. + + +

+ +Note: It is important that you add a directory here, +not a file, so make sure the namestring +ends with a slash! + +

+ +Note: If you use ASDF alone the preferred way to deal with +system definitions is to create symbolic links from the +.asd files to your registry. However, you don't have to +deal with this as ASDF-INSTALL will do that for you. + +

+ +Note: The free "Personal Edition" of LispWorks doesn't read +~/.lispworks on startup. You can circumvent this by +putting something like + +

+alias lispworks="/usr/local/lib/LispWorksPersonal/lispworks-personal-4300 -init ~/.lispworks"
+
+ +into your ~/.bashrc file. + +

+Windows +note: On Windows we can't +use a central registry because Windows doesn't have symbolic links. We +will use another mechanism (see below) to find system definitions, so +you don't have to put the PUSHNEW line into your +initialization file. + +

Installing ASDF-INSTALL

+ +(Skip this section if you use SBCL.) +Download +ASDF-INSTALL and unpack the gzipped tar archive into a directory of +your choice. Now create a symlink from the .asd file to your registry: + +
+cd /path/to/your/registry/
+ln -s /path/where/you/unpacked/asdf-install/asdf-install.asd .
+
+ +

For OpenMCL you don't have to download ASDF-INSTALL because it's +already there - it's in /path/to/ccl/tools/asdf-install/ +where /path/to/ccl/ is the directory where you installed +OpenMCL. You have to provide the symlink, though. + +

+Now start your Lisp and issue the following command: + +

+(asdf:operate 'asdf:compile-op :asdf-install)
+(asdf:operate 'asdf:load-op :asdf-install)
+
+ +This will ask ASDF to locate the ASDF-INSTALL library, compile it, and finally load it. + +

+Windows note: You can +leave out the ln command. Now, before you +compile and load ASDF-INSTALL you have to put this line into your +initialization file: + +

+(pushnew "/path/where/you/unpacked/asdf-install/" asdf:*central-registry* :test #'equal)
+
+ +and then either restart your Lisp or evaluate this expression in your +current session. Afterwards, proceed with the two +ASDF:OPERATE forms. + +

Loading ASDF-INSTALL automatically

+ +Open your initilization file again and add this line at the end: + +
+#-:asdf-install (asdf:operate 'asdf:load-op :asdf-install)
+
+ +This will instruct ASDF to load the (compiled) ASDF-INSTALL library +whenever your Lisp starts up (unless ASDF-INSTALL is already available +in your image). + +

+If you're using SBCL don't add the line from above but use + +

+(require :asdf-install)
+
+ +instead. + +

+You're now ready to use ASDF-INSTALL. + +

+Windows note: For Windows add the +following line to end of the initialization file: + +

+(pushnew 'asdf-install:sysdef-source-dir-search
+         asdf:*system-definition-search-functions*)
+
+ +As we can't use the central registry, we're using a +customized search function instead. It'll scan all directories below +each of the entries in *LOCATIONS* until it finds a +suitable system definition. Note that this is a sub-optimal solution +because this will not necessarily find the newest one if you've +installed several versions of the same library. Make sure to uninstall older versions. + +
 

Optional: Using MK:DEFSYSTEM instead of (or in addition to) ASDF

+ +MK:DEFSYSTEM was +written by Mark Kantrovitz in the early days of Common Lisp. It +precedes ASDF and also works with almost all CL implementations you'll +come across. Thanks to the efforts of Marco Antoniotti, ASDF-INSTALL +can now also be used with MK:DEFSYSTEM which means that even if the +library you want to use doesn't have an ASDF system definition you +might be able to install it via ASDF-INSTALL. +

+The recommended setup is to use both ASDF and +MK:DEFSYSTEM because this will significantly increase the number of +libraries you can install with ASDF-INSTALL. +

+To set up your Lisp environment for this you have to do the following (after reading the sections above): +

    +
  • Get MK:DEFSYSTEM (version 3.4i or higher) from CLOCC. (You can grab a nightly snapshot or browse the CVS. You only need the file defsystem.lisp from within the src/defsystem-3.x directory.) +
  • To install MK:DEFSYSTEM evaluate the form +
    +(load (compile-file "/path/to/defsystem.lisp"))
+
    +
  • To load MK:DEFSYSTEM automatically each time you start your Lisp put the forms +
    +#-:mk-defsystem (load "/path/to/defsystem")
+(mk:add-registry-location "/path/to/your/registry/")
+
    + into your initialization file. +
  • Finally, replace the line +
    +#-:asdf-install (asdf:operate 'asdf:load-op :asdf-install)
+
    +from above with the line +
    +#-:asdf-install (load "/path/to/asdf-install/load-asdf-install")
+
    +This last step will ensure that ASDF-INSTALL will always be loaded on startup even if you only use MK:DEFSYSTEM and don't have ASDF available. +
+The following sections should work for you no matter whether you use ASDF, MK:DEFSYSTEM, or both. + +
 

How to install a library

+ +Here and in the following sections we assume that you have set up your +environment as described in Prerequisites. + +

+Note: Of course, the fact that a library can be installed with +ASDF-INSTALL and that ASDF-INSTALL was ported to your Lisp +implementation doesn't necessary mean that the library itself +will work with your Lisp! Check the library's docs before you try to +install it. + +

Installing a library by name

+ +The webpage http://www.cliki.net/asdf-install +contains a list of libraries which can automatically be downloaded and +installed via ASDF-INSTALL. Listed here are libraries which are +explicitely prepared to work with ASDF-INSTALL and where the author +decided to announce this via CLiki. This is the preferred way to +install a library via ASDF-INSTALL. +

+You can click on the name of each library +to get a description. Use the library's name from the list to install +it. If, say, you want to install CL-PPCRE make sure you're +connected to the Internet and use this command: + +

+(asdf-install:install :cl-ppcre)
+
+ +Then proceed with Where to store the library below. +

+ +Note: If you install a library by name, ASDF-INSTALL will +connect to the CLiki website and from there it'll be redirected to the +actual download location provided by the library's author. + +

+Note: The argument to the ASDF-INSTALL:INSTALL +function is a string +designator, i.e. instead of :CL-PPCRE you can also +use "cl-ppcre". CLiki is case-insensitive and +therefore case doesn't matter if you install a library by name. + +

Installing a library by URL

+ +The list mentioned above is not necessary +complete, i.e. there might as well exist libraries which aren't listed +there but which can be installed via ASDF-INSTALL. + +

+In order to be ASDF-installable a library has to contain a system definition for ASDF. It also has to be +packaged in a certain way: It is assumed to come as a gzipped tar +archive (usually ending in .tar.gz or .tgz) +which unpacks into one directory possibly containing +sub-directories. The system definition has to have a name +corresponding to the name of the library (so if your library is called +"foobar" the system definition is supposed to be +foobar.asd) and has to reside in the top-level +directory. +

+If this is the case you can download and install the library directly by +providing the download URL of the package like so: + +

+(asdf-install:install "http://weitz.de/files/cl-ppcre.tar.gz")
+
+ +Now proceed with Where to store the library below. + +

+Note: Currently, ASDF-INSTALL only understands http. Other +protocols like ftp or https aren't supported. + +

+Note: It's obviously rather easy to make an existing library +ASDF-installable if it isn't already. If you come across a library +which you'd like to use but which isn't listed on http://www.cliki.net/asdf-install, +it might be worthwhile to kindly ask the library's author to change +this. + +

Installing from a local file

+ +The third way to install a library via ASDF-INSTALL is to use a local +tar archive (in the format described in the last +section). In this case you use the file's namestring + +
+(asdf-install:install "/path/to/library/library.tar.gz")
+
+ +and afterwards carry on with the next section. + +

+Note: For obvious reasons this namestring must not start with +"http://" although your operating system might +otherwise allow this. + +

Where to store the library

+ +ASDF-INSTALL will now ask you where the library should be stored. (This can be customized.) In +the default configuration this'll look more or less like so: + +
+Install where?
+1) System-wide install:
+   System in /usr/local/asdf-install/site-systems/
+   Files in /usr/local/asdf-install/site/
+2) Personal installation:
+   System in /home/edi/.asdf-install-dir/systems/
+   Files in /home/edi/.asdf-install-dir/site/
+ -->
+
+ +Choose one of these options and enter the corresponding number, then +press the Return key. (Note that on Unix-like systems you +usually don't have write access in /usr/local/ unless +you're root.) + +

The security check

+ +If you don't install from a local file, ASDF-INSTALL will now check the +validity of the library. (This behaviour can be customized.) Library authors are +supposed to crypto-sign their libraries and provide a file with the +(PGP) signature in the same place where the library can be downloaded, +i.e. if the library is at +http://www.example.com/frob.tar.gz then ASDF-INSTALL will +try to download the signature from +http://www.example.com/frob.tar.gz.asc. + +

+ASDF-INSTALL will check +

    +
  • if the signature exists, +
  • if there is a GPG trust relationship between the package signer + and you (i.e. that the package comes from someone whose + key you've signed, or someone else you have GPG trust with has signed), and +
  • if the signer is listed in + your personal list of valid suppliers of Lisp code. +
+ +If all these tests succeed, ASDF-INSTALL will compile and install the +library and you can now use it. (This will also happen instantly if +you have installed from a local file.) + +

+If one of the checks fails, you'll most likely be confronted with one +of these situations: + +

+Downloading 157777 bytes from http://weitz.de/files//cl-ppcre.tgz ...
+Error: Server responded 404 for GET http://weitz.de/files//cl-ppcre.tgz.asc
+  [condition type: DOWNLOAD-ERROR]
+
+Restart actions (select using :continue):
+ 0: Don't ckeck GPG signature for this package
+ 1: Return to Top Level (an "abort" restart).
+ 2: Abort entirely from this process.
+
+ +There was no signature corresponding to this package. + +
+Downloading 6365 bytes from http://files.b9.com//cl-base64-latest.tar.gz ...gpg: WARNING: using insecure memory!
+gpg: please see http://www.gnupg.org/faq.html for more information
+gpg: Signature made Thu 12 Jun 2003 04:06:04 PM CEST using DSA key ID C4A3823E
+gpg: Can't check signature: public key not found
+
+Error: No key found for key id 0x112ECDF2C4A3823E.  Try some command like
+  gpg  --recv-keys 0x112ECDF2C4A3823E
+  [condition type: KEY-NOT-FOUND]
+
+Restart actions (select using :continue):
+ 0: Don't ckeck GPG signature for this package
+ 1: Return to Top Level (an "abort" restart).
+ 2: Abort entirely from this process.
+
+ +The library was signed but the signer's public key wasn't found in +your public keyring. + +
+Downloading 6365 bytes from http://files.b9.com//cl-base64-latest.tar.gz ...gpg: WARNING: using insecure memory!
+gpg: please see http://www.gnupg.org/faq.html for more information
+gpg: Signature made Thu 12 Jun 2003 04:06:04 PM CEST using DSA key ID C4A3823E
+gpg: Good signature from "Kevin M. Rosenberg <kmr@debian.org>"
+gpg:                 aka "Kevin Rosenberg <kevin@rosenberg.net>"
+gpg:                 aka "Kevin M. Rosenberg <kevin@b9.com>"
+gpg:                 aka "Kevin Marcus Rosenberg, M.D. <kevin@b9.com>"
+gpg: WARNING: This key is not certified with a trusted signature!
+gpg:          There is no indication that the signature belongs to the owner.
+Primary key fingerprint: D7A0 55B6 4768 3582 B10D  3F0C 112E CDF2 C4A3 823E
+
+Error: GPG warns that the key id 0x112ECDF2C4A3823E (Kevin M. Rosenberg <kmr@debian.org>) is not fully trusted
+  [condition type: KEY-NOT-TRUSTED]
+
+Restart actions (select using :continue):
+ 0: Don't ckeck GPG signature for this package
+ 1: Return to Top Level (an "abort" restart).
+ 2: Abort entirely from this process.
+
+ +The signer's key is in your public keyring but you have no GPG trust +relationship with him. + +
+Downloading 157777 bytes from http://weitz.de/files//cl-ppcre.tgz ...gpg: WARNING: using insecure memory!
+gpg: please see http://www.gnupg.org/faq.html for more information
+gpg: Signature made Fri 24 Oct 2003 11:22:11 AM CEST using DSA key ID 057958C6
+gpg: Good signature from "Dr. Edmund Weitz <edi@weitz.de>"
+
+Error: Dr. Edmund Weitz <edi@weitz.de> (key id 595FF045057958C6) is not on your package supplier list
+  [condition type: AUTHOR-NOT-TRUSTED]
+
+Restart actions (select using :continue):
+ 0: Add to package supplier list
+ 1: Don't ckeck GPG signature for this package
+ 2: Return to Top Level (an "abort" restart).
+ 3: Abort entirely from this process.
+
+ +The signer's key is in your public keyring, you have a GPG trust +relationship with him but the signer wasn't found in your list of valid suppliers of Lisp code. +

+As you'll have noticed, in all these cases ASDF-INSTALL offers the restart +not to check the GPG signature in this particular case. How you can +select this restart depends on your Lisp implementation but if you +select it ASDF-INSTALL will proceed compiling and installing the +package without further checks for this library. +

+In the last case (condition type AUTHOR-NOT-TRUSTED) you +are also offered another restart. If you select this one the signer of +the library will be added to your package +supplier list and you won't be asked again if you install another +library signed by the same person. + +

+Note: You might be asking yourself if all this security stuff +is really necessary. Well, CLiki, +the website where ASDF-INSTALL looks for the package URL if you +install by name, can be edited by anyone so it would be +fairly easy for a malicious hacker to redirect you to a library which +once it's installed insults your boss by email or withdraws +US$ 100,000 from your bank account. You better make sure this +doesn't happen... See the section about +customization on how to (partly) disable security checks. + +

+Note: If you're unsure about notions like public +keyring or GPG trust relationship, please read +the GnuPG documentation. It is beyond the scope of this text to +explain these terms. + +
 

How to use an installed library

+ +After you've successfully executed ASDF-INSTALL:INSTALL +you can immediately use the library you've just installed while you're +still in the same Lisp session. If you quit your Lisp image and start +it anew you have to reload the library. (Of course you don't +have to install it again!) This is done like so: + +
+(asdf:operate 'asdf:load-op :library-name)
+
+ +Here :LIBRARY-NAME is either the name you've used if you +installed by name or it is the name of the main +.asd file if you've installed by URL +or from a local file. If you're not sure about +the name you have to use, you can list the contents of your registry for all libraries which are available to +you. So, if your registry looks like this + +
+edi@bird:~ > ls ~/.asdf-install-dir/systems/
+cl-ppcre.asd  cl-ppcre-test.asd  cl-who.asd  html-template.asd
+
+ +you can substitute :LIBRARY-NAME with one of +:CL-PPCRE, :CL-PPCRE-TEST, +:CL-WHO, or :HTML-TEMPLATE. (CL-PPCRE-TEST +was most likely automatically installed when you installed CL-PPCRE.) + +

+If you use SBCL you can, instead of calling ASDF:OPERATE, +simply REQUIRE +the library: + +

+(require :library-name)
+
+ +
 

How ASDF-INSTALL resolves dependencies

+ +Sometimes a library depends on one or more other libraries. This can +be expressed within an ASDF system +definition. If there's a dependency and the necessary libraries +aren't already installed then ASDF-INSTALL will try to download the +missing libraries by name and install them before +it proceeds to install the main library. This of course requires that +the missing libraries are also listed on CLiki. +

+You can for example from CMUCL issue the command + +

+(asdf-install:install :osicat)
+
+ +and watch how ASDF-INSTALL not only downloads and installs Osicat but also UFFI. + +
 

Customizing ASDF-INSTALL

+ +When ASDF-INSTALL is loaded it LOADs +the file ~/.asdf-install if it's there. This file (which +is obviously supposed to contain Lisp code) can be used to change the +values of some special +variables which control ASDF-INSTALL's behaviour. Their names are +exported +from the ASDF-INSTALL package. + +

Special variable *GNU-TAR-PROGRAM*

+ +The path to the GNU tar program as a string - the default is "tar". Changing this variable has no effect if Cygwin is used. + +

Special variable *PROXY*

+ +This variable is NIL by default but will be set to the +value of the environment variable $http_proxy (if it's +set) prior to loading ~/.asdf-install. Set this to a +non-NIL value if you need to go through an http proxy. + +

Special variable *PROXY-USER*

+

Special variable *PROXY-PASSWD*

+ +Use these variables if your proxy requires authentication. + +

Special variable *CCLAN-MIRROR*

+ +This variable is set to +"http://ftp.linux.org.uk/pub/lisp/cclan/" +before ~/.asdf-install is loaded. A couple of +ASDF-installable libraries are available via CCLAN and with the help of this +variable you can choose another CCLAN mirror from the list at http://ww.telent.net/cclan-choose-mirror. + +

Special variable *VERIFY-GPG-SIGNATURES*

+ +This variable is set to T initially which means that +there'll be a security check for each library +which is not installed from a local file. You can set it to +NIL which means no checks at all or to +:UNKNOWN-LOCATIONS which means that only URLs which are +not in *SAFE-URL-PREFIXES* are +checked. Every other value behaves like T. + +

+Note: This customization option is currently not supported in +the SBCL version of ASDF-INSTALL. + +

Special variable *SAFE-URL-PREFIXES*

+ +The value of this variable is NIL initially. It is +supposed to be a list of strings which are "safe" URL +prefixes, i.e. if a download URL begins with one of these strings +there's no security check. The value of +*SAFE-URL-PREFIXES* only matters if *VERIFY-GPG-SIGNATURES* +is set to :UNKNOWN-LOCATIONS. + +

+Note: This customization option is currently not supported in +the SBCL version of ASDF-INSTALL. + +

Special variable *LOCATIONS*

+ +The initial value of this variable (prior to loading +~/.asdf-install) is + +
+((#p"/usr/local/asdf-install/site/"
+  #p"/usr/local/asdf-install/site-systems/"
+  "System-wide install")
+ (#p"/home/edi/.asdf-install-dir/site/"
+  #p"/home/edi/.asdf-install-dir/systems/"
+  "Personal installation"))
+
+ +where /home/edi/ will obviously be replaced with your +home directory. You'll notice that this corresponds to the little menu you see when ASDF-INSTALL starts to +install a package. You can add elements to this list or replace it +completely to get another menu. Each element is a list with three +elements - a pathname +denoting the directory where the (unpacked) libraries will be stored, +a pathname denoting a directory where system +definition symlinks will be placed, and a string describing this +particular choice. +

+If you make changes to this value it is important that you also update +ASDF:*CENTRAL-REGISTRY* +accordingly in your initialization +file or ASDF-INSTALL won't find your system definitions (unless +you are on Windows). See the example below. + +

+Note: On SBCL the initial value of this variable is different +- try it out yourself. + +

Special variable *PREFERRED-LOCATION*

+ +This variable is initially NIL. If it is not +NIL it should be a positive integer not greater than the +length of *LOCATIONS*. By +setting this value you circumvent the question +about where to install a library and ASDF-INSTALL will unconditionally +use the corresponding entry from *LOCATIONS*. Note that +1 (not 0) means the first entry. + +

+Note: This customization option is currently not supported in +the SBCL version of ASDF-INSTALL. + +

Environment variable ASDF_INSTALL_DIR

+ +The value of this environment variable determines the first element of the initial value of +*LOCATIONS*, i.e. if it, say, +contains the value /usr/local/foo/, then the first +element of *LOCATIONS* is + +
+(#p"/usr/local/foo/site/"
+ #p"/usr/local/foo/site-systems/"
+ "System-wide install")
+
+ +If this variable is not set, the directory +/usr/local/asdf-install/ is used. Note that this variable affects ASDF-INSTALL's behaviour before ~/.asdf-install is loaded. + +

+Note: On SBCL the value of SBCL_HOME is used +instead. + +

Environment variable PRIVATE_ASDF_INSTALL_DIR

+ +The value of this environment variable determines the second element of the initial value of +*LOCATIONS*, i.e. if it, say, +contains the value frob/ and your username is johndoe, then the second +element of *LOCATIONS* is + +
+(#p"/home/johndoe/frob/site/"
+ #p"/home/johndoe/frob/systems/"
+ "Personal installation")
+
+ +If this variable is not set, the value +.asdf-install-dir (note the dot) is used. Note that this variable affects ASDF-INSTALL's behaviour before ~/.asdf-install is loaded. + +

+Note: On SBCL the value .sbcl is used +instead. + +

An example .asdf-install file

+ +Here's a documented example for how the file +~/.asdf-install could look like: + +
+;; use a http proxy
+(setq asdf-install:*proxy* "http://proxy.foo.com/")
+
+;; use a CCLAN mirror in France
+(setq asdf-install:*cclan-mirror* "http://thingamy.com/cclan/")
+
+;; only partial security checks
+(setq asdf-install:*verify-gpg-signatures* :unknown-locations)
+
+;; downloads from Kevin Rosenberg and from my own server don't have to be checked
+(setq asdf-install:*safe-url-prefixes*
+        '("http://files.b9.com/" "http://weitz.de/files/"))
+
+;; add a repository for unstable libraries
+(pushnew '(#p"/usr/local/lisp/unstable/site/"
+           #p"/usr/local/lisp/unstable/systems/"
+           "Install as unstable")
+         asdf-install:*locations*
+         :test #'equal)
+
+;; make sure this is also known by ASDF
+(pushnew "/usr/local/lisp/unstable/systems/"
+         asdf:*central-registry*
+         :test #'equal)
+
+ +
 

The list of trusted code suppliers

+ +ASDF-INSTALL maintains a list of library authors you trust. This list +is stored in a file trusted-uids.lisp and usually resides in the directory ~/.asdf-install-dir/ but this can be customized by changing the environment variable PRIVATE_ASDF_INSTALL_DIR. You are not supposed to edit this file manually - new entries are added automatically whenever you choose the corresponding restart during the security check. + +
 

How to uninstall a library

+ +This is easy: + +
+(asdf-install:uninstall :library-name)
+
+ +ASDF-INSTALL will ask you to confirm this and then it'll remove the +library's source directory as well as the symbolic link to the system definition (if it exists). + +

+Windows note: Due to the way systems are found on Windows +ASDF-INSTALL will propose to delete an arbitrary version of your +library if you've installed several of them. Make sure to read +what it is about to remove before you confirm. + +
 

Changelog

+ + + + + + + + + + + + + + + + + + + + + +
2005-09-27Small change for compatibility with future OpenMCL versions (thanks to Bryan O'Connor)
2005-07-14Updated note about CLISP (thanks to Henri Lenzi)
2005-06-01Added proxy authentication code (thanks to Sean Ross)
2005-02-16More OpenMCL details (thanks to Jim Thompson)
2004-12-29Added COPYRIGHT file to distribution
2004-09-13Added information about AllegroCL 7.0 and OpenMCL 0.14.1
2004-09-08Fixed typo in GET-ENV-VAR and added special variable *GNU-TAR-PROGRAM* (both thanks to Raymond Toy)
2004-05-20Changed hyphens to underlines in names of environment variables (thanks to Robert P. Goldman)
2004-05-19Mentioned Alex Mizrahi's notes, added version number for MK:DEFSYSTEM in docs and SPLIT-SEQUENCE dependency in ASDF system definition (thanks to Robert P. Goldman and Robert Lehr)
2004-04-28Fixed asdf-install.asd so that it still works and you're not forced to use load-asdf-install.lisp
2004-04-25MK:DEFSYSTEM clarification
2004-04-24Patches by Marco Antoniotti for MK:DEFSYSTEM compatibility
2004-03-27Bugfixes by Kiyoshi Mizumaru
2004-01-28Improved MCL support (James Anderson)
2004-01-21Support for MCL by James Anderson
2004-01-16Minor edits, Cygwin CLISP support, download location for asdf.fas
2004-01-15Preliminary Windows support, described how to uninstall a library, added *PREFERRED-LOCATION*, removed ln bug in CLISP code
2004-01-13 Mentioned OpenMCL support (Marco Baringer), added some SBCL exceptions, added clarification about Windows, minor edits, changes by Dan Barlow
2004-01-12Initial version
+ +
 

Copyright

+ +Copyright (c) 2004-2005 Dr. Edmund Weitz. All rights reserved. + +
 

License

+ +Redistribution and use of this tutorial in its orginal form (HTML) or +in 'derived' forms (PDF, Postscript, RTF and so forth) with or without +modification, are permitted provided that the following condition is +met: + +
    +
  • Redistributions must reproduce the above copyright notice, this + condition and the following disclaimer in the document itself + and/or other materials provided with the distribution. +
+ +IMPORTANT: This document is provided by the author "as is" and any +expressed or implied warranties, including, but not limited to, the +implied warranties of merchantability and fitness for a particular +purpose are disclaimed. In no event shall the author be liable for any +direct, indirect, incidental, special, exemplary, or consequential +damages (including, but not limited to, procurement of substitute +goods or services; loss of use, data, or profits; or business +interruption) however caused and on any theory of liability, whether +in contract, strict liability, or tort (including negligence or +otherwise) arising in any way out of the use of this documentation, +even if advised of the possibility of such damage. + +

+$Header$ +

BACK TO MY HOMEPAGE + + + Index: /branches/experimentation/later/source/tools/asdf-install/installer.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/installer.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/installer.lisp (revision 8058) @@ -0,0 +1,816 @@ +(in-package :asdf-install) + +(pushnew :asdf-install *features*) + +(defun installer-msg (stream format-control &rest format-arguments) + (apply #'format stream ";;; ASDF-INSTALL: ~@?~%" format-control format-arguments)) + + +#+:digitool +(defparameter *home-volume-name* + (second (pathname-directory (truename (user-homedir-pathname)))) + "Digitool MCL retains the OS 9 convention that ALL volumes have a +name which includes the startup volume. OS X doesn't know about this. +This figures in the home path and in the normalization for system +namestrings.") + +(defvar *proxy* (get-env-var "http_proxy")) + +(defvar *cclan-mirror* + (or (get-env-var "CCLAN_MIRROR") + "http://ftp.linux.org.uk/pub/lisp/cclan/")) + +#+(or :win32 :mswindows) +(defvar *cygwin-bin-directory* + (pathname "C:\\PROGRA~1\\Cygwin\\bin\\")) + +#+(or :win32 :mswindows) +(defvar *cygwin-bash-program* + "C:\\PROGRA~1\\Cygwin\\bin\\bash.exe") + +(defvar *gnu-tar-program* + "tar" + "Path to the GNU tar program") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *supported-defsystems* + (list :mk-defsystem + :asdf + + ;; Add others. + ;; #+lispworks :common-defsystem + )) + + + (unless (some (lambda (defsys-tag) + (member defsys-tag *features*)) + *features*) + (error "ASDF-INSTALL requires one of the following \"defsystem\" utilities to work." + *supported-defsystems*))) + + + +(defun directorify (name) + ;; input name may or may not have a trailing #\/, but we know we + ;; want a directory + (let ((path (pathname name))) + (if (pathname-name path) + (merge-pathnames + (make-pathname :directory `(:relative ,(pathname-name path)) + :name "") + path) + path))) + +(defvar *asdf-install-dirs* + (directorify (or #+sbcl (get-env-var "SBCL_HOME") + (get-env-var "ASDF_INSTALL_DIR") + (make-pathname :directory + `(:absolute + #+digitool ,*home-volume-name* + "usr" "local" "asdf-install"))))) + +#+sbcl ; Deprecated. +(define-symbol-macro *sbcl-home* *asdf-install-dirs*) + + +(defvar *private-asdf-install-dirs* + #+:sbcl + (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) + (truename (user-homedir-pathname))) + #-:sbcl + (cond ((get-env-var "PRIVATE_ASDF_INSTALL_DIR") + (directorify (get-env-var "PRIVATE_ASDF_INSTALL_DIR"))) + (t + (merge-pathnames (make-pathname :directory '(:relative ".asdf-install-dir")) + (truename (user-homedir-pathname)))))) + +#+sbcl ; Deprecated. +(define-symbol-macro *dot-sbcl* *private-asdf-install-dirs*) + + +(defvar *trusted-uids* nil) + +(defvar *verify-gpg-signatures* t) + +(defvar *safe-url-prefixes* nil) + +(defvar *preferred-location* nil) + +(defun verify-gpg-signatures-p (url) + (labels ((prefixp (prefix string) + (let ((m (mismatch prefix string))) + (or (not m) (>= m (length prefix)))))) + (case *verify-gpg-signatures* + ((nil) nil) + ((:unknown-locations) + (notany + (lambda (x) (prefixp x url)) + *safe-url-prefixes*)) + (t t)))) + +(defparameter *locations* + `((,(merge-pathnames (make-pathname :directory '(:relative "site")) + *asdf-install-dirs*) + ,(merge-pathnames (make-pathname :directory '(:relative "site-systems")) + *asdf-install-dirs*) + "System-wide install") + (,(merge-pathnames (make-pathname :directory '(:relative "site")) + *private-asdf-install-dirs*) + ,(merge-pathnames (make-pathname :directory '(:relative "systems")) + *private-asdf-install-dirs*) + "Personal installation"))) + + +#+(and (not :sbcl) :asdf) +(pushnew `(merge-pathnames ,(make-pathname :directory '(:relative "site-systems")) + ,*asdf-install-dirs*) + asdf:*central-registry* + :test #'equal) + +#+(and (not :sbcl) :asdf) +(pushnew `(merge-pathnames ,(make-pathname :directory '(:relative "systems")) + ,*private-asdf-install-dirs*) + asdf:*central-registry* + :test #'equal) + +#+mk-defsystem +(mk:add-registry-location + (merge-pathnames (make-pathname :directory '(:relative "site-systems")) + *private-asdf-install-dirs*)) + +#+mk-defsystem +(mk:add-registry-location + (merge-pathnames (make-pathname :directory '(:relative "systems")) + *private-asdf-install-dirs*)) + + +;;; Fixing the handling of *LOCATIONS* + +(defun add-locations (loc-name site system-site) + (declare (type string loc-name) + (type pathname site system-site)) + #+asdf + (progn + (pushnew site asdf:*central-registry* :test #'equal) + (pushnew system-site asdf:*central-registry* :test #'equal)) + + #+mk-defsystem + (progn + (mk:add-registry-location site) + (mk:add-registry-location system-site)) + (setf *locations* + (append *locations* (list (list site system-site loc-name))))) + + + +(eval-when (:load-toplevel :execute) + (let* ((*package* (find-package :asdf-install-customize)) + (file (probe-file (merge-pathnames + (make-pathname :name ".asdf-install") + (truename (user-homedir-pathname))))) + ) + (when file (load file)))) + + +;;;--------------------------------------------------------------------------- +;;; Conditions. + +(define-condition download-error (error) + ((url :initarg :url :reader download-url) + (response :initarg :response :reader download-response)) + (:report (lambda (c s) + (format s "Server responded ~A for GET ~A" + (download-response c) (download-url c))))) + +(define-condition signature-error (error) + ((cause :initarg :cause :reader signature-error-cause)) + (:report (lambda (c s) + (format s "Cannot verify package signature: ~A" + (signature-error-cause c))))) + +(define-condition gpg-error (error) + ((message :initarg :message :reader gpg-error-message)) + (:report (lambda (c s) + (format s "GPG failed with error status:~%~S" + (gpg-error-message c))))) + +(define-condition no-signature (gpg-error) ()) + +(define-condition key-not-found (gpg-error) + ((key-id :initarg :key-id :reader key-id)) + (:report (lambda (c s) + (format s "No key found for key id 0x~A. ~ + Try some command like ~% gpg --recv-keys 0x~A" + (key-id c) (key-id c))))) + +(define-condition key-not-trusted (gpg-error) + ((key-id :initarg :key-id :reader key-id) + (key-user-name :initarg :key-user-name :reader key-user-name)) + (:report (lambda (c s) + (format s "GPG warns that the key id 0x~A (~A) is not fully trusted" + (key-id c) (key-user-name c))))) + +(define-condition author-not-trusted (gpg-error) + ((key-id :initarg :key-id :reader key-id) + (key-user-name :initarg :key-user-name :reader key-user-name)) + (:report (lambda (c s) + (format s "~A (key id ~A) is not on your package supplier list" + (key-user-name c) (key-id c))))) + + +;;;--------------------------------------------------------------------------- +;;; URL handling. + +(defun url-host (url) + (assert (string-equal url "http://" :end1 7)) + (let* ((port-start (position #\: url :start 7)) + (host-end (min (or (position #\/ url :start 7) (length url)) + (or port-start (length url))))) + (subseq url 7 host-end))) + +(defun url-port (url) + (assert (string-equal url "http://" :end1 7)) + (let ((port-start (position #\: url :start 7))) + (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80))) + +; This is from Juri Pakaste's base64.lisp +(defparameter *encode-table* + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") + +(defun base64-encode (string) + (let ((result (make-array + (list (* 4 (truncate (/ (+ 2 (length string)) 3)))) + :element-type 'base-char))) + (do ((sidx 0 (+ sidx 3)) + (didx 0 (+ didx 4)) + (chars 2 2) + (value nil nil)) + ((>= sidx (length string)) t) + (setf value (ash (logand #xFF (char-code (char string sidx))) 8)) + (dotimes (n 2) + (when (< (+ sidx n 1) (length string)) + (setf value + (logior value + (logand #xFF (char-code (char string (+ sidx n 1)))))) + (incf chars)) + (when (= n 0) + (setf value (ash value 8)))) + (setf (elt result (+ didx 3)) + (elt *encode-table* (if (> chars 3) (logand value #x3F) 64))) + (setf value (ash value -6)) + (setf (elt result (+ didx 2)) + (elt *encode-table* (if (> chars 2) (logand value #x3F) 64))) + (setf value (ash value -6)) + (setf (elt result (+ didx 1)) + (elt *encode-table* (logand value #x3F))) + (setf value (ash value -6)) + (setf (elt result didx) + (elt *encode-table* (logand value #x3F)))) + result)) + +(defvar *proxy-user* nil) +(defvar *proxy-passwd* nil) + +(defun url-connection (url) + (let ((stream (make-stream-from-url (or *proxy* url))) + (host (url-host url))) + (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C" + url #\Return #\Linefeed + host #\Return #\Linefeed + *cclan-mirror* #\Return #\Linefeed) + (when (and *proxy-passwd* *proxy-user*) + (format stream "Proxy-Authorization: Basic ~A~C~C" + (base64-encode (format nil "~A:~A" *proxy-user* *proxy-passwd*)) + #\Return #\Linefeed)) + (format stream "~C~C" #\Return #\Linefeed) + (force-output stream) + (flet (#-:digitool + (read-header-line () + (read-line stream)) + #+:digitool + (read-header-line (&aux (line (make-array 16 + :element-type 'character + :adjustable t + :fill-pointer 0)) + (byte nil)) + (print (multiple-value-bind (reader arg) + (ccl::stream-reader stream) + (loop (setf byte (funcall reader arg)) + (case byte + ((nil) + (return)) + ((#.(char-code #\Return) + #.(char-code #\Linefeed)) + (case (setf byte (funcall reader arg)) + ((nil #.(char-code #\Return) #.(char-code #\Linefeed))) + (t (ccl:stream-untyi stream byte))) + (return)) + (t + (vector-push-extend (code-char byte) line)))) + (when (or byte (plusp (length line))) + line))))) + (list + (let* ((l (read-header-line)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-header-line) + until (or (null line) + (zerop (length line)) + (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream)))) + + +(defun download-files-for-package (package-name-or-url file-name) + (let ((url (if (= (mismatch package-name-or-url "http://") 7) + package-name-or-url + (format nil "http://www.cliki.net/~A?download" + package-name-or-url))) + ) + (destructuring-bind (response headers stream) + (block got + (loop + (destructuring-bind (response headers stream) (url-connection url) + (unless (member response '(301 302)) + (return-from got (list response headers stream))) + (close stream) + (setf url (cdr (assoc :location headers)))))) + (when (>= response 400) + (error 'download-error :url url :response response)) + (let ((length (parse-integer (or (cdr (assoc :content-length headers)) "") + :junk-allowed t))) + (installer-msg t "Downloading ~A bytes from ~A to ~A ..." + (or length "some unknown number of") + url + file-name) + (force-output) + #+:clisp (setf (stream-element-type stream) + '(unsigned-byte 8)) + (with-open-file (o file-name :direction :output + #+(or :clisp :digitool (and :lispworks :win32)) + :element-type + #+(or :clisp :digitool (and :lispworks :win32)) + '(unsigned-byte 8) + :if-exists :supersede) + #+(or :cmu :digitool) + (copy-stream stream o) + #-(or :cmu :digitool) + (if length + (let ((buf (make-array length + :element-type + (stream-element-type stream)))) + #-:clisp (read-sequence buf stream) + #+:clisp (ext:read-byte-sequence buf stream :no-hang nil) + (write-sequence buf o)) + (copy-stream stream o)))) + (close stream) + (terpri) + (restart-case + (verify-gpg-signature/url url file-name) + (skip-gpg-check (&rest rest) + :report "Don't ckeck GPG signature for this package" + (declare (ignore rest)) + nil))))) + + +(defun read-until-eof (stream) + (with-output-to-string (o) + (copy-stream stream o))) + + +(defun verify-gpg-signature/string (string file-name) + (let ((gpg-stream (make-stream-from-gpg-command string file-name)) + tags) + (unwind-protect + (loop for l = (read-line gpg-stream nil nil) + while l + do (print l) + when (> (mismatch l "[GNUPG:]") 6) + do (destructuring-bind (_ tag &rest data) + (split-sequence:split-sequence-if (lambda (x) + (find x '(#\Space #\Tab))) + l) + (declare (ignore _)) + (pushnew (cons (intern tag :keyword) + data) tags))) + (ignore-errors + (close gpg-stream))) + ;; test for obvious key/sig problems + (let ((errsig (assoc :errsig tags))) + (and errsig (error 'key-not-found :key-id (second errsig)))) + (let ((badsig (assoc :badsig tags))) + (and badsig (error 'key-not-found :key-id (second badsig)))) + (let* ((good (assoc :goodsig tags)) + (id (second good)) + (name (format nil "~{~A~^ ~}" (nthcdr 2 good)))) + ;; good signature, but perhaps not trusted + (unless (or (assoc :trust_ultimate tags) + (assoc :trust_fully tags)) + (cerror "Install the package anyway" + 'key-not-trusted + :key-user-name name + :key-id id)) + (loop + (when + (restart-case + (or (assoc id *trusted-uids* :test #'equal) + (error 'author-not-trusted + :key-user-name name + :key-id id)) + (add-key (&rest rest) + :report "Add to package supplier list" + (declare (ignore rest)) + (pushnew (list id name) *trusted-uids*))) + (return)))))) + + +(defun verify-gpg-signature/url (url file-name) + (when (verify-gpg-signatures-p url) + (destructuring-bind (response headers stream) + (url-connection (concatenate 'string url ".asc")) + (unwind-protect + (flet (#-:digitool + (read-signature (data stream) + (read-sequence data stream)) + #+:digitool + (read-signature (data stream) + (multiple-value-bind (reader arg) + (ccl:stream-reader stream) + (let ((byte 0)) + (dotimes (i (length data)) + (unless (setf byte (funcall reader arg)) + (error 'download-error :url (concatenate 'string url ".asc") + :response 200)) + (setf (char data i) (code-char byte))))))) + (if (= response 200) + (let ((data (make-string (parse-integer + (cdr (assoc :content-length headers)) + :junk-allowed t)))) + (read-signature data stream) + (verify-gpg-signature/string data file-name)) + (error 'download-error :url (concatenate 'string url ".asc") + :response response))) + (close stream))))) + + +(define-condition installation-abort (condition) + () + (:report (lambda (c s) + (declare (ignore c)) + (installer-msg s "Installation aborted.")))) + + +(defun where () + (loop with n-locations = (length *locations*) + for response = (or *preferred-location* + (progn + (format t "Install where?~%") + (loop for (source system name) in *locations* + for i from 0 + do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" + i name system source)) + (format t "~D) Abort installation.~% --> " n-locations) + (force-output) + (read))) + when (and (numberp response) + (<= 0 response (1- n-locations))) + return (elt *locations* response) + when (and (numberp response) + (= response n-locations)) + do (abort (make-condition 'installation-abort)))) + + +;;; install-package -- + +(defun install-package (source system packagename) + "Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems." + (ensure-directories-exist source) + (ensure-directories-exist system) + (let* ((tar + (or #-(or :win32 :mswindows) + (return-output-from-program *gnu-tar-program* + (list "-C" (namestring (truename source)) + "-xzvf" (namestring (truename packagename)))) + #+(or :win32 :mswindows) + (return-output-from-program *cygwin-bash-program* + (list "-l" + "-c" + (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\"" + (namestring (truename source)) + (namestring (truename packagename))))) + (error "ASDF-INSTALL: can't untar ~S." packagename))) + (pos-slash (or (position #\/ tar) + (position #\Return tar) + (position #\Linefeed tar))) + (*default-pathname-defaults* + (merge-pathnames + (make-pathname :directory + `(:relative ,(subseq tar 0 pos-slash))) + source)) + ) + (princ tar) + (loop for sysfile in (append + (directory + (make-pathname :defaults (print *default-pathname-defaults*) + :name :wild + :type "asd")) + (directory + (make-pathname :defaults (print *default-pathname-defaults*) + :name :wild + :type "system"))) + #-(or :win32 :mswindows) + do + #-(or :win32 :mswindows) + (let ((target (merge-pathnames + (make-pathname :name (pathname-name sysfile) + :type (pathname-type sysfile)) + system))) + (when (probe-file target) + (unlink-file target)) + (symlink-files sysfile target)) + collect sysfile))) + + +#| Original +(defun install-package (source system packagename) + "Returns a list of asdf system names for installed asdf systems" + (ensure-directories-exist source) + (ensure-directories-exist system) + (let* ((tar + (or + #-(or :win32 :mswindows) + (return-output-from-program "tar" + (list "-C" (system-namestring source) + "-xzvf" (system-namestring packagename))) + #+(or :win32 :mswindows) + (return-output-from-program "sh" + (list "-c" + (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\"" + (namestring (truename source)) + (namestring (truename packagename))))) + (error "can't untar"))) + (pos-slash (position-if #'(lambda (c) + (find c #(#\/ #\Return #\Linefeed))) + tar)) + (*default-pathname-defaults* + (merge-pathnames + (make-pathname :directory + `(:relative ,(subseq tar 0 pos-slash))) + source))) + (princ tar) + (loop for asd in (directory + (make-pathname :defaults (print *default-pathname-defaults*) + :name :wild + :type "asd")) + #-(or :win32 :mswindows) + do + #-(or :win32 :mswindows) + (let ((target (merge-pathnames + (make-pathname :name (pathname-name asd) + :type (pathname-type asd)) + system))) + (when (probe-file target) + (unlink-file target)) + (symlink-files asd target)) + collect (pathname-name asd)))) +|# + + +(defun temp-file-name (p) + (let* ((pos-slash (position #\/ p :from-end t)) + (pos-dot (position #\. p :start (or pos-slash 0)))) + (merge-pathnames + (make-pathname + :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot) + :type "asdf-install-tmp") + #+:clisp (user-homedir-pathname)))) + + +;;; install +;;; This is the external entry point. + +(defun install (&rest packages) + (let ((*temporary-files* nil) + (*trusted-uids* + (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))) + (when (probe-file p) + (with-open-file (f p) (read f))))) + ;; (installed-packages nil) + ) + (unwind-protect + (destructuring-bind (source system name) (where) + (declare (ignore name)) + (labels ((one-iter (packages) + (let ((installed-package-sysfiles + (loop for p in (mapcar #'string packages) + unless + #+(or :sbcl :alisp) (probe-file p) + #-(or :sbcl :alisp) (and (/= (mismatch p "http://") 7) + (probe-file p)) + do (let ((tmp (temp-file-name p))) + (pushnew tmp *temporary-files*) + (download-files-for-package p tmp) + (setf p tmp)) + end + do (installer-msg t "Installing ~A in ~A, ~A" + p + source + system) + append (install-package source + system + p))) + ) + (dolist (sysfile installed-package-sysfiles) + (handler-bind + ( + #+asdf + (asdf:missing-dependency + (lambda (c) + (installer-msg t + "Downloading package ~A, required by ~A~%" + (asdf::missing-requires c) + (asdf:component-name + (asdf::missing-required-by c))) + (one-iter (list + (symbol-name + (asdf::missing-requires c)))) + (invoke-restart 'retry))) + + #+mk-defsystem + (make:missing-component + (lambda (c) + (installer-msg t + "Downloading package ~A, required by ~A~%" + (make:missing-component-name c) + (pathname-name sysfile) ; This should work. + ) + (one-iter (list (make:missing-component-name c))) + (invoke-restart 'retry))) + ) + + (loop (multiple-value-bind (ret restart-p) + (with-simple-restart + (retry "Retry installation") + (load-system-definition sysfile)) + (declare (ignore ret)) + (unless restart-p (return)))) + )))) + ) + (one-iter packages))) + (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))) + (when (probe-file p) + (with-open-file (out p + :direction :output + :if-exists :supersede) + (with-standard-io-syntax + (prin1 *trusted-uids* out))))) + (dolist (l *temporary-files* t) + (when (probe-file l) (delete-file l)))))) + + +(defun load-system-definition (sysfile) + (declare (type pathname sysfile)) + #+asdf + (when (or (string-equal "asd" (pathname-type sysfile)) + (string-equal "asdf" (pathname-type sysfile))) + (installer-msg t "Loading system ~S via ASDF." (pathname-name sysfile)) + (asdf:operate 'asdf:load-op (pathname-name sysfile))) + + #+mk-defsystem + (when (string-equal "system" (pathname-type sysfile)) + (installer-msg t "Loading system ~S via MK:DEFSYSTEM." (pathname-name sysfile)) + (mk:load-system (pathname-name sysfile)))) + + +#| Original. +(defun install (&rest packages) + (let ((*temporary-files* nil) + (*trusted-uids* + (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))) + (when (probe-file p) + (with-open-file (f p) (read f)))))) + (unwind-protect + (destructuring-bind (source system name) (where) + (declare (ignore name)) + (labels ((one-iter (packages) + (dolist (asd + (loop for p in (mapcar 'string packages) + unless #+(or :sbcl :alisp) + (probe-file p) + #-(or :sbcl :alisp) + (and (/= (mismatch p "http://") 7) + (probe-file p)) + do (let ((tmp (temp-file-name p))) + (pushnew tmp *temporary-files*) + (download-files-for-package p tmp) + (setf p tmp)) + end + do (format t "Installing ~A in ~A,~A~%" + p source system) + append (install-package source system p))) + (handler-bind + ((asdf:missing-dependency + (lambda (c) + (format t + "Downloading package ~A, required by ~A~%" + (asdf::missing-requires c) + (asdf:component-name + (asdf::missing-required-by c))) + (one-iter (list + (symbol-name + (asdf::missing-requires c)))) + (invoke-restart 'retry)))) + (loop + (multiple-value-bind (ret restart-p) + (with-simple-restart + (retry "Retry installation") + (asdf:operate 'asdf:load-op asd)) + (declare (ignore ret)) + (unless restart-p (return)))))))) + (one-iter packages))) + (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))) + (with-open-file (out p :direction :output + :if-exists :supersede) + (with-standard-io-syntax + (prin1 *trusted-uids* out)))) + (dolist (l *temporary-files*) + (when (probe-file l) (delete-file l)))))) +|# + + +;;; uninstall -- + +(defun uninstall (system &optional (prompt t)) + #+asdf + (let* ((asd (asdf:system-definition-pathname system)) + (system (asdf:find-system system)) + (dir (asdf::pathname-sans-name+type + (asdf::resolve-symlinks asd)))) + (when (or (not prompt) + (y-or-n-p + "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" + system asd dir)) + #-(or :win32 :mswindows) + (delete-file asd) + (asdf:run-shell-command "rm -r '~A'" (namestring (truename dir))))) + + #+mk-defsystem + (multiple-value-bind (sysfile sysfile-exists-p) + (mk:system-definition-pathname system) + (when sysfile-exists-p + (let ((system (ignore-errors (mk:find-system system :error)))) + (when system + (when (or (not prompt) + (y-or-n-p + "Delete system ~A.~%system file: ~A~%Are you sure?" + system + sysfile)) + (mk:clean-system system) + (delete-file sysfile) + (dolist (f (mk:files-in-system system)) + (delete-file f))) + )) + ))) + + +#| Original +(defun uninstall (system &optional (prompt t)) + (let* ((asd (asdf:system-definition-pathname system)) + (system (asdf:find-system system)) + (dir (asdf::pathname-sans-name+type + (asdf::resolve-symlinks asd)))) + (when (or (not prompt) + (y-or-n-p + "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" + system asd dir)) + #-(or :win32 :mswindows) + (delete-file asd) + (asdf:run-shell-command "rm -r '~A'" (namestring (truename dir)))))) +|# + + +;;; some day we will also do UPGRADE, but we need to sort out version +;;; numbering a bit better first + +#+(and :asdf (or :win32 :mswindows)) +(defun sysdef-source-dir-search (system) + (let ((name (asdf::coerce-name system))) + (dolist (location *locations*) + (let* ((dir (first location)) + (files (directory (merge-pathnames + (make-pathname :name name + :type "asd" + :version :newest + :directory '(:relative :wild) + :host nil + :device nil) + dir)))) + (dolist (file files) + (when (probe-file file) + (return-from sysdef-source-dir-search file))))))) + +;;; end of file -- install.lisp -- Index: /branches/experimentation/later/source/tools/asdf-install/load-asdf-install.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/load-asdf-install.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/load-asdf-install.lisp (revision 8058) @@ -0,0 +1,111 @@ +;;; -*- Mode: Lisp -*- + +;;; load-asdf-install.lisp -- +;;; Generic loader for ASDF-INSTALL. + +(eval-when (:load-toplevel :execute) + (unless (find-package "ASDF-INSTALL-LOADER") + (make-package "ASDF-INSTALL-LOADER" :use '("COMMON-LISP")))) + +(in-package "ASDF-INSTALL-LOADER") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *asdf-install-directory* + (make-pathname :host (pathname-host *load-truename*) + :device (pathname-device *load-truename*) + :directory (pathname-directory *load-truename*) + ;; :case :common ; Do we need this? + ))) + + +(defun cl-user::load-asdf-install + (&key + (directory *asdf-install-directory*) + (compile-first-p nil) + (load-verbose *load-verbose*) + (print-herald t) + ) + (when print-herald + (format *standard-output* + "~&;;; ASDF-INSTALL: Loading ASDF-INSTALL package from directory~@ + ;;; \"~A\"~2%" + (namestring (pathname directory)))) + (let ((directory (pathname directory))) + (flet ((load-and-or-compile (file) + (if compile-first-p + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file file) + ;; (declare (ignore warnings-p)) + (when failure-p + (format *standard-output* + ";;; File ~S compiled~@ + ;;; Warnings ~S, Failure ~S.~%" + output-truename + warnings-p + failure-p) + (return-from cl-user::load-asdf-install nil) + ) + (load output-truename :verbose load-verbose)) + (load file :verbose load-verbose))) + ) + + (setf (logical-pathname-translations "ASDF-INSTALL-LIBRARY") + `(("**;*.*.*" + ,(make-pathname + :host (pathname-host directory) + :device (pathname-device directory) + :directory (append (pathname-directory directory) + (list :wild-inferiors)))) + ("**;*.*" + ,(make-pathname + :host (pathname-host directory) + :device (pathname-device directory) + :directory (append (pathname-directory directory) + (list :wild-inferiors)))))) + + (load-and-or-compile "ASDF-INSTALL-LIBRARY:defpackage.lisp") + (load-and-or-compile "ASDF-INSTALL-LIBRARY:port.lisp") + + (unless (find-package "SPLIT-SEQUENCE") + (load-and-or-compile "ASDF-INSTALL-LIBRARY:split-sequence.lisp")) + + #| + ;; Implementation dependencies (in alphabetical order). + #+allegro + (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;allegro.lisp") + + #+clisp + (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;clisp.lisp") + + #+(or cmu sbcl) ; They are still very similar. + (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;cmucl.lisp") + + #+digitool + (load-and-or-compile "ASDF-INSTALL-LIBRARY:digitool.lisp") + + #+lcl + (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;lcl.lisp") + + #+lispworks + (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;lispworks.lisp") + |# + + + (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp") + ;; (load-and-or-compile "ASDF-INSTALL-LIBRARY:loader.lisp") + + )) + (pushnew :asdf-install *features*) + (provide 'asdf-install) + + ;; To clean a minimum (and to make things difficult to debug)... + ;; (delete-package "ASDF-INSTALL-LOADER") + ) + + +;;; Automatically load the library. + +(eval-when (:load-toplevel :execute) + (cl-user::load-asdf-install)) + +;;; end of file -- load-asdf-install.lisp -- Index: /branches/experimentation/later/source/tools/asdf-install/loader.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/loader.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/loader.lisp (revision 8058) @@ -0,0 +1,15 @@ +(in-package :cl-user) + +(eval-when (:load-toplevel) + (unless (find-package 'asdf) + (require 'asdf)) + (let ((asdf::*verbose-out* nil)) + (require 'asdf-install))) + +(defun run () + (handler-case + (apply #'asdf-install:install (cdr *posix-argv*)) + (error (c) + (format *error-output* "Install failed due to error:~% ~A~%" c) + (sb-ext:quit :unix-status 1)))) + Index: /branches/experimentation/later/source/tools/asdf-install/port.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/port.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/port.lisp (revision 8058) @@ -0,0 +1,353 @@ +(in-package :asdf-install) + +(defvar *temporary-files*) + +(eval-when (:load-toplevel :compile-toplevel :execute) + #+:lispworks + (require "comm") + #+:allegro + (require :osi) + #+:allegro + (require :socket) + #+:digitool + (require :opentransport)) + +(defun get-env-var (name) + #+:sbcl (sb-ext:posix-getenv name) + #+:cmu (cdr (assoc (intern (substitute #\_ #\- name) + :keyword) + ext:*environment-list*)) + #+:allegro (sys:getenv name) + #+:lispworks (lw:environment-variable name) + #+:clisp (ext:getenv name) + #+(or :mcl :openmcl) (ccl::getenv name)) + +#-:digitool +(defun system-namestring (pathname) + (namestring (truename pathname))) + +#+:digitool +(defvar *start-up-volume* + (second (pathname-directory (truename "ccl:")))) + +#+:digitool +(defun system-namestring (pathname) + ;; this tries to adjust the root directory to eliminate the spurious + ;; volume name for the boot file system; it also avoids use of + ;; TRUENAME as some applications are for not yet existent files + (let ((truename (probe-file pathname))) + (unless truename + (setf truename + (translate-logical-pathname + (merge-pathnames pathname *default-pathname-defaults*)))) + (let ((directory (pathname-directory truename))) + (flet ((string-or-nil (value) (when (stringp value) value)) + (absolute-p (directory) (eq (first directory) :absolute)) + (root-volume-p (directory) + (equal *start-up-volume* (second directory)))) + (format nil "~:[~;/~]~{~a/~}~@[~a~]~@[.~a~]" + (absolute-p directory) + (if (root-volume-p directory) (cddr directory) (cdr directory)) + (string-or-nil (pathname-name truename)) + (string-or-nil (pathname-type truename))))))) + +#+:digitool +(progn + (defun |read-linefeed-eol-comment| + (stream char &optional (eol '(#\return #\linefeed))) + (loop (setf char (read-char stream nil nil)) + (unless char (return)) + (when (find char eol) (return))) + (values)) + + (set-syntax-from-char #\linefeed #\space) + (set-macro-character #\; #'|read-linefeed-eol-comment| nil *readtable*)) + +;; for non-SBCL we just steal this from SB-EXECUTABLE +#-(or :sbcl :digitool) +(defvar *stream-buffer-size* 8192) +#-(or :sbcl :digitool) +(defun copy-stream (from to) + "Copy into TO from FROM until end of the input stream, in blocks of +*stream-buffer-size*. The streams should have the same element type." + (unless (subtypep (stream-element-type to) (stream-element-type from)) + (error "Incompatible streams ~A and ~A." from to)) + (let ((buf (make-array *stream-buffer-size* + :element-type (stream-element-type from)))) + (loop + (let ((pos #-(or :clisp :cmu) (read-sequence buf from) + #+:clisp (ext:read-byte-sequence buf from :no-hang nil) + #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil))) + (when (zerop pos) (return)) + (write-sequence buf to :end pos))))) + +#+:digitool +(defun copy-stream (from to) + "Perform copy and map EOL mode." + (multiple-value-bind (reader reader-arg) (ccl::stream-reader from) + (multiple-value-bind (writer writer-arg) (ccl::stream-writer to) + (let ((datum nil)) + (loop (unless (setf datum (funcall reader reader-arg)) + (return)) + (funcall writer writer-arg datum)))))) + +#+:sbcl +(declaim (inline copy-stream)) +#+:sbcl +(defun copy-stream (from to) + (sb-executable:copy-stream from to)) + +(defun make-stream-from-url (url) + #+:sbcl + (let ((s (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect + s (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name (url-host url)))) + (url-port url)) + (sb-bsd-sockets:socket-make-stream s :input t :output t :buffering :full)) + #+:cmu + (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url)) + :input t :output t :buffering :full) + #+:lispworks + (comm:open-tcp-stream (url-host url) (url-port url) + #+(and :lispworks :win32) :element-type + #+(and :lispworks :win32) '(unsigned-byte 8)) + #+:allegro + (socket:make-socket :remote-host (url-host url) + :remote-port (url-port url)) + #+:clisp + (socket:socket-connect (url-port url) (url-host url) + :external-format + (ext:make-encoding :charset 'charset:iso-8859-1 :line-terminator :unix)) + #+:openmcl + (ccl:make-socket :remote-host (url-host url) + :remote-port (url-port url)) + #+:digitool + (ccl::open-tcp-stream (url-host url) (url-port url) + :element-type 'unsigned-byte)) + +#+(or :sbcl :cmu) +(defun make-stream-from-gpg-command (string file-name) + (#+:sbcl sb-ext:process-output + #+:cmu ext:process-output + (#+:sbcl sb-ext:run-program + #+:cmu ext:run-program + "gpg" + (list + "--status-fd" "1" "--verify" "-" + (namestring file-name)) + :output :stream + :error nil + #+sbcl :search #+sbcl t + :input (make-string-input-stream string) + :wait t))) + +#+(and :lispworks (not :win32)) +(defun make-stream-from-gpg-command (string file-name) + ;; kludge - we can't separate the in and out streams + (let ((stream (sys:open-pipe (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A" + string + (namestring file-name))))) + stream)) + +(defun make-temp-sig (file-name content) + (let ((name (format nil "~A.asc" (namestring (truename file-name))))) + (with-open-file (out name + :direction :output + :if-exists :supersede) + (write-string content out)) + (pushnew name *temporary-files*) + name)) + +#+(and :lispworks :win32) +(defun make-stream-from-gpg-command (string file-name) + (sys:open-pipe (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\"" + (make-temp-sig file-name string) + (namestring file-name)))) + +#+(and :clisp (not (or :win32 :cygwin))) +(defun make-stream-from-gpg-command (string file-name) + (let ((stream + (ext:run-shell-command (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A" + string + (namestring file-name)) + :output :stream + :wait nil))) + stream)) + +#+(and :clisp (or :win32 :cygwin)) +(defun make-stream-from-gpg-command (string file-name) + (ext:run-shell-command (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\"" + (make-temp-sig file-name string) + (namestring file-name)) + :output :stream + :wait nil)) + +#+:allegro +(defun make-stream-from-gpg-command (string file-name) + (multiple-value-bind (in-stream out-stream) + (excl:run-shell-command + #-:mswindows + (concatenate 'vector + #("gpg" "gpg" "--status-fd" "1" "--verify" "-") + (make-sequence 'vector 1 + :initial-element (namestring file-name))) + #+:mswindows + (format nil "gpg --status-fd 1 --verify - \"~A\"" (namestring file-name)) + :input :stream + :output :stream + :separate-streams t + :wait nil) + (write-string string in-stream) + (finish-output in-stream) + (close in-stream) + out-stream)) + +#+:openmcl +(defun make-stream-from-gpg-command (string file-name) + (let ((proc (ccl:run-program "gpg" (list "--status-fd" "1" "--verify" "-" (namestring file-name)) + :input :stream + :output :stream + :wait nil))) + (write-string string (ccl:external-process-input-stream proc)) + (close (ccl:external-process-input-stream proc)) + (ccl:external-process-output-stream proc))) + +#+:digitool +(defun make-stream-from-gpg-command (string file-name) + (make-instance 'popen-input-stream + :command (format nil "echo '~A' | gpg --status-fd 1 --verify - '~A'" + string + (system-namestring file-name)))) + +#+:sbcl +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((proc (sb-ext:run-program + program + args + :output out-stream + :wait t))) + (when (or (null proc) + (and (member (sb-ext:process-status proc) '(:exited :signaled)) + (not (zerop (sb-ext:process-exit-code proc))))) + (return-from return-output-from-program nil))))) + +#+:cmu +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((proc (ext:run-program + program + args + :output out-stream + :wait t))) + (when (or (null proc) + (and (member (ext:process-status proc) '(:exited :signaled)) + (not (zerop (ext:process-exit-code proc))))) + (return-from return-output-from-program nil))))) + +#+:lispworks +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (unless (zerop (sys:call-system-showing-output + (format nil #-:win32 "~A~{ '~A'~}" + #+:win32 "~A~{ ~A~}" + program args) + :prefix "" + :show-cmd nil + :output-stream out-stream)) + (return-from return-output-from-program nil)))) + +#+(and :clisp (not :win32)) +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream + (ext:run-program program + :arguments args + :output :stream + :wait nil))) + (loop for line = (read-line stream nil) + while line + do (write-line line out-stream))))) + +#+(and :clisp :win32) +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream + (ext:run-shell-command + (format nil "~A~{ ~A~}" program args + :output :stream + :wait nil)))) + (loop for line = (ignore-errors (read-line stream nil)) + while line + do (write-line line out-stream))))) + +#+:allegro +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream + (excl:run-shell-command + #-:mswindows + (concatenate 'vector + (list program) + (cons program args)) + #+:mswindows + (format nil "~A~{ ~A~}" program args) + :output :stream + :wait nil))) + (loop for line = (read-line stream nil) + while line + do (write-line line out-stream))))) + +#+:openmcl +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((proc (ccl:run-program program args + :input nil + :output :stream + :wait nil))) + (loop for line = (read-line (ccl:external-process-output-stream proc) nil nil nil) + while line + do (write-line line out-stream))))) + +#+:digitool +(defun return-output-from-program (program args) + (ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args))) + +;; why not just use DELETE-FILE? +(defun unlink-file (pathname) + #+:sbcl + (sb-posix:unlink pathname) + #+:cmu + (unix:unix-unlink (namestring pathname)) + #+:allegro + (excl.osi:unlink pathname) + #+(or :lispwork :clisp :openmcl :digitool) + (delete-file pathname)) + +(defun symlink-files (old new) + #+:sbcl + (sb-posix:symlink old new) + #+:cmu + (unix:unix-symlink (namestring old) + (namestring new)) + #+:allegro + (excl.osi:symlink old new) + #+:lispworks + ;; we loose if the pathnames contain apostrophes... + (sys:call-system (format nil "ln -s '~A' '~A'" + (namestring old) + (namestring new))) + #+:clisp + (ext:run-program "ln" + :arguments (append '("-s") + (list (format nil "~A" (namestring old)) + (format nil "~A" (namestring new))))) + #+:openmcl + (ccl:run-program "ln" (list "-s" (namestring old) (namestring new))) + #+:digitool + (ccl::call-system (format nil "ln -s '~A' '~A'" + (system-namestring old) + (system-namestring new)))) Index: /branches/experimentation/later/source/tools/asdf-install/split-sequence.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf-install/split-sequence.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf-install/split-sequence.lisp (revision 8058) @@ -0,0 +1,247 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; ; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication here, which is kept +;;; to illustrate the relationship between the SPLIT-SEQUENCE +;;; functions and the CL:POSITION functions. + +;;; Examples: +;;; +;;; * (split-sequence #\; "a;;b;c") +;;; -> ("a" "" "b" "c"), 6 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t) +;;; -> ("a" "" "b" "c"), 0 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) +;;; -> ("c"), 4 +;;; +;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) +;;; -> ("a" "b" "c"), 6 +;;; +;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 +;;; +;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("ab" "a" "a" "ab" "a"), 11 +;;; +;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) +;;; -> ("oo" "bar" "b"), 9 + +(defpackage "SPLIT-SEQUENCE" + (:use "CL") + (:nicknames "PARTITION") + (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" + "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT") + (:documentation "The SPLIT-SEQUENCE package provides functionality for Common Lisp sequences analagous to Perl's split operator.")) + +(in-package "SPLIT-SEQUENCE") + +(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by delimiter. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +(CL:COMPLEMENT predicate). + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if-not predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if-not predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +;;; clean deprecation + +(defun partition (&rest args) + "PARTITION is deprecated; use SPLIT-SEQUENCE instead." + (apply #'split-sequence args)) + +(defun partition-if (&rest args) + "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead." + (apply #'split-sequence-if args)) + +(defun partition-if-not (&rest args) + "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead." + (apply #'split-sequence-if-not args)) + +(define-compiler-macro partition (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") + form) + +(define-compiler-macro partition-if (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") + form) + +(define-compiler-macro partition-if-not (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") + form) + +(pushnew :split-sequence *features*) Index: /branches/experimentation/later/source/tools/asdf.lisp =================================================================== --- /branches/experimentation/later/source/tools/asdf.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/asdf.lisp (revision 8058) @@ -0,0 +1,1173 @@ +;;; This is asdf: Another System Definition Facility. $Revision$ +;;; +;;; Feedback, bug reports, and patches are all welcome: please mail to +;;; . But note first that the canonical +;;; source for asdf is presently the cCLan CVS repository at +;;; +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the CVS HEAD +;;; is the latest development version, whereas the revision tagged +;;; RELEASE may be slightly older but is considered `stable' + +;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;;; the problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file + +(defpackage #:asdf + (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:hyperdocumentation #:hyperdoc + + #:compile-op #:load-op #:load-source-op #:test-system-version + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + + #:operation-on-warnings + #:operation-on-failure + + ;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*asdf-revision* + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + #:duplicate-names + + #:retry + #:accept ; restarts + + ) + (:use :cl)) + +#+nil +(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") + + +(in-package #:asdf) + +(defvar *asdf-revision* (let* ((v "$Revision$") + (colon (or (position #\: v) -1)) + (dot (position #\. v))) + (and v colon dot + (list (parse-integer v :start (1+ colon) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t))))) + +(defvar *compile-file-warnings-behaviour* :warn) +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) + +(defvar *verbose-out* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utility stuff + +(defmacro aif (test then &optional else) + `(let ((it ,test)) (if it ,then ,else))) + +(defun pathname-sans-name+type (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME and TYPE components" + (make-pathname :name nil :type nil :defaults pathname)) + +(define-modify-macro appendf (&rest args) + append "Append onto list") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; classes, condiitons + +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + +(define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply #'format s (format-control c) (format-arguments c))))) + +(define-condition circular-dependency (system-definition-error) + ((components :initarg :components :reader circular-dependency-components))) + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (version :initform nil :reader missing-version :initarg :version) + (parent :initform nil :reader missing-parent :initarg :parent))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(define-condition operation-error (error) + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s "~@" + (error-operation c) (error-component c))))) +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + +(defclass component () + ((name :accessor component-name :initarg :name :documentation + "Component name: designator for a string composed of portable pathname characters") + (version :accessor component-version :initarg :version) + (in-order-to :initform nil :initarg :in-order-to) + ;;; XXX crap name + (do-first :initform nil :initarg :do-first) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) + (parent :initarg :parent :initform nil :reader component-parent) + ;; no direct accessor for pathname, we do this as a method to allow + ;; it to default in funky ways if not supplied + (relative-pathname :initarg :pathname) + (operation-times :initform (make-hash-table ) + :accessor component-operation-times) + ;; XXX we should provide some atomic interface for updating the + ;; component properties + (properties :accessor component-properties :initarg :properties + :initform nil))) + +;;;; methods: conditions + +(defmethod print-object ((c missing-dependency) s) + (format s "~@<~A, required by ~A~@:>" + (call-next-method c nil) (missing-required-by c))) + +(defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) + +;;;; methods: components + +(defmethod print-object ((c missing-component) s) + (format s "~@" + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) + +(defgeneric component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defmethod component-system ((component component)) + (aif (component-parent component) + (component-system it) + component)) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity t) + (ignore-errors + (prin1 (component-name c) stream)))) + +(defclass module (component) + ((components :initform nil :accessor module-components :initarg :components) + ;; what to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing + (if-component-dep-fails :initform :fail + :accessor module-if-component-dep-fails + :initarg :if-component-dep-fails) + (default-component-class :accessor module-default-component-class + :initform 'cl-source-file :initarg :default-component-class))) + +(defgeneric component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defun component-parent-pathname (component) + (aif (component-parent component) + (component-pathname it) + *default-pathname-defaults*)) + +(defgeneric component-relative-pathname (component) + (:documentation "Extracts the relative pathname applicable for a particular component.")) + +(defmethod component-relative-pathname ((component module)) + (or (slot-value component 'relative-pathname) + (make-pathname + :directory `(:relative ,(component-name component)) + :host (pathname-host (component-parent-pathname component))))) + +(defmethod component-pathname ((component component)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) + (merge-pathnames (component-relative-pathname component)))) + +(defgeneric component-property (component property)) + +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + +(defgeneric (setf component-property) (new-value component property)) + +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties)))))) + +(defclass system (module) + ((description :accessor system-description :initarg :description) + (long-description + :accessor system-long-description :initarg :long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence))) + +;;; version-satisfies + +;;; with apologies to christophe rhodes ... +(defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) + +(defgeneric version-satisfies (component version)) + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (return-from version-satisfies t)) + (let ((x (mapcar #'parse-integer + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding systems + +(defvar *defined-systems* (make-hash-table :test 'equal)) +(defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "~@" name)))) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* + '(sysdef-central-registry-search)) + +(defun system-definition-pathname (system) + (some (lambda (x) (funcall x system)) + *system-definition-search-functions*)) + +(defvar *central-registry* + '(*default-pathname-defaults* + #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" + #+nil "telent:asdf;systems;")) + +(defun sysdef-central-registry-search (system) + (let ((name (coerce-name system))) + (block nil + (dolist (dir *central-registry*) + (let* ((defaults (eval dir)) + (file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file))))))) + +(defun make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(defun find-system (name &optional (error-p t)) + (let* ((name (coerce-name name)) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. + on-disk + *package*) + (load on-disk)) + (delete-package package)))) + (let ((in-memory (gethash name *defined-systems*))) + (if in-memory + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) + +(defun register-system (name system) + (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (setf (gethash (coerce-name name) *defined-systems*) + (cons (get-universal-time) system))) + +(defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding components + +(defgeneric find-component (module name &optional version) + (:documentation "Finds the component with name NAME present in the +MODULE module; if MODULE is nil, then the component is assumed to be a +system.")) + +(defmethod find-component ((module module) name &optional version) + (if (slot-boundp module 'components) + (let ((m (find name (module-components module) + :test #'equal :key #'component-name))) + (if (and m (version-satisfies m version)) m)))) + + +;;; a component with no parent is a system +(defmethod find-component ((module (eql nil)) name &optional version) + (let ((m (find-system name nil))) + (if (and m (version-satisfies m version)) m))) + +;;; component subclasses + +(defclass source-file (component) ()) + +(defclass cl-source-file (source-file) ()) +(defclass c-source-file (source-file) ()) +(defclass java-source-file (source-file) ()) +(defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) ()) + +(defgeneric source-file-type (component system)) +(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") +(defmethod source-file-type ((c c-source-file) (s module)) "c") +(defmethod source-file-type ((c java-source-file) (s module)) "java") +(defmethod source-file-type ((c html-file) (s module)) "html") +(defmethod source-file-type ((c static-file) (s module)) nil) + +(defmethod component-relative-pathname ((component source-file)) + (let ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + name-type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; operations + +;;; one of these is instantiated whenever (operate ) is called + +(defclass operation () + ((forced :initform nil :initarg :force :accessor operation-forced) + (original-initargs :initform nil :initarg :original-initargs + :accessor operation-original-initargs) + (visited-nodes :initform nil :accessor operation-visited-nodes) + (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (parent :initform nil :initarg :parent :accessor operation-parent))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity t) + (ignore-errors + (prin1 (operation-original-initargs o) stream)))) + +(defmethod shared-initialize :after ((operation operation) slot-names + &key force + &allow-other-keys) + (declare (ignore slot-names force)) + ;; empty method to disable initarg validity checking + ) + +(defgeneric perform (operation component)) +(defgeneric operation-done-p (operation component)) +(defgeneric explain (operation component)) +(defgeneric output-files (operation component)) +(defgeneric input-files (operation component)) + +(defun node-for (o c) + (cons (class-name (class-of o)) c)) + +(defgeneric operation-ancestor (operation) + (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + +(defmethod operation-ancestor ((operation operation)) + (aif (operation-parent operation) + (operation-ancestor it) + operation)) + + +(defun make-sub-operation (c o dep-c dep-o) + (let* ((args (copy-list (operation-original-initargs o))) + (force-p (getf args :force))) + ;; note explicit comparison with T: any other non-NIL force value + ;; (e.g. :recursive) will pass through + (cond ((and (null (component-parent c)) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) + + +(defgeneric visit-component (operation component data)) + +(defmethod visit-component ((o operation) (c component) data) + (unless (component-visited-p o c) + (push (cons (node-for o c) data) + (operation-visited-nodes (operation-ancestor o))))) + +(defgeneric component-visited-p (operation component)) + +(defmethod component-visited-p ((o operation) (c component)) + (assoc (node-for o c) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) + +(defgeneric (setf visiting-component) (new-value operation component)) + +(defmethod (setf visiting-component) (new-value operation component) + ;; MCL complains about unused lexical variables + (declare (ignorable new-value operation component))) + +(defmethod (setf visiting-component) (new-value (o operation) (c component)) + (let ((node (node-for o c)) + (a (operation-ancestor o))) + (if new-value + (pushnew node (operation-visiting-nodes a) :test 'equal) + (setf (operation-visiting-nodes a) + (remove node (operation-visiting-nodes a) :test 'equal))))) + +(defgeneric component-visiting-p (operation component)) + +(defmethod component-visiting-p ((o operation) (c component)) + (let ((node (cons o c))) + (member node (operation-visiting-nodes (operation-ancestor o)) + :test 'equal))) + +(defgeneric component-depends-on (operation component)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (class-name (class-of o)) + (slot-value c 'in-order-to)))) + +(defgeneric component-self-dependencies (operation component)) + +(defmethod component-self-dependencies ((o operation) (c component)) + (let ((all-deps (component-depends-on o c))) + (remove-if-not (lambda (x) + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + +(defmethod input-files ((operation operation) (c component)) + (let ((parent (component-parent c)) + (self-deps (component-self-dependencies operation c))) + (if self-deps + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(defmethod input-files ((operation operation) (c module)) nil) + +(defmethod operation-done-p ((o operation) (c component)) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) + +;;; So you look at this code and think "why isn't it a bunch of +;;; methods". And the answer is, because standard method combination +;;; runs :before methods most->least-specific, which is back to front +;;; for our purposes. And CLISP doesn't have non-standard method +;;; combinations, so let's keep it simple and aspire to portability + +(defgeneric traverse (operation component)) +(defmethod traverse ((operation operation) (c component)) + (let ((forced nil)) + (labels ((do-one-dep (required-op required-c required-v) + (let* ((dep-c (or (find-component + (component-parent c) + ;; XXX tacky. really we should build the + ;; in-order-to slot with canonicalized + ;; names instead of coercing this late + (coerce-name required-c) required-v) + (error 'missing-dependency :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency :required-by c + :requires (car dep) :version nil))) + (t + (dolist (d dep) + (cond ((consp d) + (assert (string-equal + (symbol-name (first d)) + "VERSION")) + (appendf forced + (do-one-dep op (second d) (third d)))) + (t + (appendf forced (do-one-dep op d nil))))))))) + (aif (component-visited-p operation c) + (return-from traverse + (if (cdr it) (list (cons 'pruned-op c)) nil))) + ;; dependencies + (if (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) + (setf (visiting-component operation c) t) + (loop for (required-op . deps) in (component-depends-on operation c) + do (do-dep required-op deps)) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c)))))) + (setf (visiting-component operation c) nil) + (visit-component operation c (and forced t)) + forced))) + + +(defmethod perform ((operation operation) (c source-file)) + (sysdef-error + "~@" + (class-of operation) (class-of c))) + +(defmethod perform ((operation operation) (c module)) + nil) + +(defmethod explain ((operation operation) (component component)) + (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) + +;;; compile-op + +(defclass compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (on-warnings :initarg :on-warnings :accessor operation-on-warnings + :initform *compile-file-warnings-behaviour*) + (on-failure :initarg :on-failure :accessor operation-on-failure + :initform *compile-file-failure-behaviour*))) + +(defmethod perform :before ((operation compile-op) (c source-file)) + (map nil #'ensure-directories-exist (output-files operation c))) + +(defmethod perform :after ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (get-universal-time))) + +;;; perform is required to check output-files to find out where to put +;;; its answers, in case it has been overridden for site policy +(defmethod perform ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c)))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file source-file + :output-file output-file) + ;(declare (ignore output)) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation))))) + +(defmethod output-files ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #+:broken-fasl-loader (list (component-pathname c))) + +(defmethod perform ((operation compile-op) (c static-file)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + nil) + +;;; load-op + +(defclass load-op (operation) ()) + +(defmethod perform ((o load-op) (c cl-source-file)) + (mapcar #'load (input-files o c))) + +(defmethod perform ((operation load-op) (c static-file)) + nil) +(defmethod operation-done-p ((operation load-op) (c static-file)) + t) + +(defmethod output-files ((o operation) (c component)) + nil) + +(defmethod component-depends-on ((operation load-op) (c component)) + (cons (list 'compile-op (component-name c)) + (call-next-method))) + +;;; load-source-op + +(defclass load-source-op (operation) ()) + +(defmethod perform ((o load-source-op) (c cl-source-file)) + (let ((source (component-pathname c))) + (setf (component-property c 'last-loaded-as-source) + (and (load source) + (get-universal-time))))) + +(defmethod perform ((operation load-source-op) (c static-file)) + nil) + +(defmethod output-files ((operation load-source-op) (c component)) + nil) + +;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +(defmethod component-depends-on ((o load-source-op) (c component)) + (let ((what-would-load-op-do (cdr (assoc 'load-op + (slot-value c 'in-order-to))))) + (mapcar (lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) + what-would-load-op-do))) + +(defmethod operation-done-p ((o load-source-op) (c source-file)) + (if (or (not (component-property c 'last-loaded-as-source)) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) + nil t)) + +(defclass test-op (operation) ()) + +(defmethod perform ((operation test-op) (c component)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; invoking operations + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) + (let* ((op (apply #'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if verbose *trace-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) + +(defun oos (&rest args) + "Alias of OPERATE function" + (apply #'operate args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; syntax + +(defun remove-keyword (key arglist) + (labels ((aux (key arglist) + (cond ((null arglist) nil) + ((eq key (car arglist)) (cddr arglist)) + (t (cons (car arglist) (cons (cadr arglist) + (remove-keyword + key (cddr arglist)))))))) + (aux key arglist))) + +(defmacro defsystem (name &body options) + (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options + (let ((component-options (remove-keyword :class options))) + `(progn + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + (or ,pathname + (pathname-sans-name+type + (resolve-symlinks *load-truename*)) + *default-pathname-defaults*) + ',component-options)))))) + + +(defun class-for-type (parent type) + (let ((class + (find-class + (or (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) #.(package-name *package*))) + nil))) + (or class + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error "~@" type)))) + +(defun maybe-add-tree (tree op1 op2 c) + "Add the node C at /OP1/OP2 in TREE, unless it's there already. +Returns the new tree (which probably shares structure with the old one)" + (let ((first-op-tree (assoc op1 tree))) + (if first-op-tree + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + +(defun union-of-dependencies (&rest deps) + (let ((new-tree nil)) + (dolist (dep deps) + (dolist (op-tree dep) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + new-tree)) + + +(defun remove-keys (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(defvar *serial-depends-on*) + +(defun parse-component-form (parent options) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) + (when (boundp '*serial-depends-on*) + (setf depends-on + (concatenate 'list *serial-depends-on* depends-on))) + (apply #'reinitialize-instance + ret + :name (coerce-name name) + :pathname pathname + :parent parent + other-args) + (when (typep ret 'module) + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop for c-form in components + for c = (parse-component-form ret c-form) + collect c + if serial + do (push (component-name c) *serial-depends-on*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) + + (setf (slot-value ret 'in-order-to) + (union-of-dependencies + in-order-to + `((compile-op (compile-op ,@depends-on)) + (load-op (load-op ,@depends-on)))) + (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) + + (loop for (n v) in `((perform ,perform) (explain ,explain) + (output-files ,output-files) + (operation-done-p ,operation-done-p)) + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) (remove-method (symbol-function n) m)) + (component-inline-methods ret)) + when v + do (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret)))) + ret))) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) + "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(defun sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) + +(defun resolve-symlinks (path) + #-allegro (truename path) + #+allegro (excl:pathname-resolve-symbolic-links path) + ) + +;;; optional extras + +;;; run-shell-command functions for other lisp implementations will be +;;; gratefully accepted, if they do the same thing. If the docstring +;;; is ambiguous, send a bug report + +(defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code." + (let ((command (apply #'format nil control-string args))) + (format *verbose-out* "; $ ~A~%" command) + #+sbcl + (sb-ext:process-exit-code + (sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + #+win32 #+win32 :search t + :input nil :output *verbose-out*)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+allegro + (excl:run-shell-command command :input nil :output *verbose-out*) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream *verbose-out*) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + )) + + +(defgeneric hyperdocumentation (package name doc-type)) +(defmethod hyperdocumentation ((package symbol) name doc-type) + (hyperdocumentation (find-package package) name doc-type)) + +(defun hyperdoc (name doc-type) + (hyperdocumentation (symbol-package name) name doc-type)) + + +(pushnew :asdf *features*) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") + (pushnew :sbcl-hooks-require *features*))) + +#+(and sbcl sbcl-hooks-require) +(progn + (defun module-provide-asdf (name) + (handler-bind ((style-warning #'muffle-warning)) + (let* ((*verbose-out* (make-broadcast-stream)) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)))) + + (defun contrib-sysdef-search (system) + (let* ((name (coerce-name system)) + (home (truename (sb-ext:posix-getenv "SBCL_HOME"))) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))) + + (pushnew + '(merge-pathnames "site-systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + *central-registry*) + + (pushnew + '(merge-pathnames ".sbcl/systems/" + (user-homedir-pathname)) + *central-registry*) + + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) + +(provide 'asdf) Index: /branches/experimentation/later/source/tools/defsystem.lisp =================================================================== --- /branches/experimentation/later/source/tools/defsystem.lisp (revision 8058) +++ /branches/experimentation/later/source/tools/defsystem.lisp (revision 8058) @@ -0,0 +1,4885 @@ +;;; -*- Mode: Lisp; Package: make -*- +;;; -*- Mode: CLtL; Syntax: Common-Lisp -*- + +;;; DEFSYSTEM 3.4 Interim. + +;;; defsystem.lisp -- + +;;; **************************************************************** +;;; MAKE -- A Portable Defsystem Implementation ******************** +;;; **************************************************************** + +;;; This is a portable system definition facility for Common Lisp. +;;; Though home-grown, the syntax was inspired by fond memories of the +;;; defsystem facility on Symbolics 3600's. The exhaustive lists of +;;; filename extensions for various lisps and the idea to have one +;;; "operate-on-system" function instead of separate "compile-system" +;;; and "load-system" functions were taken from Xerox Corp.'s PCL +;;; system. + +;;; This system improves on both PCL and Symbolics defsystem utilities +;;; by performing a topological sort of the graph of file-dependency +;;; constraints. Thus, the components of the system need not be listed +;;; in any special order, because the defsystem command reorganizes them +;;; based on their constraints. It includes all the standard bells and +;;; whistles, such as not recompiling a binary file that is up to date +;;; (unless the user specifies that all files should be recompiled). + +;;; Originally written by Mark Kantrowitz, School of Computer Science, +;;; Carnegie Mellon University, October 1989. + +;;; MK:DEFSYSTEM 3.3 Interim +;;; +;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved. +;;; 1999 - 2004 Mark Kantrowitz and Marco Antoniotti. All +;;; rights reserved. + +;;; Use, copying, modification, merging, publishing, distribution +;;; and/or sale of this software, source and/or binary files and +;;; associated documentation files (the "Software") and of derivative +;;; works based upon this Software are permitted, as long as the +;;; following conditions are met: + +;;; o this copyright notice is included intact and is prominently +;;; visible in the Software +;;; o if modifications have been made to the source code of the +;;; this package that have not been adopted for inclusion in the +;;; official version of the Software as maintained by the Copyright +;;; holders, then the modified package MUST CLEARLY identify that +;;; such package is a non-standard and non-official version of +;;; the Software. Furthermore, it is strongly encouraged that any +;;; modifications made to the Software be sent via e-mail to the +;;; MK-DEFSYSTEM maintainers for consideration of inclusion in the +;;; official MK-DEFSYSTEM package. + +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. +;;; IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY +;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;;; Except as contained in this notice, the names of M. Kantrowitz and +;;; M. Antoniotti shall not be used in advertising or otherwise to promote +;;; the sale, use or other dealings in this Software without prior written +;;; authorization from M. Kantrowitz and M. Antoniotti. + + +;;; Please send bug reports, comments and suggestions to . + + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in +;;; September and October 1990, but not documented until January 1991. +;;; +;;; akd = Abdel Kader Diagne +;;; as = Andreas Stolcke +;;; bha = Brian Anderson +;;; brad = Brad Miller +;;; bw = Robert Wilhelm +;;; djc = Daniel J. Clancy +;;; fdmm = Fernando D. Mato Mira +;;; gc = Guillaume Cartier +;;; gi = Gabriel Inaebnit +;;; gpw = George Williams +;;; hkt = Rick Taube +;;; ik = Ik Su Yoo +;;; jk = John_Kolojejchick@MORK.CIMDS.RI.CMU.EDU +;;; kt = Kevin Thompson +;;; kc = Kaelin Colclasure +;;; kmr = Kevin M. Rosenberg +;;; lmh = Liam M. Healy +;;; mc = Matthew Cornell +;;; oc = Oliver Christ +;;; rs = Ralph P. Sobek +;;; rs2 = Richard Segal +;;; sb = Sean Boisen +;;; ss = Steve Strassman +;;; tar = Thomas A. Russ +;;; toni = Anton Beschta +;;; yc = Yang Chen +;;; +;;; Thanks to Steve Strassmann and +;;; Sean Boisen for detailed bug reports and +;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit +;;; for help with VAXLisp bugs. +;;; +;;; 05-NOV-90 hkt Changed canonicalize-system-name to make system +;;; names package independent. Interns them in the +;;; keyword package. Thus either strings or symbols may +;;; be used to name systems from the user's point of view. +;;; 05-NOV-90 hkt Added definition FIND-SYSTEM to allow OOS to +;;; work on systems whose definition hasn't been loaded yet. +;;; 05-NOV-90 hkt Added definitions COMPILE-SYSTEM and LOAD-SYSTEM +;;; as alternates to OOS for naive users. +;;; 05-NOV-90 hkt Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT] +;;; into USER package instead of import. +;;; 15-NOV-90 mk Changed package name to "MAKE", eliminating "DEFSYSTEM" +;;; to avoid conflicts with allegro, symbolics packages +;;; named "DEFSYSTEM". +;;; 30-JAN-91 mk Modified append-directories to work with the +;;; logical-pathnames system. +;;; 30-JAN-91 mk Append-directories now works with Sun CL4.0. Also, fixed +;;; bug wrt Lucid 4.0's pathnames (which changed from lcl3.0 +;;; -- 4.0 uses a list for the directory slot, whereas +;;; 3.0 required a string). Possible fix to symbolics bug. +;;; 30-JAN-91 mk Defined NEW-REQUIRE to make redefinition of REQUIRE +;;; cleaner. Replaced all calls to REQUIRE in this file with +;;; calls to NEW-REQUIRE, which should avoid compiler warnings. +;;; 30-JAN-91 mk In VAXLisp, when we redefine lisp:require, the compiler +;;; no longer automatically executes require forms when it +;;; encounters them in a file. The user can always wrap an +;;; (eval-when (compile load eval) ...) around the require +;;; form. Alternately, see commented out code near the +;;; redefinition of lisp:require which redefines it as a +;;; macro instead. +;;; 30-JAN-91 mk Added parameter :version to operate-on-system. If it is +;;; a number, that number is used as part of the binary +;;; directory name as the place to store and load files. +;;; If NIL (the default), uses regular binary directory. +;;; If T, tries to find the most recent version of the +;;; binary directory. +;;; 30-JAN-91 mk Added global variable *use-timeouts* (default: t), which +;;; specifies whether timeouts should be used in +;;; Y-OR-N-P-WAIT. This is provided for users whose lisps +;;; don't handle read-char-no-hang properly, so that they +;;; can set it to NIL to disable the timeouts. Usually the +;;; reason for this is the lisp is run on top of UNIX, +;;; which buffers input LINES (and provides input editing). +;;; To get around this we could always turn CBREAK mode +;;; on and off, but there's no way to do this in a portable +;;; manner. +;;; 30-JAN-91 mk Fixed bug where in :test t mode it was actually providing +;;; the system, instead of faking it. +;;; 30-JAN-91 mk Changed storage of system definitions to a hash table. +;;; Changed canonicalize-system-name to coerce the system +;;; names to uppercase strings. Since we're no longer using +;;; get, there's no need to intern the names as symbols, +;;; and strings don't have packages to cause problems. +;;; Added UNDEFSYSTEM, DEFINED-SYSTEMS, and DESCRIBE-SYSTEM. +;;; Added :delete-binaries command. +;;; 31-JAN-91 mk Franz Allegro CL has a defsystem in the USER package, +;;; so we need to do a shadowing import to avoid name +;;; conflicts. +;;; 31-JAN-91 mk Fixed bug in compile-and-load-operation where it was +;;; only loading newly compiled files. +;;; 31-JAN-91 mk Added :load-time slot to components to record the +;;; file-write-date of the binary/source file that was loaded. +;;; Now knows "when" (which date version) the file was loaded. +;;; Added keyword :minimal-load and global *minimal-load* +;;; to enable defsystem to avoid reloading unmodified files. +;;; Note that if B depends on A, but A is up to date and +;;; loaded and the user specified :minimal-load T, then A +;;; will not be loaded even if B needs to be compiled. So +;;; if A is an initializations file, say, then the user should +;;; not specify :minimal-load T. +;;; 31-JAN-91 mk Added :load-only slot to components. If this slot is +;;; specified as non-NIL, skips over any attempts to compile +;;; the files in the component. (Loading the file satisfies +;;; the need to recompile.) +;;; 31-JAN-91 mk Eliminated use of set-alist-lookup and alist-lookup, +;;; replacing it with hash tables. It was too much bother, +;;; and rather brittle too. +;;; 31-JAN-91 mk Defined #@ macro character for use with AFS @sys +;;; feature simulator. #@"directory" is then synonymous +;;; with (afs-binary-directory "directory"). +;;; 31-JAN-91 mk Added :private-file type of module. It is similar to +;;; :file, but has an absolute pathname. This allows you +;;; to specify a different version of a file in a system +;;; (e.g., if you're working on the file in your home +;;; directory) without completely rewriting the system +;;; definition. +;;; 31-JAN-91 mk Operations on systems, such as :compile and :load, +;;; now propagate to subsystems the system depends on +;;; if *operations-propagate-to-subsystems* is T (the default) +;;; and the systems were defined using either defsystem +;;; or as a :system component of another system. Thus if +;;; a system depends on another, it can now recompile the +;;; other. +;;; 01-FEB-91 mk Added default definitions of PROVIDE/REQUIRE/*MODULES* +;;; for lisps that have thrown away these definitions in +;;; accordance with CLtL2. +;;; 01-FEB-91 mk Added :compile-only slot to components. Analogous to +;;; :load-only. If :compile-only is T, will not load the +;;; file on operation :compile. Either compiles or loads +;;; the file, but not both. In other words, compiling the +;;; file satisfies the demand to load it. This is useful +;;; for PCL defmethod and defclass definitions, which wrap +;;; an (eval-when (compile load eval) ...) around the body +;;; of the definition -- we save time by not loading the +;;; compiled code, since the eval-when forces it to be +;;; loaded. Note that this may not be entirely safe, since +;;; CLtL2 has added a :load keyword to compile-file, and +;;; some lisps may maintain a separate environment for +;;; the compiler. This feature is for the person who asked +;;; that a :COMPILE-SATISFIES-LOAD keyword be added to +;;; modules. It's named :COMPILE-ONLY instead to match +;;; :LOAD-ONLY. +;;; 11-FEB-91 mk Now adds :mk-defsystem to features list, to allow +;;; special cased loading of defsystem if not already +;;; present. +;;; 19-FEB-91 duff Added filename extension for hp9000/300's running Lucid. +;;; 26-FEB-91 mk Distinguish between toplevel systems (defined with +;;; defsystem) and systems defined as a :system module +;;; of a defsystem. The former can depend only on systems, +;;; while the latter can depend on anything at the same +;;; level. +;;; 12-MAR-91 mk Added :subsystem component type to be a system with +;;; pathnames relative to its parent component. +;;; 12-MAR-91 mk Uncommented :device :absolute for CMU pathnames, so +;;; that the leading slash is included. +;;; 12-MAR-91 brad Patches for Allegro 4.0.1 on Sparc. +;;; 12-MAR-91 mk Changed definition of format-justified-string so that +;;; it no longer depends on the ~<~> format directives, +;;; because Allegro 4.0.1 has a bug which doesn't support +;;; them. Anyway, the new definition is twice as fast +;;; and conses half as much as FORMAT. +;;; 12-MAR-91 toni Remove nils from list in expand-component-components. +;;; 12-MAR-91 bw If the default-package and system have the same name, +;;; and the package is not loaded, this could lead to +;;; infinite loops, so we bomb out with an error. +;;; Fixed bug in default packages. +;;; 13-MAR-91 mk Added global *providing-blocks-load-propagation* to +;;; control whether system dependencies are loaded if they +;;; have already been provided. +;;; 13-MAR-91 brad In-package is a macro in CLtL2 lisps, so we change +;;; the package manually in operate-on-component. +;;; 15-MAR-91 mk Modified *central-registry* to be either a single +;;; directory pathname, or a list of directory pathnames +;;; to be checked in order. +;;; 15-MAR-91 rs Added afs-source-directory to handle versions when +;;; compiling C code under lisp. Other minor changes to +;;; translate-version and operate-on-system. +;;; 21-MAR-91 gi Fixed bug in defined-systems. +;;; 22-MAR-91 mk Replaced append-directories with new version that works +;;; by actually appending the directories, after massaging +;;; them into the proper format. This should work for all +;;; CLtL2-compliant lisps. +;;; 09-APR-91 djc Missing package prefix for lp:pathname-host-type. +;;; Modified component-full-pathname to work for logical +;;; pathnames. +;;; 09-APR-91 mk Added *dont-redefine-require* to control whether +;;; REQUIRE is redefined. Fixed minor bugs in redefinition +;;; of require. +;;; 12-APR-91 mk (pathname-host nil) causes an error in MCL 2.0b1 +;;; 12-APR-91 mc Ported to MCL2.0b1. +;;; 16-APR-91 mk Fixed bug in needs-loading where load-time and +;;; file-write-date got swapped. +;;; 16-APR-91 mk If the component is load-only, defsystem shouldn't +;;; tell you that there is no binary and ask you if you +;;; want to load the source. +;;; 17-APR-91 mc Two additional operations for MCL. +;;; 21-APR-91 mk Added feature requested by ik. *files-missing-is-an-error* +;;; new global variable which controls whether files (source +;;; and binary) missing cause a continuable error or just a +;;; warning. +;;; 21-APR-91 mk Modified load-file-operation to allow compilation of source +;;; files during load if the binary files are old or +;;; non-existent. This adds a :compile-during-load keyword to +;;; oos, and load-system. Global *compile-during-load* sets +;;; the default (currently :query). +;;; 21-APR-91 mk Modified find-system so that there is a preference for +;;; loading system files from disk, even if the system is +;;; already defined in the environment. +;;; 25-APR-91 mk Removed load-time slot from component defstruct and added +;;; function COMPONENT-LOAD-TIME to store the load times in a +;;; hash table. This is safer than the old definition because +;;; it doesn't wipe out load times every time the system is +;;; redefined. +;;; 25-APR-91 mk Completely rewrote load-file-operation. Fixed some bugs +;;; in :compile-during-load and in the behavior of defsystem +;;; when multiple users are compiling and loading a system +;;; instead of just a single user. +;;; 16-MAY-91 mk Modified FIND-SYSTEM to do the right thing if the system +;;; definition file cannot be found. +;;; 16-MAY-91 mk Added globals *source-pathname-default* and +;;; *binary-pathname-default* to contain default values for +;;; :source-pathname and :binary-pathname. For example, set +;;; *source-pathname-default* to "" to avoid having to type +;;; :source-pathname "" all the time. +;;; 27-MAY-91 mk Fixed bug in new-append-directories where directory +;;; components of the form "foo4.0" would appear as "foo4", +;;; since pathname-name truncates the type. Changed +;;; pathname-name to file-namestring. +;;; 3-JUN-91 gc Small bug in new-append-directories; replace (when +;;; abs-name) with (when (not (null-string abs-name))) +;;; 4-JUN-91 mk Additional small change to new-append-directories for +;;; getting the device from the relative pname if the abs +;;; pname is "". This is to fix a small behavior in CMU CL old +;;; compiler. Also changed (when (not (null-string abs-name))) +;;; to have an (and abs-name) in there. +;;; 8-JAN-92 sb Added filename extension for defsystem under Lucid Common +;;; Lisp/SGO 3.0.1+. +;;; 8-JAN-92 mk Changed the definition of prompt-string to work around an +;;; AKCL bug. Essentially, AKCL doesn't default the colinc to +;;; 1 if the colnum is provided, so we hard code it. +;;; 8-JAN-92 rs (pathname-directory (pathname "")) returns '(:relative) in +;;; Lucid, instead of NIL. Changed new-append-directories and +;;; test-new-append-directories to reflect this. +;;; 8-JAN-92 mk Fixed problem related to *load-source-if-no-binary*. +;;; compile-and-load-source-if-no-binary wasn't checking for +;;; the existence of the binary if this variable was true, +;;; causing the file to not be compiled. +;;; 8-JAN-92 mk Fixed problem with null-string being called on a pathname +;;; by returning NIL if the argument isn't a string. +;;; 3-NOV-93 mk In Allegro 4.2, pathname device is :unspecific by default. +;;; 11-NOV-93 fdmm Fixed package definition lock problem when redefining +;;; REQUIRE on ACL. +;;; 11-NOV-93 fdmm Added machine and software types for SGI and IRIX. It is +;;; important to distinguish the OS version and CPU type in +;;; SGI+ACL, since ACL 4.1 on IRIX 4.x and ACL 4.2 on IRIX 5.x +;;; have incompatible .fasl files. +;;; 01-APR-94 fdmm Fixed warning problem when redefining REQUIRE on LispWorks. +;;; 01-NOV-94 fdmm Replaced (software-type) call in ACL by code extracting +;;; the interesting parts from (software-version) [deleted +;;; machine name and id]. +;;; 03-NOV-94 fdmm Added a hook (*compile-file-function*), that is funcalled +;;; by compile-file-operation, so as to support other languages +;;; running on top of Common Lisp. +;;; The default is to compile Common Lisp. +;;; 03-NOV-94 fdmm Added SCHEME-COMPILE-FILE, so that defsystem can now +;;; compile Pseudoscheme files. +;;; 04-NOV-94 fdmm Added the exported generic function SET-LANGUAGE, to +;;; have a clean, easy to extend interface for telling +;;; defsystem which language to assume for compilation. +;;; Currently supported arguments: :common-lisp, :scheme. +;;; 11-NOV-94 kc Ported to Allegro CL for Windows 2.0 (ACLPC) and CLISP. +;;; 18-NOV-94 fdmm Changed the entry *filename-extensions* for LispWorks +;;; to support any platform. +;;; Added entries for :mcl and :clisp too. +;;; 16-DEC-94 fdmm Added and entry for CMU CL on SGI to *filename-extensions*. +;;; 16-DEC-94 fdmm Added OS version identification for CMU CL on SGI. +;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed make-pathnames call fix +;;; in NEW-APPEND-DIRECTORIES. +;;; 16-DEC-94 fdmm Added HOME-SUBDIRECTORY to fix CMU's ignorance about `~' +;;; when specifying registries. +;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed :device fix in make-pathnames call +;;; in COMPONENT-FULL-PATHNAME. This fix was also reported +;;; by kc on 12-NOV-94. CMU CL 17 now supports CLtL2 pathnames. +;;; 16-DEC-94 fdmm Removed a quote before the call to read in the readmacro +;;; #@. This fixes a really annoying misfeature (couldn't do +;;; #@(concatenate 'string "foo/" "bar"), for example). +;;; 03-JAN-95 fdmm Do not include :pcl in *features* if :clos is there. +;;; 2-MAR-95 mk Modified fdmm's *central-registry* change to use +;;; user-homedir-pathname and to be a bit more generic in the +;;; pathnames. +;;; 2-MAR-95 mk Modified fdmm's updates to *filename-extensions* to handle +;;; any CMU CL binary extensions. +;;; 2-MAR-95 mk Make kc's port to ACLPC a little more generic. +;;; 2-MAR-95 mk djc reported a bug, in which GET-SYSTEM was not returning +;;; a system despite the system's just having been loaded. +;;; The system name specified in the :depends-on was a +;;; lowercase string. I am assuming that the system name +;;; in the defsystem form was a symbol (I haven't verified +;;; that this was the case with djc, but it is the only +;;; reasonable conclusion). So, CANONICALIZE-SYSTEM-NAME +;;; was storing the system in the hash table as an +;;; uppercase string, but attempting to retrieve it as a +;;; lowercase string. This behavior actually isn't a bug, +;;; but a user error. It was intended as a feature to +;;; allow users to use strings for system names when +;;; they wanted to distinguish between two different systems +;;; named "foo.system" and "Foo.system". However, this +;;; user error indicates that this was a bad design decision. +;;; Accordingly, CANONICALIZE-SYSTEM-NAME now uppercases +;;; even strings for retrieving systems, and the comparison +;;; in *modules* is now case-insensitive. The result of +;;; this change is if the user cannot have distinct +;;; systems in "Foo.system" and "foo.system" named "Foo" and +;;; "foo", because they will clobber each other. There is +;;; still case-sensitivity on the filenames (i.e., if the +;;; system file is named "Foo.system" and you use "foo" in +;;; the :depends-on, it won't find it). We didn't take the +;;; further step of requiring system filenames to be lowercase +;;; because we actually find this kind of case-sensitivity +;;; to be useful, when maintaining two different versions +;;; of the same system. +;;; 7-MAR-95 mk Added simplistic handling of logical pathnames. Also +;;; modified new-append-directories so that it'll try to +;;; split up pathname directories that are strings into a +;;; list of the directory components. Such directories aren't +;;; ANSI CL, but some non-conforming implementations do it. +;;; 7-MAR-95 mk Added :proclamations to defsystem form, which can be used +;;; to set the compiler optimization level before compilation. +;;; For example, +;;; :proclamations '(optimize (safety 3) (speed 3) (space 0)) +;;; 7-MAR-95 mk Defsystem now tells the user when it reloads the system +;;; definition. +;;; 7-MAR-95 mk Fixed problem pointed out by yc. If +;;; *source-pathname-default* is "" and there is no explicit +;;; :source-pathname specified for a file, the file could +;;; wind up with an empty file name. In other words, this +;;; global default shouldn't apply to :file components. Added +;;; explicit test for null strings, and when present replaced +;;; them with NIL (for binary as well as source, and also for +;;; :private-file components). +;;; 7-MAR-95 tar Fixed defsystem to work on TI Explorers (TI CL). +;;; 7-MAR-95 jk Added machine-type-translation for Decstation 5000/200 +;;; under Allegro 3.1 +;;; 7-MAR-95 as Fixed bug in AKCL-1-615 in which defsystem added a +;;; subdirectory "RELATIVE" to all filenames. +;;; 7-MAR-95 mk Added new test to test-new-append-directories to catch the +;;; error fixed by as. Essentially, this error occurs when the +;;; absolute-pathname has no directory (i.e., it has a single +;;; pathname component as in "foo" and not "foo/bar"). If +;;; RELATIVE ever shows up in the Result, we now know to +;;; add an extra conditionalization to prevent abs-keyword +;;; from being set to :relative. +;;; 7-MAR-95 ss Miscellaneous fixes for MCL 2.0 final. +;;; *compile-file-verbose* not in MCL, *version variables +;;; need to occur before AFS-SOURCE-DIRECTORY definition, +;;; and certain code needed to be in the CCL: package. +;;; 8-MAR-95 mk Y-OR-N-P-WAIT uses a busy-waiting. On Lisp systems where +;;; the time functions cons, such as CMU CL, this can cause a +;;; lot of ugly garbage collection messages. Modified the +;;; waiting to include calls to SLEEP, which should reduce +;;; some of the consing. +;;; 8-MAR-95 mk Replaced fdmm's SET-LANGUAGE enhancement with a more +;;; general extension, along the lines suggested by akd. +;;; Defsystem now allows components to specify a :language +;;; slot, such as :language :lisp, :language :scheme. This +;;; slot is inherited (with the default being :lisp), and is +;;; used to obtain compilation and loading functions for +;;; components, as well as source and binary extensions. The +;;; compilation and loading functions can be overridden by +;;; specifying a :compiler or :loader in the system +;;; definition. Also added :documentation slot to the system +;;; definition. +;;; Where this comes in real handy is if one has a +;;; compiler-compiler implemented in Lisp, and wants the +;;; system to use the compiler-compiler to create a parser +;;; from a grammar and then compile parser. To do this one +;;; would create a module with components that looked +;;; something like this: +;;; ((:module cc :components ("compiler-compiler")) +;;; (:module gr :compiler 'cc :loader #'ignore +;;; :source-extension "gra" +;;; :binary-extension "lisp" +;;; :depends-on (cc) +;;; :components ("sample-grammar")) +;;; (:module parser :depends-on (gr) +;;; :components ("sample-grammar"))) +;;; Defsystem would then compile and load the compiler, use +;;; it (the function cc) to compile the grammar into a parser, +;;; and then compile the parser. The only tricky part is +;;; cc is defined by the system, and one can't include #'cc +;;; in the system definition. However, one could include +;;; a call to mk:define-language in the compiler-compiler file, +;;; and define :cc as a language. This is the prefered method. +;;; 8-MAR-95 mk New definition of topological-sort suggested by rs2. This +;;; version avoids the call to SORT, but in practice isn't +;;; much faster. However, it avoids the need to maintain a +;;; TIME slot in the topsort-node structure. +;;; 8-MAR-95 mk rs2 also pointed out that the calls to MAKE-PATHNAME and +;;; NAMESTRING in COMPONENT-FULL-PATHNAME are a major reason +;;; why defsystem is slow. Accordingly, I've changed +;;; COMPONENT-FULL-PATHNAME to include a call to NAMESTRING +;;; (and removed all other calls to NAMESTRING), and also made +;;; a few changes to minimize the number of calls to +;;; COMPONENT-FULL-PATHNAME, such as memoizing it. See To Do +;;; below for other related comments. +;;; 8-MAR-95 mk Added special hack requested by Steve Strassman, which +;;; allows one to specify absolute pathnames in the shorthand +;;; for a list of components, and have defsystem recognize +;;; which are absolute and which are relative. +;;; I actually think this would be a good idea, but I haven't +;;; tested it, so it is disabled by default. Search for +;;; *enable-straz-absolute-string-hack* to enable it. +;;; 8-MAR-95 kt Fixed problem with EXPORT in AKCL 1.603, in which it wasn't +;;; properly exporting the value of the global export +;;; variables. +;;; 8-MAR-95 mk Added UNMUNGE-LUCID to fix nasty problem with COMPILE-FILE +;;; in Lucid. Lucid apparently tries to merge the :output-file +;;; with the source file when the :output-file is a relative +;;; pathname. Wierd, and definitely non-standard. +;;; 9-MAR-95 mk Changed ALLEGRO-MAKE-SYSTEM-FASL to also include the files +;;; in any systems the system depends on, as per a +;;; request of oc. +;;; 9-MAR-95 mk Some version of CMU CL couldn't hack a call to +;;; MAKE-PATHNAME with :host NIL. I'm not sure which version +;;; it is, but the current version doesn't have this problem. +;;; If given :host nil, it defaults the host to +;;; COMMON-LISP::*UNIX-HOST*. So I haven't "fixed" this +;;; problem. +;;; 9-MAR-95 mk Integrated top-level commands for Allegro designed by bha +;;; into the code, with slight modifications. +;;; 9-MAR-95 mk Instead of having COMPUTE-SYSTEM-PATH check the current +;;; directory in a hard-coded fashion, include the current +;;; directory in the *central-registry*, as suggested by +;;; bha and others. +;;; 9-MAR-95 bha Support for Logical Pathnames in Allegro. +;;; 9-MAR-95 mk Added modified version of bha's DEFSYSPATH idea. +;;; 13-MAR-95 mk Added a macro for the simple serial case, where a system +;;; (or module) is simple a list of files, each of which +;;; depends on the previous one. If the value of :components +;;; is a list beginning with :serial, it expands each +;;; component and makes it depend on the previous component. +;;; For example, (:serial "foo" "bar" "baz") would create a +;;; set of components where "baz" depended on "bar" and "bar" +;;; on "foo". +;;; 13-MAR-95 mk *** Now version 3.0. This version is a interim bug-fix and +;;; update, since I do not have the time right now to complete +;;; the complete overhaul and redesign. +;;; Major changes in 3.0 include CMU CL 17, CLISP, ACLPC, TI, +;;; LispWorks and ACL(SGI) support, bug fixes for ACL 4.1/4.2. +;;; 14-MAR-95 fdmm Finally added the bit of code to discriminate cleanly +;;; among different lisps without relying on (software-version) +;;; idiosyncracies. +;;; You can now customize COMPILER-TYPE-TRANSLATION so that +;;; AFS-BINARY-DIRECTORY can return a different value for +;;; different lisps on the same platform. +;;; If you use only one compiler, do not care about supporting +;;; code for multiple versions of it, and want less verbose +;;; directory names, just set *MULTIPLE-LISP-SUPPORT* to nil. +;;; 17-MAR-95 lmh Added EVAL-WHEN for one of the MAKE-PACKAGE calls. +;;; CMU CL's RUN-PROGRAM is in the extensions package. +;;; ABSOLUTE-FILE-NAMESTRING-P was missing :test keyword +;;; Rearranged conditionalization in DIRECTORY-TO-LIST to +;;; suppress compiler warnings in CMU CL. +;;; 17-MAR-95 mk Added conditionalizations to avoid certain CMU CL compiler +;;; warnings reported by lmh. +;;; 19990610 ma Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed. + +;;; 19991211 ma NEW VERSION 4.0 started. +;;; 19991211 ma Merged in changes requested by T. Russ of +;;; ISI. Please refer to the special "ISI" comments to +;;; understand these changes +;;; 20000228 ma The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM, +;;; COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer +;;; imported in the COMMON-LISP-USER package. +;;; Cfr. the definitions of *EXPORTS* and +;;; *SPECIAL-EXPORTS*. +;;; 2000-07-21 rlt Add COMPILER-OPTIONS to defstruct to allow user to +;;; specify special compiler options for a particular +;;; component. +;;; 2002-01-08 kmr Changed allegro symbols to lowercase to support +;;; case-sensitive images + +;;;--------------------------------------------------------------------------- +;;; ISI Comments +;;; +;;; 19991211 Marco Antoniotti +;;; These comments come from the "ISI Branch". I believe I did +;;; include the :load-always extension correctly. The other commets +;;; seem superseded by other changes made to the system in the +;;; following years. Some others are now useless with newer systems +;;; (e.g. filename truncation for new Windows based CL +;;; implementations.) + +;;; 1-OCT-92 tar Fixed problem with TI Lisp machines and append-directory. +;;; 1-OCT-92 tar Made major modifications to compile-file-operation and +;;; load-file-operation to reduce the number of probe-file +;;; and write-date inquiries. This makes the system run much +;;; faster through slow network connections. +;;; 13-OCT-92 tar Added :load-always slot to components. If this slot is +;;; specified as non-NIL, always loads the component. +;;; This does not trigger dependent compilation. +;;; (This can be useful when macro definitions needed +;;; during compilation are changed by later files. In +;;; this case, not reloading up-to-date files can +;;; cause different results.) +;;; 28-OCT-93 tar Allegro 4.2 causes an error on (pathname-device nil) +;;; 14-SEP-94 tar Disable importing of symbols into (CL-)USER package +;;; to minimize conflicts with other defsystem utilities. +;;; 10-NOV-94 tar Added filename truncation code to support Franz Allegro +;;; PC with it's 8 character filename limitation. +;;; 15-MAY-98 tar Changed host attribute for pathnames to support LispWorks +;;; (Windows) pathnames which reference other Drives. Also +;;; updated file name convention. +;;; 9-NOV-98 tar Updated new-append-directories for Lucid 5.0 +;;; + + + +;;; ******************************** +;;; Ports ************************** +;;; ******************************** +;;; +;;; DEFSYSTEM has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach) +;;; CMU Common Lisp 17f (Python 1.0) +;;; Franz Allegro Common Lisp 3.1.12 (ExCL 3/30/90) +;;; Franz Allegro Common Lisp 4.0/4.1/4.2 +;;; Franz Allegro Common Lisp for Windows (2.0) +;;; Lucid Common Lisp (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0 [SPARC,SUN3]) +;;; Lucid Common Lisp (4.0 [SPARC,SUN3]) +;;; VAXLisp (v2.2) [VAX/VMS] +;;; VAXLisp (v3.1) +;;; Harlequin LispWorks +;;; CLISP (CLISP3 [SPARC]) +;;; Symbolics XL12000 (Genera 8.3) +;;; Scieneer Common Lisp (SCL) 1.1 +;;; Macintosh Common Lisp +;;; ECL +;;; +;;; DEFSYSTEM needs to be tested in the following lisps: +;;; OpenMCL +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; COMPONENT-FULL-PATHNAME is a major source of slowness in the system +;;; because of all the calls to the expensive operations MAKE-PATHNAME +;;; and NAMESTRING. To improve performance, DEFSYSTEM should be reworked +;;; to avoid any need to call MAKE-PATHNAME and NAMESTRING, as the logical +;;; pathnames package does. Unfortunately, I don't have the time to do this +;;; right now. Instead, I installed a temporary improvement by memoizing +;;; COMPONENT-FULL-PATHNAME to cache previous calls to the function on +;;; a component by component and type by type basis. The cache is +;;; cleared before each call to OOS, in case filename extensions change. +;;; But DEFSYSTEM should really be reworked to avoid this problem and +;;; ensure greater portability and to also handle logical pathnames. +;;; +;;; Also, PROBE-FILE and FILE-WRITE-DATE are other sources of slowness. +;;; Perhaps by also memoizing FILE-WRITE-DATE and reimplementing PROBE-FILE +;;; in terms of FILE-WRITE-DATE, can achieve a further speed-up. This was +;;; suggested by Steven Feist (feist@ils.nwu.edu). +;;; +;;; True CLtL2 logical pathnames support -- can't do it, because CLtL2 +;;; doesn't have all the necessary primitives, and even in Allegro CL 4.2 +;;; (namestring #l"foo:bar;baz.lisp") +;;; does not work properly. +;;; +;;; Create separate stand-alone documentation for defsystem, and also +;;; a test suite. +;;; +;;; Change SYSTEM to be a class instead of a struct, and make it a little +;;; more generic, so that it permits alternate system definitions. +;;; Replace OPERATE-ON-SYSTEM with MAP-SYSTEM (args: function, system-name, +;;; &rest options) +;;; +;;; Add a patch directory mechanism. Perhaps have several directories +;;; with code in them, and the first one with the specified file wins? +;;; LOAD-PATCHES function. +;;; +;;; Need way to load old binaries even if source is newer. +;;; +;;; Allow defpackage forms/package definitions in the defsystem? If +;;; a package not defined, look for and load a file named package.pkg? +;;; +;;; need to port for GNU CL (ala kcl)? +;;; +;;; Someone asked whether one can have :file components at top-level. I believe +;;; this is the case, but should double-check that it is possible (and if +;;; not, make it so). +;;; +;;; A common error/misconception seems to involve assuming that :system +;;; components should include the name of the system file, and that +;;; defsystem will automatically load the file containing the system +;;; definition and propagate operations to it. Perhaps this would be a +;;; nice feature to add. +;;; +;;; If a module is :load-only t, then it should not execute its :finally-do +;;; and :initially-do clauses during compilation operations, unless the +;;; module's files happen to be loaded during the operation. +;;; +;;; System Class. Customizable delimiters. +;;; +;;; Load a system (while not loading anything already loaded) +;;; and inform the user of out of date fasls with the choice +;;; to load the old fasl or recompile and then load the new +;;; fasl? +;;; +;;; modify compile-file-operation to handle a query keyword.... +;;; +;;; Perhaps systems should keep around the file-write-date of the system +;;; definition file, to prevent excessive reloading of the system definition? +;;; +;;; load-file-operation needs to be completely reworked to simplify the +;;; logic of when files get loaded or not. +;;; +;;; Need to revamp output: Nesting and indenting verbose output doesn't +;;; seem cool, especially when output overflows the 80-column margins. +;;; +;;; Document various ways of writing a system. simple (short) form +;;; (where :components is just a list of filenames) in addition to verbose. +;;; Put documentation strings in code. +;;; +;;; :load-time for modules and systems -- maybe record the time the system +;;; was loaded/compiled here and print it in describe-system? +;;; +;;; Make it easy to define new functions that operate on a system. For +;;; example, a function that prints out a list of files that have changed, +;;; hardcopy-system, edit-system, etc. +;;; +;;; If a user wants to have identical systems for different lisps, do we +;;; force the user to use logical pathnames? Or maybe we should write a +;;; generic-pathnames package that parses any pathname format into a +;;; uniform underlying format (i.e., pull the relevant code out of +;;; logical-pathnames.lisp and clean it up a bit). +;;; +;;; Verify that Mac pathnames now work with append-directories. +;;; +;;; A common human error is to violate the modularization by making a file +;;; in one module depend on a file in another module, instead of making +;;; one module depend on the other. This is caught because the dependency +;;; isn't found. However, is there any way to provide a more informative +;;; error message? Probably not, especially if the system has multiple +;;; files of the same name. +;;; +;;; For a module none of whose files needed to be compiled, have it print out +;;; "no files need recompilation". +;;; +;;; Write a system date/time to a file? (version information) I.e., if the +;;; filesystem supports file version numbers, write an auxiliary file to +;;; the system definition file that specifies versions of the system and +;;; the version numbers of the associated files. +;;; +;;; Add idea of a patch directory. +;;; +;;; In verbose printout, have it log a date/time at start and end of +;;; compilation: +;;; Compiling system "test" on 31-Jan-91 21:46:47 +;;; by Defsystem version v2.0 01-FEB-91. +;;; +;;; Define other :force options: +;;; :query allows user to specify that a file not normally compiled +;;; should be. OR +;;; :confirm allows user to specify that a file normally compiled +;;; shouldn't be. AND +;;; +;;; We currently assume that compilation-load dependencies and if-changed +;;; dependencies are identical. However, in some cases this might not be +;;; true. For example, if we change a macro we have to recompile functions +;;; that depend on it (except in lisps that automatically do this, such +;;; as the new CMU Common Lisp), but not if we change a function. Splitting +;;; these apart (with appropriate defaulting) would be nice, but not worth +;;; doing immediately since it may save only a couple of file recompilations, +;;; while making defsystem much more complex than it already is. +;;; +;;; Current dependencies are limited to siblings. Maybe we should allow +;;; nephews and uncles? So long as it is still a DAG, we can sort it. +;;; Answer: No. The current setup enforces a structure on the modularity. +;;; Otherwise, why should we have modules if we're going to ignore it? +;;; +;;; Currently a file is recompiled more or less if the source is newer +;;; than the binary or if the file depends on a file that has changed +;;; (i.e., was recompiled in this session of a system operation). +;;; Neil Goldman has pointed out that whether a file +;;; needs recompilation is really independent of the current session of +;;; a system operation, and depends only on the file-write-dates of the +;;; source and binary files for a system. Thus a file should require +;;; recompilation in the following circumstances: +;;; 1. If a file's source is newer than its binary, or +;;; 2. If a file's source is not newer than its binary, but the file +;;; depends directly or indirectly on a module (or file) that is newer. +;;; For a regular file use the file-write-date (FWD) of the source or +;;; binary, whichever is more recent. For a load-only file, use the only +;;; available FWD. For a module, use the most recent (max) FWD of any of +;;; its components. +;;; The impact of this is that instead of using a boolean CHANGED variable +;;; throughout the code, we need to allow CHANGED to be NIL/T/ or +;;; maybe just the FWD timestamp, and to use the value of CHANGED in +;;; needs-compilation decisions. (Use of NIL/T as values is an optimization. +;;; The FWD timestamp which indicates the most recent time of any changes +;;; should be sufficient.) This will affect not just the +;;; compile-file-operation, but also the load-file-operation because of +;;; compilation during load. Also, since FWDs will be used more prevalently, +;;; we probably should couple this change with the inclusion of load-times +;;; in the component defstruct. This is a tricky and involved change, and +;;; requires more thought, since there are subtle cases where it might not +;;; be correct. For now, the change will have to wait until the DEFSYSTEM +;;; redesign. + + +;;; ******************************************************************** +;;; How to Use this System ********************************************* +;;; ******************************************************************** + +;;; To use this system, +;;; 1. If you want to have a central registry of system definitions, +;;; modify the value of the variable *central-registry* below. +;;; 2. Load this file (defsystem.lisp) in either source or compiled form, +;;; 3. Load the file containing the "defsystem" definition of your system, +;;; 4. Use the function "operate-on-system" to do things to your system. + +;;; For more information, see the documentation and examples in +;;; lisp-utilities.ps. + +;;; ******************************** +;;; Usage Comments ***************** +;;; ******************************** + +;;; If you use symbols in the system definition file, they get interned in +;;; the COMMON-LISP-USER package, which can lead to name conflicts when +;;; the system itself seeks to export the same symbol to the COMMON-LISP-USER +;;; package. The workaround is to use strings instead of symbols for the +;;; names of components in the system definition file. In the major overhaul, +;;; perhaps the user should be precluded from using symbols for such +;;; identifiers. +;;; +;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp", +;;; file name expansion is much slower than if you use the full pathname, +;;; as in "/user/USERID/lisp". +;;; + + +;;; **************************************************************** +;;; Lisp Code ****************************************************** +;;; **************************************************************** + +;;; ******************************** +;;; Massage CLtL2 onto *features* ** +;;; ******************************** +;;; Let's be smart about CLtL2 compatible Lisps: +(eval-when (compile load eval) + #+(or (and allegro-version>= (version>= 4 0)) :mcl :openmcl :sbcl) + (pushnew :cltl2 *features*)) + +;;; ******************************** +;;; Provide/Require/*modules* ****** +;;; ******************************** + +;;; Since CLtL2 has dropped require and provide from the language, some +;;; lisps may not have the functions PROVIDE and REQUIRE and the +;;; global *MODULES*. So if lisp::provide and user::provide are not +;;; defined, we define our own. + +;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions +;;; and variables not being declared or bound, apparently because it +;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns +;;; T, so it doesn't really bother when compiling the body of the unless. +;;; The new compiler does this properly, so I'm not going to bother +;;; working around this. + +;;; Some Lisp implementations return bogus warnings about assuming +;;; *MODULE-FILES* and *LIBRARY* to be special, and CANONICALIZE-MODULE-NAME +;;; and MODULE-FILES being undefined. Don't worry about them. + +;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code +;;; necessary? + +#-(or :CMU + :vms + :mcl + :openmcl + :lispworks + :clisp + :gcl + :sbcl + :cormanlisp + :scl + (and allegro-version>= (version>= 4 1))) +(eval-when #-(or :lucid) + (:compile-toplevel :load-toplevel :execute) + #+(or :lucid) + (compile load eval) + + (unless (or (fboundp 'lisp::require) + (fboundp 'user::require) + + #+(and :excl (and allegro-version>= (version>= 4 0))) + (fboundp 'cltl1::require) + + #+:lispworks + (fboundp 'system::require)) + + #-:lispworks + (in-package "LISP") + #+:lispworks + (in-package "SYSTEM") + + (export '(*modules* provide require)) + + ;; Documentation strings taken almost literally from CLtL1. + + (defvar *modules* () + "List of names of the modules that have been loaded into Lisp so far. + It is used by PROVIDE and REQUIRE.") + + ;; We provide two different ways to define modules. The default way + ;; is to put either a source or binary file with the same name + ;; as the module in the library directory. The other way is to define + ;; the list of files in the module with defmodule. + + ;; The directory listed in *library* is implementation dependent, + ;; and is intended to be used by Lisp manufacturers as a place to + ;; store their implementation dependent packages. + ;; Lisp users should use systems and *central-registry* to store + ;; their packages -- it is intended that *central-registry* is + ;; set by the user, while *library* is set by the lisp. + + (defvar *library* nil ; "/usr/local/lisp/Modules/" + "Directory within the file system containing files, where the name + of a file is the same as the name of the module it contains.") + + (defvar *module-files* (make-hash-table :test #'equal) + "Hash table mapping from module names to list of files for the + module. REQUIRE loads these files in order.") + + (defun canonicalize-module-name (name) + ;; if symbol, string-downcase the printrep to make nicer filenames. + (if (stringp name) name (string-downcase (string name)))) + + (defmacro defmodule (name &rest files) + "Defines a module NAME to load the specified FILES in order." + `(setf (gethash (canonicalize-module-name ,name) *module-files*) + ',files)) + (defun module-files (name) + (gethash name *module-files*)) + + (defun provide (name) + "Adds a new module name to the list of modules maintained in the + variable *modules*, thereby indicating that the module has been + loaded. Name may be a string or symbol -- strings are case-senstive, + while symbols are treated like lowercase strings. Returns T if + NAME was not already present, NIL otherwise." + (let ((module (canonicalize-module-name name))) + (unless (find module *modules* :test #'string=) + ;; Module not present. Add it and return T to signify that it + ;; was added. + (push module *modules*) + t))) + + (defun require (name &optional pathname) + "Tests whether a module is already present. If the module is not + present, loads the appropriate file or set of files. The pathname + argument, if present, is a single pathname or list of pathnames + whose files are to be loaded in order, left to right. If the + pathname is nil, the system first checks if a module was defined + using defmodule and uses the pathnames so defined. If that fails, + it looks in the library directory for a file with name the same + as that of the module. Returns T if it loads the module." + (let ((module (canonicalize-module-name name))) + (unless (find module *modules* :test #'string=) + ;; Module is not already present. + (when (and pathname (not (listp pathname))) + ;; If there's a pathname or pathnames, ensure that it's a list. + (setf pathname (list pathname))) + (unless pathname + ;; If there's no pathname, try for a defmodule definition. + (setf pathname (module-files module))) + (unless pathname + ;; If there's still no pathname, try the library directory. + (when *library* + (setf pathname (concatenate 'string *library* module)) + ;; Test if the file exists. + ;; We assume that the lisp will default the file type + ;; appropriately. If it doesn't, use #+".fasl" or some + ;; such in the concatenate form above. + (if (probe-file pathname) + ;; If it exists, ensure we've got a list + (setf pathname (list pathname)) + ;; If the library file doesn't exist, we don't want + ;; a load error. + (setf pathname nil)))) + ;; Now that we've got the list of pathnames, let's load them. + (dolist (pname pathname t) + (load pname :verbose nil)))))) + ) ; eval-when + +;;; ******************************** +;;; Set up Package ***************** +;;; ******************************** + + +;;; Unfortunately, lots of lisps have their own defsystems, some more +;;; primitive than others, all uncompatible, and all in the DEFSYSTEM +;;; package. To avoid name conflicts, we've decided to name this the +;;; MAKE package. A nice side-effect is that the short nickname +;;; MK is my initials. + +#+(or clisp cormanlisp ecl (and gcl defpackage) sbcl) +(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK")) + +#-(or :sbcl :cltl2 :lispworks :ecl :scl) +(in-package "MAKE" :nicknames '("MK")) + +;;; For CLtL2 compatible lisps... +#+(and :excl :allegro-v4.0 :cltl2) +(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) + (:import-from cltl1 *modules* provide require)) + +;;; *** Marco Antoniotti 19970105 +;;; In Allegro 4.1, 'provide' and 'require' are not external in +;;; 'CLTL1'. However they are in 'COMMON-LISP'. Hence the change. +#+(and :excl :allegro-v4.1 :cltl2) +(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) ) + +#+(and :excl :allegro-version>= (version>= 4 2)) +(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)) + +#+:lispworks +(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") + (:import-from system *modules* provide require) + (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM" + "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*")) + +#+:mcl +(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") + (:import-from ccl *modules* provide require)) + +;;; *** Marco Antoniotti 19951012 +;;; The code below, is originally executed also for CMUCL. However I +;;; believe this is wrong, since CMUCL comes with its own defpackage. +;;; I added the extra :CMU in the 'or'. +#+(and :cltl2 (not (or :cmu :clisp :sbcl + (and :excl (or :allegro-v4.0 :allegro-v4.1)) + :mcl))) +(eval-when (compile load eval) + (unless (find-package "MAKE") + (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP")))) + +;;; *** Marco Antoniotti 19951012 +;;; Here I add the proper defpackage for CMU +#+:CMU +(defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS") + (:nicknames "MK")) + +#+:sbcl +(defpackage "MAKE" (:use "COMMON-LISP") + (:nicknames "MK")) + +#+:scl +(defpackage :make (:use :common-lisp) + (:nicknames :mk)) + +#+(or :cltl2 :lispworks :scl) +(eval-when (compile load eval) + (in-package "MAKE")) + +#+ecl +(in-package "MAKE") + +;;; *** Marco Antoniotti 19970105 +;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1 +#+(and :excl :allegro-v4.0 :cltl2) +(cltl1:provide 'make) +#+(and :excl :allegro-v4.0 :cltl2) +(provide 'make) + +#+:openmcl +(cl:provide 'make) + +#+(and :mcl (not :openmcl)) +(ccl:provide 'make) + +#+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl))) +(provide 'make) + +#+:lispworks +(provide 'make) + +#-(or :cltl2 :lispworks) +(provide 'make) + +(pushnew :mk-defsystem *features*) + +;;; Some compatibility issues. Mostly for CormanLisp. +;;; 2002-02-20 Marco Antoniotti + +#+cormanlisp +(defun compile-file-pathname (pathname-designator) + (merge-pathnames (make-pathname :type "fasl") + (etypecase pathname-designator + (pathname pathname-designator) + (string (parse-namestring pathname-designator)) + ;; We need FILE-STREAM here as well. + ))) + +#+cormanlisp +(defun file-namestring (pathname-designator) + (let ((p (etypecase pathname-designator + (pathname pathname-designator) + (string (parse-namestring pathname-designator)) + ;; We need FILE-STREAM here as well. + ))) + (namestring (make-pathname :directory () + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p))))) + +;;; The external interface consists of *exports* and *other-exports*. + +;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in +;;; the compile form, so that you can't use a defvar with a default value and +;;; then a succeeding export as well. + +(eval-when (compile load eval) + (defvar *special-exports* nil) + (defvar *exports* nil) + (defvar *other-exports* nil) + + (export (setq *exports* + '(operate-on-system + oos + afs-binary-directory afs-source-directory + files-in-system))) + (export (setq *special-exports* + '())) + (export (setq *other-exports* + '(*central-registry* + *bin-subdir* + + add-registry-location + find-system + defsystem compile-system load-system hardcopy-system + + system-definition-pathname + + missing-component + missing-component-name + missing-component-component + missing-module + missing-system + + register-foreign-system + + machine-type-translation + software-type-translation + compiler-type-translation + ;; require + define-language + allegro-make-system-fasl + files-which-need-compilation + undefsystem + defined-systems + describe-system clean-system edit-system ;hardcopy-system + system-source-size make-system-tag-table + *defsystem-version* + *compile-during-load* + *minimal-load* + *dont-redefine-require* + *files-missing-is-an-error* + *reload-systems-from-disk* + *source-pathname-default* + *binary-pathname-default* + *multiple-lisp-support* + )))) + + +;;; We import these symbols into the USER package to make them +;;; easier to use. Since some lisps have already defined defsystem +;;; in the user package, we may have to shadowing-import it. +#| +#-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics) +(eval-when (compile load eval) + (import *exports* #-(or :cltl2 :lispworks) "USER" + #+(or :cltl2 :lispworks) "COMMON-LISP-USER") + (import *special-exports* #-(or :cltl2 :lispworks) "USER" + #+(or :cltl2 :lispworks) "COMMON-LISP-USER")) +#+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics) +(eval-when (compile load eval) + (import *exports* #-(or :cltl2 :lispworks) "USER" + #+(or :cltl2 :lispworks) "COMMON-LISP-USER") + (shadowing-import *special-exports* + #-(or :cltl2 :lispworks) "USER" + #+(or :cltl2 :lispworks) "COMMON-LISP-USER")) +|# + +#-(or :PCL :CLOS :scl) +(when (find-package "PCL") + (pushnew :pcl *modules*) + (pushnew :pcl *features*)) + +;;; ******************************** +;;; Defsystem Version ************** +;;; ******************************** +(defparameter *defsystem-version* "3.3 Interim, 2002-06-13" + "Current version number/date for Defsystem.") + +;;; ******************************** +;;; Customizable System Parameters * +;;; ******************************** + +(defvar *dont-redefine-require* nil + "If T, prevents the redefinition of REQUIRE. This is useful for + lisps that treat REQUIRE specially in the compiler.") + +(defvar *multiple-lisp-support* t + "If T, afs-binary-directory will try to return a name dependent + on the particular lisp compiler version being used.") + +;;; home-subdirectory -- +;;; HOME-SUBDIRECTORY is used only in *central-registry* below. +;;; Note that CMU CL 17e does not understand the ~/ shorthand for home +;;; directories. +;;; +;;; Note: +;;; 20020220 Marco Antoniotti +;;; The #-cormanlisp version is the original one, which is broken anyway, since +;;; it is UNIX dependent. +;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing +;;; the ANSI USER-HOMEDIR-PATHNAME function. +#-cormanlisp +(defun home-subdirectory (directory) + (concatenate 'string + #+(or :sbcl :cmu :scl) + "home:" + #-(or :sbcl :cmu :scl) + (let ((homedir (user-homedir-pathname))) + (or (and homedir (namestring homedir)) + "~/")) + directory)) + +#+cormanlisp +(defun home-subdirectory (directory) + (declare (type string directory)) + (concatenate 'string "C:\\" directory)) + +;;; The following function is available for users to add +;;; (setq mk:*central-registry* (defsys-env-search-path)) +;;; to Lisp init files in order to use the value of the DEFSYSPATH +;;; instead of directly coding it in the file. +#+:allegro +(defun defsys-env-search-path () + "This function grabs the value of the DEFSYSPATH environment variable + and breaks the search path into a list of paths." + (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:) + :test #'string-equal)) + +;;; Change this variable to set up the location of a central +;;; repository for system definitions if you want one. +;;; This is a defvar to allow users to change the value in their +;;; lisp init files without worrying about it reverting if they +;;; reload defsystem for some reason. + +;;; Note that if a form is included in the registry list, it will be evaluated +;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check. + +(defvar *central-registry* + `(;; Current directory + "./" + #+:LUCID (working-directory) + #+ACLPC (current-directory) + #+:allegro (excl:current-directory) + #+:sbcl (progn *default-pathname-defaults*) + #+(or :cmu :scl) (ext:default-directory) + ;; *** Marco Antoniotti + ;; Somehow it is better to qualify default-directory in CMU with + ;; the appropriate package (i.e. "EXTENSIONS".) + ;; Same for Allegro. + #+(and :lispworks (not :lispworks4)) + ,(multiple-value-bind (major minor) + #-:lispworks-personal-edition + (system::lispworks-version) + #+:lispworks-personal-edition + (values system::*major-version-number* + system::*minor-version-number*) + (if (or (> major 3) + (and (= major 3) (> minor 2)) + (and (= major 3) (= minor 2) + (equal (lisp-implementation-version) "3.2.1"))) + `(make-pathname :directory + ,(find-symbol "*CURRENT-WORKING-DIRECTORY*" + (find-package "SYSTEM"))) + (find-symbol "*CURRENT-WORKING-DIRECTORY*" + (find-package "LW")))) + #+:lispworks4 + (hcl:get-working-directory) + ;; Home directory + #-sbcl + (mk::home-subdirectory "lisp/systems/") + + ;; Global registry + "/usr/local/lisp/Registry/") + "Central directory of system definitions. May be either a single + directory pathname, or a list of directory pathnames to be checked + after the local directory.") + + +(defun add-registry-location (pathname) + "Adds a path to the central registry." + (pushnew pathname *central-registry* :test #'equal)) + +(defvar *bin-subdir* ".bin/" + "The subdirectory of an AFS directory where the binaries are really kept.") + +;;; These variables set up defaults for operate-on-system, and are used +;;; for communication in lieu of parameter passing. Yes, this is bad, +;;; but it keeps the interface small. Also, in the case of the -if-no-binary +;;; variables, parameter passing would require multiple value returns +;;; from some functions. Why make life complicated? +(defvar *tell-user-when-done* nil + "If T, system will print ...DONE at the end of an operation") +(defvar *oos-verbose* nil + "Operate on System Verbose Mode") +(defvar *oos-test* nil + "Operate on System Test Mode") +(defvar *load-source-if-no-binary* nil + "If T, system will try loading the source if the binary is missing") +(defvar *bother-user-if-no-binary* t + "If T, the system will ask the user whether to load the source if + the binary is missing") +(defvar *load-source-instead-of-binary* nil + "If T, the system will load the source file instead of the binary.") +(defvar *compile-during-load* :query + "If T, the system will compile source files during load if the + binary file is missing. If :query, it will ask the user for + permission first.") +(defvar *minimal-load* nil + "If T, the system tries to avoid reloading files that were already loaded + and up to date.") + +(defvar *files-missing-is-an-error* t + "If both the source and binary files are missing, signal a continuable + error instead of just a warning.") + +(defvar *operations-propagate-to-subsystems* t + "If T, operations like :COMPILE and :LOAD propagate to subsystems + of a system that are defined either using a component-type of :system + or by another defsystem form.") + +;;; Particular to CMULisp +(defvar *compile-error-file-type* "err" + "File type of compilation error file in cmulisp") +(defvar *cmu-errors-to-terminal* t + "Argument to :errors-to-terminal in compile-file in cmulisp") +(defvar *cmu-errors-to-file* t + "If T, cmulisp will write an error file during compilation") + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** + +;;; Massage people's *features* into better shape. +(eval-when (compile load eval) + (dolist (feature *features*) + (when (and (symbolp feature) ; 3600 + (equal (symbol-name feature) "CMU")) + (pushnew :CMU *features*))) + + #+Lucid + (when (search "IBM RT PC" (machine-type)) + (pushnew :ibm-rt-pc *features*)) + ) + +;;; *filename-extensions* is a cons of the source and binary extensions. +(defvar *filename-extensions* + (car `(#+(and Symbolics Lispm) ("lisp" . "bin") + #+(and dec common vax (not ultrix)) ("LSP" . "FAS") + #+(and dec common vax ultrix) ("lsp" . "fas") + #+ACLPC ("lsp" . "fsl") + #+CLISP ("lsp" . "fas") + #+KCL ("lsp" . "o") + #+ECL ("lsp" . "so") + #+IBCL ("lsp" . "o") + #+Xerox ("lisp" . "dfasl") + ;; Lucid on Silicon Graphics + #+(and Lucid MIPS) ("lisp" . "mbin") + ;; the entry for (and lucid hp300) must precede + ;; that of (and lucid mc68000) for hp9000/300's running lucid, + ;; since *features* on hp9000/300's also include the :mc68000 + ;; feature. + #+(and lucid hp300) ("lisp" . "6bin") + #+(and Lucid MC68000) ("lisp" . "lbin") + #+(and Lucid Vax) ("lisp" . "vbin") + #+(and Lucid Prime) ("lisp" . "pbin") + #+(and Lucid SUNRise) ("lisp" . "sbin") + #+(and Lucid SPARC) ("lisp" . "sbin") + #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin") + ;; PA is Precision Architecture, HP's 9000/800 RISC cpu + #+(and Lucid PA) ("lisp" . "hbin") + #+excl ("cl" . ,(pathname-type (compile-file-pathname "foo.cl"))) + #+(or :cmu :scl) ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl")) +; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl") +; #+(and :CMU :sgi) ("lisp" . "sgif") +; #+(and :CMU :sparc) ("lisp" . "sparcf") + #+PRIME ("lisp" . "pbin") + #+HP ("l" . "b") + #+TI ("lisp" . #.(string (si::local-binary-file-type))) + #+:gclisp ("LSP" . "F2S") + #+pyramid ("clisp" . "o") + + ;; Harlequin LispWorks + #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*) +; #+(and :sun4 :lispworks) ("lisp" . "wfasl") +; #+(and :mips :lispworks) ("lisp" . "mfasl") + #+:mcl ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp"))) + #+:coral ("lisp" . "fasl") + + ;; Otherwise, + ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp"))))) + "Filename extensions for Common Lisp. A cons of the form + (Source-Extension . Binary-Extension). If the system is + unknown (as in *features* not known), defaults to lisp and fasl.") + +(defvar *system-extension* + ;; MS-DOS systems can only handle three character extensions. + #-ACLPC "system" + #+ACLPC "sys" + "The filename extension to use with systems.") + +;;; The above variables and code should be extended to allow a list of +;;; valid extensions for each lisp implementation, instead of a single +;;; extension. When writing a file, the first extension should be used. +;;; But when searching for a file, every extension in the list should +;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and +;;; "lsp" (*load-source-types*) as source code extensions, and +;;; (c:backend-fasl-file-type c:*backend*) +;;; (c:backend-byte-fasl-file-type c:*backend*) +;;; and "fasl" as binary (object) file extensions (*load-object-types*). + +;;; Note that the above code is used below in the LANGUAGE defstruct. + +;;; There is no real support for this variable being nil, so don't change it. +;;; Note that in any event, the toplevel system (defined with defsystem) +;;; will have its dependencies delayed. Not having dependencies delayed +;;; might be useful if we define several systems within one defsystem. +(defvar *system-dependencies-delayed* t + "If T, system dependencies are expanded at run time") + +;;; Replace this with consp, dammit! +(defun non-empty-listp (list) + (and list (listp list))) + +;;; ******************************** +;;; Component Operation Definition * +;;; ******************************** +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *version-dir* nil + "The version subdir. bound in operate-on-system.") +(defvar *version-replace* nil + "The version replace. bound in operate-on-system.") +(defvar *version* nil + "Default version.")) + +(defvar *component-operations* (make-hash-table :test #'equal) + "Hash table of (operation-name function) pairs.") +(defun component-operation (name &optional operation) + (if operation + (setf (gethash name *component-operations*) operation) + (gethash name *component-operations*))) + +;;; ******************************** +;;; AFS @sys immitator ************* +;;; ******************************** + +;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out. +#-:mcl +(eval-when (compile load eval) + ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo"). + ;; For example, + ;; #@"foo" + ;; "foo/.bin/rt_mach/" + (set-dispatch-macro-character + #\# #\@ + #'(lambda (stream char arg) + (declare (ignore char arg)) + `(afs-binary-directory ,(read stream t nil t))))) + +(defvar *find-irix-version-script* + "\"1,4 d\\ +s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ +/./,$ d\\ +\"") + +(defun operating-system-version () + #+(and :sgi :excl) + (let* ((full-version (software-version)) + (blank-pos (search " " full-version)) + (os (subseq full-version 0 blank-pos)) + (version-rest (subseq full-version + (1+ blank-pos))) + os-version) + (setq blank-pos (search " " version-rest)) + (setq version-rest (subseq version-rest + (1+ blank-pos))) + (setq blank-pos (search " " version-rest)) + (setq os-version (subseq version-rest 0 blank-pos)) + (setq version-rest (subseq version-rest + (1+ blank-pos))) + (setq blank-pos (search " " version-rest)) + (setq version-rest (subseq version-rest + (1+ blank-pos))) + (concatenate 'string + os " " os-version)) ; " " version-rest + #+(and :sgi :cmu :sbcl) + (concatenate 'string + (software-type) + (software-version)) + #+(and :lispworks :irix) + (let ((soft-type (software-type))) + (if (equalp soft-type "IRIX5") + (progn + (foreign:call-system + (format nil "versions ~A | sed -e ~A > ~A" + "eoe1" + *find-irix-version-script* + "irix-version") + "/bin/csh") + (with-open-file (s "irix-version") + (format nil "IRIX ~S" + (read s)))) + soft-type)) + #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix)) + (software-type)) + +(defun compiler-version () + #+:lispworks (concatenate 'string + "lispworks" " " (lisp-implementation-version)) + #+excl (concatenate 'string + "excl" " " excl::*common-lisp-version-number*) + #+sbcl (concatenate 'string + "sbcl" " " (lisp-implementation-version)) + #+cmu (concatenate 'string + "cmu" " " (lisp-implementation-version)) + #+scl (concatenate 'string + "scl" " " (lisp-implementation-version)) + + #+kcl "kcl" + #+IBCL "ibcl" + #+akcl "akcl" + #+gcl "gcl" + #+ecl "ecl" + #+lucid "lucid" + #+ACLPC "aclpc" + #+CLISP "clisp" + #+Xerox "xerox" + #+symbolics "symbolics" + #+mcl "mcl" + #+coral "coral" + #+gclisp "gclisp" + ) + +(defun afs-binary-directory (root-directory) + ;; Function for obtaining the directory AFS's @sys feature would have + ;; chosen when we're not in AFS. This function is useful as the argument + ;; to :binary-pathname in defsystem. For example, + ;; :binary-pathname (afs-binary-directory "scanner/") + (let ((machine (machine-type-translation + #-(and :sgi :allegro-version>= (version>= 4 2)) + (machine-type) + #+(and :sgi :allegro-version>= (version>= 4 2)) + (machine-version))) + (software (software-type-translation + #-(and :sgi (or :cmu :sbcl :scl + (and :allegro-version>= (version>= 4 2)))) + (software-type) + #+(and :sgi (or :cmu :sbcl :scl + (and :allegro-version>= (version>= 4 2)))) + (operating-system-version))) + (lisp (compiler-type-translation (compiler-version)))) + ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach + (setq root-directory (namestring root-directory)) + (setq root-directory (ensure-trailing-slash root-directory)) + (format nil "~A~@[~A~]~@[~A/~]" + root-directory + *bin-subdir* + (if *multiple-lisp-support* + (afs-component machine software lisp) + (afs-component machine software))))) + +(defun afs-source-directory (root-directory &optional version-flag) + ;; Function for obtaining the directory AFS's @sys feature would have + ;; chosen when we're not in AFS. This function is useful as the argument + ;; to :source-pathname in defsystem. + (setq root-directory (namestring root-directory)) + (setq root-directory (ensure-trailing-slash root-directory)) + (format nil "~A~@[~A/~]" + root-directory + (and version-flag (translate-version *version*)))) + +(defun null-string (s) + (when (stringp s) + (string-equal s ""))) + +(defun ensure-trailing-slash (dir) + (if (and dir + (not (null-string dir)) + (not (char= (char dir + (1- (length dir))) + #\/)) + (not (char= (char dir + (1- (length dir))) + #\\)) + ) + (concatenate 'string dir "/") + dir)) + +(defun afs-component (machine software &optional lisp) + (format nil "~@[~A~]~@[_~A~]~@[_~A~]" + machine + (or software "mach") + lisp)) + +(defvar *machine-type-alist* (make-hash-table :test #'equal) + "Hash table for retrieving the machine-type") +(defun machine-type-translation (name &optional operation) + (if operation + (setf (gethash (string-upcase name) *machine-type-alist*) operation) + (gethash (string-upcase name) *machine-type-alist*))) + +(machine-type-translation "IBM RT PC" "rt") +(machine-type-translation "DEC 3100" "pmax") +(machine-type-translation "DEC VAX-11" "vax") +(machine-type-translation "DECstation" "pmax") +(machine-type-translation "Sun3" "sun3") +(machine-type-translation "Sun-4" "sun4") +(machine-type-translation "MIPS Risc" "mips") +(machine-type-translation "SGI" "sgi") +(machine-type-translation "Silicon Graphics Iris 4D" "sgi") +(machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi") +(machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi") +(machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi") +(machine-type-translation "IP22" "sgi") +;;; MIPS R4000 Processor Chip Revision: 3.0 +;;; MIPS R4400 Processor Chip Revision: 5.0 +;;; MIPS R4600 Processor Chip Revision: 1.0 +(machine-type-translation "IP20" "sgi") +;;; MIPS R4000 Processor Chip Revision: 3.0 +(machine-type-translation "IP17" "sgi") +;;; MIPS R4000 Processor Chip Revision: 2.2 +(machine-type-translation "IP12" "sgi") +;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0 +(machine-type-translation "IP7" "sgi") +;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0 + +(machine-type-translation "x86" "x86") +;;; ACL +(machine-type-translation "IBM PC Compatible" "x86") +;;; LW +(machine-type-translation "I686" "x86") +;;; LW +(machine-type-translation "PC/386" "x86") +;;; CLisp Win32 + +#+(and :lucid :sun :mc68000) +(machine-type-translation "unknown" "sun3") + + +(defvar *software-type-alist* (make-hash-table :test #'equal) + "Hash table for retrieving the software-type") +(defun software-type-translation (name &optional operation) + (if operation + (setf (gethash (string-upcase name) *software-type-alist*) operation) + (gethash (string-upcase name) *software-type-alist*))) + +(software-type-translation "BSD UNIX" "mach") ; "unix" +(software-type-translation "Ultrix" "mach") ; "ultrix" +(software-type-translation "SunOS" "SunOS") +(software-type-translation "MACH/4.3BSD" "mach") +(software-type-translation "IRIX System V" "irix") ; (software-type) +(software-type-translation "IRIX5" "irix5") +;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version) + +(software-type-translation "IRIX 5.2" "irix5") +(software-type-translation "IRIX 5.3" "irix5") +(software-type-translation "IRIX5.2" "irix5") +(software-type-translation "IRIX5.3" "irix5") + +(software-type-translation "Linux" "linux") ; Lispworks for Linux +(software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL +(software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32") +(software-type-translation "Windows NT" "win32") ; LW for Windows +(software-type-translation "ANSI C program" "ansi-c") ; CLISP +(software-type-translation "C compiler" "ansi-c") ; CLISP for Win32 + +(software-type-translation nil "") + +#+:lucid +(software-type-translation "Unix" + #+:lcl4.0 "4.0" + #+(and :lcl3.0 (not :lcl4.0)) "3.0") + +(defvar *compiler-type-alist* (make-hash-table :test #'equal) + "Hash table for retrieving the Common Lisp type") +(defun compiler-type-translation (name &optional operation) + (if operation + (setf (gethash (string-upcase name) *compiler-type-alist*) operation) + (gethash (string-upcase name) *compiler-type-alist*))) + +(compiler-type-translation "lispworks 3.2.1" "lispworks") +(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks") +(compiler-type-translation "lispworks 4.2.0" "lispworks") + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (or (find :case-sensitive common-lisp:*features*) + (find :case-insensitive common-lisp:*features*)) + (if (or (eq excl:*current-case-mode* :case-sensitive-lower) + (eq excl:*current-case-mode* :case-sensitive-upper)) + (push :case-sensitive common-lisp:*features*) + (push :case-insensitive common-lisp:*features*)))) + + +#+(and allegro case-sensitive ics) +(compiler-type-translation "excl 6.1" "excl-m") +#+(and allegro case-sensitive (not ics)) +(compiler-type-translation "excl 6.1" "excl-m8") + +#+(and allegro case-insensitive ics) +(compiler-type-translation "excl 6.1" "excl-a") +#+(and allegro case-insensitive (not ics)) +(compiler-type-translation "excl 6.1" "excl-a8") + +(compiler-type-translation "excl 4.2" "excl") +(compiler-type-translation "excl 4.1" "excl") +(compiler-type-translation "cmu 17f" "cmu") +(compiler-type-translation "cmu 17e" "cmu") +(compiler-type-translation "cmu 17d" "cmu") + +;;; ******************************** +;;; System Names ******************* +;;; ******************************** + +;;; If you use strings for system names, be sure to use the same case +;;; as it appears on disk, if the filesystem is case sensitive. +(defun canonicalize-system-name (name) + ;; Originally we were storing systems using GET. This meant that the + ;; name of a system had to be a symbol, so we interned the symbols + ;; in the keyword package to avoid package dependencies. Now that we're + ;; storing the systems in a hash table, we've switched to using strings. + ;; Since the hash table is case sensitive, we use uppercase strings. + ;; (Names of modules and files may be symbols or strings.) + #||(if (keywordp name) + name + (intern (string-upcase (string name)) "KEYWORD"))||# + (if (stringp name) (string-upcase name) (string-upcase (string name)))) + +(defvar *defined-systems* (make-hash-table :test #'equal) + "Hash table containing the definitions of all known systems.") + +(defun get-system (name) + "Returns the definition of the system named NAME." + (gethash (canonicalize-system-name name) *defined-systems*)) + +(defsetf get-system (name) (value) + `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value)) + +(defun undefsystem (name) + "Removes the definition of the system named NAME." + (setf (get-system name) nil)) + +(defun defined-systems () + "Returns a list of defined systems." + (let ((result nil)) + (maphash #'(lambda (key value) + (declare (ignore key)) + (push value result)) + *defined-systems*) + result)) + +;;; ******************************** +;;; Directory Pathname Hacking ***** +;;; ******************************** + +;;; Unix example: An absolute directory starts with / while a +;;; relative directory doesn't. A directory ends with /, while +;;; a file's pathname doesn't. This is important 'cause +;;; (pathname-directory "foo/bar") will return "foo" and not "foo/". + +;;; I haven't been able to test the fix to the problem with symbolics +;;; hosts. Essentially, append-directories seems to have been tacking +;;; the default host onto the front of the pathname (e.g., mk::source-pathname +;;; gets a "B:" on front) and this overrides the :host specified in the +;;; component. The value of :host should override that specified in +;;; the :source-pathname and the default file server. If this doesn't +;;; fix things, specifying the host in the root pathname "F:>root-dir>" +;;; may be a good workaround. + +;;; Need to verify that merging of pathnames where modules are located +;;; on different devices (in VMS-based VAXLisp) now works. + +;;; Merge-pathnames works for VMS systems. In VMS systems, the directory +;;; part is enclosed in square brackets, e.g., +;;; "[root.child.child_child]" or "[root.][child.][child_child]" +;;; To concatenate directories merge-pathnames works as follows: +;;; (merge-pathnames "" "[root]") ==> "[root]" +;;; (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext" +;;; (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext" +;;; (merge-pathnames "[root]file.ext" "[son]") ==> "[root]file.ext" +;;; Thus the problem with the #-VMS code was that it was merging x y into +;;; [[x]][y] instead of [x][y] or [x]y. + +;;; Miscellaneous notes: +;;; On GCLisp, the following are equivalent: +;;; "\\root\\subdir\\BAZ" +;;; "/root/subdir/BAZ" +;;; On VAXLisp, the following are equivalent: +;;; "[root.subdir]BAZ" +;;; "[root.][subdir]BAZ" +;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2 + +(defun new-append-directories (absolute-dir relative-dir) + ;; Version of append-directories for CLtL2-compliant lisps. In particular, + ;; they must conform to section 23.1.3 "Structured Directories". We are + ;; willing to fix minor aberations in this function, but not major ones. + ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100), + ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0. + (setf absolute-dir (or absolute-dir "") + relative-dir (or relative-dir "")) + (let* ((abs-dir (pathname absolute-dir)) + (rel-dir (pathname relative-dir)) + (host (pathname-host abs-dir)) + (device (if (null-string absolute-dir) ; fix for CMU CL old compiler + (pathname-device rel-dir) + (pathname-device abs-dir))) + (abs-directory (directory-to-list (pathname-directory abs-dir))) + (abs-keyword (when (keywordp (car abs-directory)) + (pop abs-directory))) + ;; Stig (July 2001): + ;; Somehow CLISP dies on the next line, but NIL is ok. + (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name + (rel-directory (directory-to-list (pathname-directory rel-dir))) + (rel-keyword (when (keywordp (car rel-directory)) + (pop rel-directory))) + #-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir)) + ;; Stig (July 2001); + ;; These values seems to help clisp as well + #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir)) + #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir)) + (directory nil)) + + ;; TI Common Lisp pathnames can return garbage for file names because + ;; of bizarreness in the merging of defaults. The following code makes + ;; sure that the name is a valid name by comparing it with the + ;; pathname-name. It also strips TI specific extensions and handles + ;; the necessary case conversion. TI maps upper back into lower case + ;; for unix files! + #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal) + (setf abs-name (string-right-trim "." (string-upcase abs-name))) + (setf abs-name nil)) + #+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal) + (setf rel-file (string-right-trim "." (string-upcase rel-file))) + (setf rel-file nil)) + ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root) + ;; and filename "foo". The namestring of a pathname with + ;; directory '(:absolute :root "foo") ignores everything after the + ;; :root. + #+(and allegro-version>= (version>= 4 0)) + (when (eq (car abs-directory) :root) (pop abs-directory)) + #+(and allegro-version>= (version>= 4 0)) + (when (eq (car rel-directory) :root) (pop rel-directory)) + + (when (and abs-name (not (null-string abs-name))) ; was abs-name + (cond ((and (null abs-directory) (null abs-keyword)) + #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative) + (setf abs-directory (list abs-name))) + (t + (setf abs-directory (append abs-directory (list abs-name)))))) + (when (and (null abs-directory) + (or (null abs-keyword) + ;; In Lucid, an abs-dir of nil gets a keyword of + ;; :relative since (pathname-directory (pathname "")) + ;; returns (:relative) instead of nil. + #+:lucid (eq abs-keyword :relative)) + rel-keyword) + ;; The following feature switches seem necessary in CMUCL + ;; Marco Antoniotti 19990707 + #+(or :sbcl :CMU) + (if (typep abs-dir 'logical-pathname) + (setf abs-keyword :absolute) + (setf abs-keyword rel-keyword)) + #-(or :sbcl :CMU) + (setf abs-keyword rel-keyword)) + (setf directory (append abs-directory rel-directory)) + (when abs-keyword (setf directory (cons abs-keyword directory))) + (namestring + (make-pathname :host host + :device device + :directory + directory + :name + #-(or :sbcl :MCL :clisp) rel-file + #+(or :sbcl :MCL :clisp) rel-name + + #+(or :sbcl :MCL :clisp) :type + #+(or :sbcl :MCL :clisp) rel-type + )))) + +(defun directory-to-list (directory) + ;; The directory should be a list, but nonstandard implementations have + ;; been known to use a vector or even a string. + (cond ((listp directory) + directory) + ((stringp directory) + (cond ((find #\; directory) + ;; It's probably a logical pathname, so split at the + ;; semicolons: + (split-string directory :item #\;)) + #+MCL + ((and (find #\: directory) + (not (find #\/ directory))) + ;; It's probably a MCL pathname, so split at the colons. + (split-string directory :item #\:)) + (t + ;; It's probably a unix pathname, so split at the slash. + (split-string directory :item #\/)))) + (t + (coerce directory 'list)))) + + +(defparameter *append-dirs-tests* + '("~/foo/" "baz/bar.lisp" + "~/foo" "baz/bar.lisp" + "/foo/bar/" "baz/barf.lisp" + "/foo/bar/" "/baz/barf.lisp" + "foo/bar/" "baz/barf.lisp" + "foo/bar" "baz/barf.lisp" + "foo/bar" "/baz/barf.lisp" + "foo/bar/" "/baz/barf.lisp" + "/foo/bar/" nil + "foo/bar/" nil + "foo/bar" nil + "foo" nil + "foo" "" + nil "baz/barf.lisp" + nil "/baz/barf.lisp" + nil nil)) + +(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*)) + (do* ((dir-list test-dirs (cddr dir-list)) + (abs-dir (car dir-list) (car dir-list)) + (rel-dir (cadr dir-list) (cadr dir-list))) + ((null dir-list) (values)) + (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S" + abs-dir rel-dir (new-append-directories abs-dir rel-dir)))) + +#|| + (test-new-append-directories) + +ABS: "~/foo/" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp" +ABS: "~/foo" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp" +ABS: "/foo/bar/" REL: "baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp" +ABS: "/foo/bar/" REL: "/baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp" +ABS: "foo/bar/" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" +ABS: "foo/bar" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" +ABS: "foo/bar" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" +ABS: "foo/bar/" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" +ABS: "/foo/bar/" REL: NIL Result: "/foo/bar/" +ABS: "foo/bar/" REL: NIL Result: "foo/bar/" +ABS: "foo/bar" REL: NIL Result: "foo/bar/" +ABS: "foo" REL: NIL Result: "foo/" +ABS: "foo" REL: "" Result: "foo/" +ABS: NIL REL: "baz/barf.lisp" Result: "baz/barf.lisp" +ABS: NIL REL: "/baz/barf.lisp" Result: "/baz/barf.lisp" +ABS: NIL REL: NIL Result: "" + +||# + + +(defun append-directories (absolute-directory relative-directory) + "There is no CL primitive for tacking a subdirectory onto a directory. + We need such a function because defsystem has both absolute and + relative pathnames in the modules. This is a somewhat ugly hack which + seems to work most of the time. We assume that ABSOLUTE-DIRECTORY + is a directory, with no filename stuck on the end. Relative-directory, + however, may have a filename stuck on the end." + (when (or absolute-directory relative-directory) + (cond + ;; KMR commented out because: when appending two logical pathnames, + ;; using this code translates the first logical pathname then appends + ;; the second logical pathname -- an error. + #| + ;; We need a reliable way to determine if a pathname is logical. + ;; Allegro 4.1 does not recognize the syntax of a logical pathname + ;; as being logical unless its logical host is already defined. + + #+(or (and allegro-version>= (version>= 4 1)) + :logical-pathnames-mk) + ((and absolute-directory + (logical-pathname-p absolute-directory) + relative-directory) + ;; For use with logical pathnames package. + (append-logical-directories-mk absolute-directory relative-directory)) + |# + ((namestring-probably-logical absolute-directory) + ;; A simplistic stab at handling logical pathnames + (append-logical-pnames absolute-directory relative-directory)) + (t + ;; In VMS, merge-pathnames actually does what we want!!! + #+:VMS + (namestring (merge-pathnames (or absolute-directory "") + (or relative-directory ""))) + #+:macl1.3.2 + (namestring (make-pathname :directory absolute-directory + :name relative-directory)) + ;; Cross your fingers and pray. + #-(or :VMS :macl1.3.2) + (new-append-directories absolute-directory relative-directory))))) + +#+:logical-pathnames-mk +(defun append-logical-directories-mk (absolute-dir relative-dir) + (lp:append-logical-directories absolute-dir relative-dir)) + + +;;; append-logical-pathnames-mk -- +;;; The following is probably still bogus and it does not solve the +;;; problem of appending two logical pathnames. +;;; Anyway, as per suggetsion by KMR, the function is not called +;;; anymore. +;;; Hopefully this will not cause problems for ACL. + +#+(and (and allegro-version>= (version>= 4 1)) + (not :logical-pathnames-mk)) +(defun append-logical-directories-mk (absolute-dir relative-dir) + ;; We know absolute-dir and relative-dir are non nil. Moreover + ;; absolute-dir is a logical pathname. + (setq absolute-dir (logical-pathname absolute-dir)) + (etypecase relative-dir + (string (setq relative-dir (parse-namestring relative-dir))) + (pathname #| do nothing |#)) + + (translate-logical-pathname + (merge-pathnames relative-dir absolute-dir))) + +#| Old version 2002-03-02 +#+(and (and allegro-version>= (version>= 4 1)) + (not :logical-pathnames-mk)) +(defun append-logical-directories-mk (absolute-dir relative-dir) + ;; We know absolute-dir and relative-dir are non nil. Moreover + ;; absolute-dir is a logical pathname. + (setq absolute-dir (logical-pathname absolute-dir)) + (etypecase relative-dir + (string (setq relative-dir (parse-namestring relative-dir))) + (pathname #| do nothing |#)) + + (translate-logical-pathname + (make-pathname + :host (or (pathname-host absolute-dir) + (pathname-host relative-dir)) + :directory (append (pathname-directory absolute-dir) + (cdr (pathname-directory relative-dir))) + :name (or (pathname-name absolute-dir) + (pathname-name relative-dir)) + :type (or (pathname-type absolute-dir) + (pathname-type relative-dir)) + :version (or (pathname-version absolute-dir) + (pathname-version relative-dir))))) + +;; Old version +#+(and (and allegro-version>= (version>= 4 1)) + (not :logical-pathnames-mk)) +(defun append-logical-directories-mk (absolute-dir relative-dir) + (when (or absolute-dir relative-dir) + (setq absolute-dir (logical-pathname (or absolute-dir "")) + relative-dir (logical-pathname (or relative-dir ""))) + (translate-logical-pathname + (make-pathname + :host (or (pathname-host absolute-dir) + (pathname-host relative-dir)) + :directory (append (pathname-directory absolute-dir) + (cdr (pathname-directory relative-dir))) + :name (or (pathname-name absolute-dir) + (pathname-name relative-dir)) + :type (or (pathname-type absolute-dir) + (pathname-type relative-dir)) + :version (or (pathname-version absolute-dir) + (pathname-version relative-dir)))))) +|# + +;;; determines if string or pathname object is logical +#+:logical-pathnames-mk +(defun logical-pathname-p (thing) + (eq (lp:pathname-host-type thing) :logical)) + +;;; From Kevin Layer for 4.1final. +#+(and (and allegro-version>= (version>= 4 1)) + (not :logical-pathnames-mk)) +(defun logical-pathname-p (thing) + (typep (parse-namestring thing) 'logical-pathname)) + +(defun pathname-logical-p (thing) + (typecase thing + (logical-pathname t) + #+clisp ; CLisp has non conformant Logical Pathnames. + (pathname (pathname-logical-p (namestring thing))) + (string (and (= 1 (count #\: thing)) ; Shortcut. + (ignore-errors (translate-logical-pathname thing)) + t)) + (t nil))) + +;;; This affects only one thing. +;;; 19990707 Marco Antoniotti +;;; old version + +(defun namestring-probably-logical (namestring) + (and (stringp namestring) + ;; unix pathnames don't have embedded semicolons + (find #\; namestring))) +#|| +;;; New version +(defun namestring-probably-logical (namestring) + (and (stringp namestring) + (typep (parse-namestring namestring) 'logical-pathname))) + + +;;; New new version +;;; 20000321 Marco Antoniotti +(defun namestring-probably-logical (namestring) + (pathname-logical-p namestring)) +||# + +(defun append-logical-pnames (absolute relative) + (declare (type (or null string pathname) absolute relative)) + (let ((abs (if absolute + #-clisp (namestring absolute) + #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string + "")) + (rel (if relative (namestring relative) "")) + ) + ;; Make sure the absolute directory ends with a semicolon unless + ;; the pieces are null strings + (unless (or (null-string abs) (null-string rel) + (char= (char abs (1- (length abs))) + #\;)) + (setq abs (concatenate 'string abs ";"))) + ;; Return the concatenate pathnames + (concatenate 'string abs rel))) + +#|| +;;; This was a try at appending a subdirectory onto a directory. +;;; It failed. We're keeping this around to prevent future mistakes +;;; of a similar sort. +(defun merge-directories (absolute-directory relative-directory) + ;; replace concatenate with something more intelligent + ;; i.e., concatenation won't work with some directories. + ;; it should also behave well if the parent directory + ;; has a filename at the end, or if the relative-directory ain't relative + (when absolute-directory + (setq absolute-directory (pathname-directory absolute-directory))) + (concatenate 'string + (or absolute-directory "") + (or relative-directory ""))) +||# + +#|| + (defun d (d n) (namestring (make-pathname :directory d :name n))) + +D + (d "~/foo/" "baz/bar.lisp") +"/usr0/mkant/foo/baz/bar.lisp" + + (d "~/foo" "baz/bar.lisp") +"/usr0/mkant/foo/baz/bar.lisp" + + (d "/foo/bar/" "baz/barf.lisp") +"/foo/bar/baz/barf.lisp" + + (d "foo/bar/" "baz/barf.lisp") +"foo/bar/baz/barf.lisp" + + (d "foo/bar" "baz/barf.lisp") +"foo/bar/baz/barf.lisp" + + (d "foo/bar" "/baz/barf.lisp") +"foo/bar//baz/barf.lisp" + + (d "foo/bar" nil) +"foo/bar/" + + (d nil "baz/barf.lisp") +"baz/barf.lisp" + + (d nil nil) +"" + +||# + +;;; The following is a change proposed by DTC for SCL. +;;; Maybe it could be used all the time. + +#-scl +(defun new-file-type (pathname type) + ;; why not (make-pathname :type type :defaults pathname)? + (make-pathname + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (pathname-directory pathname) + :name (pathname-name pathname) + :type type + :version (pathname-version pathname))) + + +#+scl +(defun new-file-type (pathname type) + ;; why not (make-pathname :type type :defaults pathname)? + (make-pathname + :host (pathname-host pathname :case :common) + :device (pathname-device pathname :case :common) + :directory (pathname-directory pathname :case :common) + :name (pathname-name pathname :case :common) + :type (string-upcase type) + :version (pathname-version pathname :case :common))) + + + +;;; ******************************** +;;; Component Defstruct ************ +;;; ******************************** +(defvar *source-pathname-default* nil + "Default value of :source-pathname keyword in DEFSYSTEM. Set this to + \"\" to avoid having to type :source-pathname \"\" all the time.") + +(defvar *binary-pathname-default* nil + "Default value of :binary-pathname keyword in DEFSYSTEM.") + +;;; Removed TIME slot, which has been made unnecessary by the new definition +;;; of topological-sort. + +(defstruct (topological-sort-node (:conc-name topsort-)) + (color :white :type (member :gray :black :white)) + ;; time + ) + +(defstruct (component (:include topological-sort-node) + (:print-function print-component)) + (type :file ; to pacify the CMUCL compiler (:type is alway supplied) + :type (member :defsystem + :system + :subsystem + :module + :file + :private-file + )) + (name nil :type (or symbol string)) + (indent 0 :type (mod 1024)) ; Number of characters of indent in + ; verbose output to the user. + host ; The pathname host (i.e., "/../a"). + device ; The pathname device. + source-root-dir ; Relative or absolute (starts + ; with "/"), directory or file + ; (ends with "/"). + (source-pathname *source-pathname-default*) + source-extension ; A string, e.g., "lisp" + ; if NIL, inherit + (binary-pathname *binary-pathname-default*) + binary-root-dir + binary-extension ; A string, e.g., "fasl". If + ; NIL, uses default for + ; machine-type. + package ; Package for use-package. + + ;; The following three slots are used to provide for alternate compilation + ;; and loading functions for the files contained within a component. If + ;; a component has a compiler or a loader specified, those functions are + ;; used. Otherwise the functions are derived from the language. If no + ;; language is specified, it defaults to Common Lisp (:lisp). Other current + ;; possible languages include :scheme (PseudoScheme) and :c, but the user + ;; can define additional language mappings. Compilation functions should + ;; accept a pathname argument and a :output-file keyword; loading functions + ;; just a pathname argument. The default functions are #'compile-file and + ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to + ;; mix languages. + (language nil :type (or null symbol)) + (compiler nil :type (or null symbol function)) + (loader nil :type (or null symbol function)) + (compiler-options nil :type list) ; A list of compiler options to + ; use for compiling this + ; component. These must be + ; keyword options supported by + ; the compiler. + + (components () :type list) ; A list of components + ; comprising this component's + ; definition. + (depends-on () :type list) ; A list of the components + ; this one depends on. may + ; refer only to the components + ; at the same level as this + ; one. + proclamations ; Compiler options, such as + ; '(optimize (safety 3)). + initially-do ; Form to evaluate before the + ; operation. + finally-do ; Form to evaluate after the operation. + compile-form ; For foreign libraries. + load-form ; For foreign libraries. + + ;; load-time ; The file-write-date of the + ; binary/source file loaded. + + ;; If load-only is T, will not compile the file on operation :compile. + ;; In other words, for files which are :load-only T, loading the file + ;; satisfies any demand to recompile. + load-only ; If T, will not compile this + ; file on operation :compile. + ;; If compile-only is T, will not load the file on operation :compile. + ;; Either compiles or loads the file, but not both. In other words, + ;; compiling the file satisfies the demand to load it. This is useful + ;; for PCL defmethod and defclass definitions, which wrap a + ;; (eval-when (compile load eval) ...) around the body of the definition. + ;; This saves time in some lisps. + compile-only ; If T, will not load this + ; file on operation :compile. + #|| ISI Extension ||# + load-always ; If T, will force loading + ; even if file has not + ; changed. + ;; PVE: add banner + (banner nil :type (or null string)) + + (documentation nil :type (or null string)) ; Optional documentation slot + ) + + +;;; To allow dependencies from "foreign systems" like ASDF or one of +;;; the proprietary ones like ACL or LW. + +(defstruct (foreign-system (:include component (type :system))) + kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...) + object ; The actual foreign system object. + ) + + +(defun register-foreign-system (name &key representation kind) + (declare (type (or symbol string) name)) + (let ((fs (make-foreign-system :name name + :kind kind + :object representation))) + (setf (get-system name) fs))) + + + +(define-condition missing-component (simple-condition) + ((name :reader missing-component-name + :initarg :name) + (component :reader missing-component-component + :initarg :component) + ) + (:default-initargs :component nil) + (:report (lambda (mmc stream) + (format stream "MK:DEFSYSTEM: missing component ~S for ~S." + (missing-component-name mmc) + (missing-component-component mmc)))) + ) + +(define-condition missing-module (missing-component) + () + (:report (lambda (mmc stream) + (format stream "MK:DEFSYSTEM: missing module ~S for ~S." + (missing-component-name mmc) + (missing-component-component mmc)))) + ) + +(define-condition missing-system (missing-module) + () + (:report (lambda (msc stream) + (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]." + (missing-component-name msc) + (missing-component-component msc)))) + ) + + + +(defvar *file-load-time-table* (make-hash-table :test #'equal) + "Hash table of file-write-dates for the system definitions and + files in the system definitions.") +(defun component-load-time (component) + (when component + (etypecase component + (string (gethash component *file-load-time-table*)) + (pathname (gethash (namestring component) *file-load-time-table*)) + (component + (ecase (component-type component) + (:defsystem + (let* ((name (component-name component)) + (path (when name (compute-system-path name nil)))) + (declare (type (or string pathname null) path)) + (when path + (gethash (namestring path) *file-load-time-table*)))) + ((:file :private-file) + ;; Use only :source pathname to identify component's + ;; load time. + (let ((path (component-full-pathname component :source))) + (when path + (gethash path *file-load-time-table*))))))))) + +#-(or :cmu) +(defsetf component-load-time (component) (value) + `(when ,component + (etypecase ,component + (string (setf (gethash ,component *file-load-time-table*) ,value)) + (pathname (setf (gethash (namestring (the pathname ,component)) + *file-load-time-table*) + ,value)) + (component + (ecase (component-type ,component) + (:defsystem + (let* ((name (component-name ,component)) + (path (when name (compute-system-path name nil)))) + (declare (type (or string pathname null) path)) + (when path + (setf (gethash (namestring path) *file-load-time-table*) + ,value)))) + ((:file :private-file) + ;; Use only :source pathname to identify file. + (let ((path (component-full-pathname ,component :source))) + (when path + (setf (gethash path *file-load-time-table*) + ,value))))))) + ,value)) + +#+(or :cmu) +(defun (setf component-load-time) (value component) + (declare + (type (or null string pathname component) component) + (type (or unsigned-byte null) value)) + (when component + (etypecase component + (string (setf (gethash component *file-load-time-table*) value)) + (pathname (setf (gethash (namestring (the pathname component)) + *file-load-time-table*) + value)) + (component + (ecase (component-type component) + (:defsystem + (let* ((name (component-name component)) + (path (when name (compute-system-path name nil)))) + (declare (type (or string pathname null) path)) + (when path + (setf (gethash (namestring path) *file-load-time-table*) + value)))) + ((:file :private-file) + ;; Use only :source pathname to identify file. + (let ((path (component-full-pathname component :source))) + (when path + (setf (gethash path *file-load-time-table*) + value))))))) + value)) + + +;;; compute-system-path -- + +(defun compute-system-path (module-name definition-pname) + (let* ((file-pathname + (make-pathname :name (etypecase module-name + (symbol (string-downcase + (string module-name))) + (string module-name)) + :type *system-extension*)) + (lib-file-pathname + (make-pathname :directory (list :relative module-name) + :name (etypecase module-name + (symbol (string-downcase + (string module-name))) + (string module-name)) + :type *system-extension*)) + ) + (or (when definition-pname ; given pathname for system def + (probe-file definition-pname)) + ;; Then the central registry. Note that we also check the current + ;; directory in the registry, but the above check is hard-coded. + (cond (*central-registry* + (if (listp *central-registry*) + (dolist (registry *central-registry*) + (let ((file (or (probe-file + (append-directories (if (consp registry) + (eval registry) + registry) + file-pathname)) + (probe-file + (append-directories (if (consp registry) + (eval registry) + registry) + lib-file-pathname)) + )) + ) + (when file (return file)))) + (or (probe-file (append-directories *central-registry* + file-pathname)) + (probe-file (append-directories *central-registry* + lib-file-pathname)) + )) + ) + (t + ;; No central registry. Assume current working directory. + ;; Maybe this should be an error? + (or (probe-file file-pathname) + (probe-file lib-file-pathname))))) + )) + + +(defun system-definition-pathname (system-name) + (let ((system (ignore-errors (find-system system-name :error)))) + (if system + (let ((system-def-pathname + (make-pathname :type "system" + :defaults (pathname (component-full-pathname system :source)))) + ) + (values system-def-pathname + (probe-file system-def-pathname))) + (values nil nil)))) + + + + +#| + +(defun compute-system-path (module-name definition-pname) + (let* ((filename (format nil "~A.~A" + (if (symbolp module-name) + (string-downcase (string module-name)) + module-name) + *system-extension*))) + (or (when definition-pname ; given pathname for system def + (probe-file definition-pname)) + ;; Then the central registry. Note that we also check the current + ;; directory in the registry, but the above check is hard-coded. + (cond (*central-registry* + (if (listp *central-registry*) + (dolist (registry *central-registry*) + (let ((file (probe-file + (append-directories (if (consp registry) + (eval registry) + registry) + filename)))) + (when file (return file)))) + (probe-file (append-directories *central-registry* + filename)))) + (t + ;; No central registry. Assume current working directory. + ;; Maybe this should be an error? + (probe-file filename)))))) +|# + + +(defvar *reload-systems-from-disk* t + "If T, always tries to reload newer system definitions from disk. + Otherwise first tries to find the system definition in the current + environment.") + +(defun find-system (system-name &optional (mode :ask) definition-pname) + "Returns the system named SYSTEM-NAME. +If not already loaded, loads it, depending on the value of +*RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK, +:ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default. +This allows OPERATE-ON-SYSTEM to work on non-loaded as well as +loaded system definitions. DEFINITION-PNAME is the pathname for +the system definition, if provided." + (ecase mode + (:ask + (or (get-system system-name) + (when (y-or-n-p-wait + #\y 20 + "System ~A not loaded. Shall I try loading it? " + system-name) + (find-system system-name :load definition-pname)))) + (:error + (or (get-system system-name) + (error 'missing-system :name system-name))) + (:load-or-nil + (let ((system (get-system system-name))) + (or (unless *reload-systems-from-disk* system) + ;; If SYSTEM-NAME is a symbol, it will lowercase the + ;; symbol's string. + ;; If SYSTEM-NAME is a string, it doesn't change the case of the + ;; string. So if case matters in the filename, use strings, not + ;; symbols, wherever the system is named. + (when (foreign-system-p system) + (warn "Foreing system ~S cannot be reloaded by MK:DEFSYSTEM.") + (return-from find-system nil)) + (let ((path (compute-system-path system-name definition-pname))) + (when (and path + (or (null system) + (null (component-load-time path)) + (< (component-load-time path) + (file-write-date path)))) + (tell-user-generic + (format nil "Loading system ~A from file ~A" + system-name + path)) + (load path) + (setf system (get-system system-name)) + (when system + (setf (component-load-time path) + (file-write-date path)))) + system) + system))) + (:load + (or (unless *reload-systems-from-disk* (get-system system-name)) + (when (foreign-system-p (get-system system-name)) + (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM.") + (return-from find-system nil)) + (or (find-system system-name :load-or-nil definition-pname) + (error "Can't find system named ~s." system-name)))))) + + +(defun print-component (component stream depth) + (declare (ignore depth)) + (format stream "#<~:@(~A~): ~A>" + (component-type component) + (component-name component))) + + +(defun describe-system (name &optional (stream *standard-output*)) + "Prints a description of the system to the stream. If NAME is the + name of a system, gets it and prints a description of the system. + If NAME is a component, prints a description of the component." + (let ((system (if (typep name 'component) name (find-system name :load)))) + (format stream "~&~A ~A: ~ + ~@[~& Host: ~A~]~ + ~@[~& Device: ~A~]~ + ~@[~& Package: ~A~]~ + ~& Source: ~@[~A~] ~@[~A~] ~@[~A~]~ + ~& Binary: ~@[~A~] ~@[~A~] ~@[~A~]~ + ~@[~& Depends On: ~A ~]~& Components: ~{~15T~A~&~}" + (component-type system) + (component-name system) + (component-host system) + (component-device system) + (component-package system) + (component-root-dir system :source) + (component-pathname system :source) + (component-extension system :source) + (component-root-dir system :binary) + (component-pathname system :binary) + (component-extension system :binary) + (component-depends-on system) + (component-components system)) + #||(when recursive + (dolist (component (component-components system)) + (describe-system component stream recursive)))||# + system)) + +(defun canonicalize-component-name (component) + ;; Within the component, the name is a string. + (if (typep (component-name component) 'string) + ;; Unnecessary to change it, so just return it, same case + (component-name component) + ;; Otherwise, make it a downcase string -- important since file + ;; names are often constructed from component names, and unix + ;; prefers lowercase as a default. + (setf (component-name component) + (string-downcase (string (component-name component)))))) + +(defun component-pathname (component type) + (when component + (ecase type + (:source (component-source-pathname component)) + (:binary (component-binary-pathname component)) + (:error (component-error-pathname component))))) +(defun component-error-pathname (component) + (let ((binary (component-pathname component :binary))) + (new-file-type binary *compile-error-file-type*))) +(defsetf component-pathname (component type) (value) + `(when ,component + (ecase ,type + (:source (setf (component-source-pathname ,component) ,value)) + (:binary (setf (component-binary-pathname ,component) ,value))))) + +(defun component-root-dir (component type) + (when component + (ecase type + (:source (component-source-root-dir component)) + ((:binary :error) (component-binary-root-dir component)) + ))) +(defsetf component-root-dir (component type) (value) + `(when ,component + (ecase ,type + (:source (setf (component-source-root-dir ,component) ,value)) + (:binary (setf (component-binary-root-dir ,component) ,value))))) + +(defvar *source-pathnames-table* (make-hash-table :test #'equal) + "Table which maps from components to full source pathnames.") +(defvar *binary-pathnames-table* (make-hash-table :test #'equal) + "Table which maps from components to full binary pathnames.") +(defparameter *reset-full-pathname-table* t + "If T, clears the full-pathname tables before each call to + OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance + after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could + result in changes to system and language definitions to not take + effect, and so should be used with caution.") +(defun clear-full-pathname-tables () + (clrhash *source-pathnames-table*) + (clrhash *binary-pathnames-table*)) + +(defun component-full-pathname (component type &optional (version *version*)) + (when component + (case type + (:source + (let ((old (gethash component *source-pathnames-table*))) + (or old + (let ((new (component-full-pathname-i component type version))) + (setf (gethash component *source-pathnames-table*) new) + new)))) + (:binary + (let ((old (gethash component *binary-pathnames-table*))) + (or old + (let ((new (component-full-pathname-i component type version))) + (setf (gethash component *binary-pathnames-table*) new) + new)))) + (otherwise + (component-full-pathname-i component type version))))) + +(defun component-full-pathname-i (component type &optional (version *version*) + &aux version-dir version-replace) + ;; If the pathname-type is :binary and the root pathname is null, + ;; distribute the binaries among the sources (= use :source pathname). + ;; This assumes that the component's :source pathname has been set + ;; before the :binary one. + (if version + (multiple-value-setq (version-dir version-replace) + (translate-version version)) + (setq version-dir *version-dir* version-replace *version-replace*)) + (let ((pathname + (append-directories + (if version-replace + version-dir + (append-directories (component-root-dir component type) + version-dir)) + (component-pathname component type)))) + + ;; When a logical pathname is used, it must first be translated to + ;; a physical pathname. This isn't strictly correct. What should happen + ;; is we fill in the appropriate slots of the logical pathname, and + ;; then return the logical pathname for use by compile-file & friends. + ;; But calling translate-logical-pathname to return the actual pathname + ;; should do for now. + + ;; (format t "pathname = ~A~%" pathname) + ;; (format t "type = ~S~%" (component-extension component type)) + + ;; 20000303 Marco Antoniotti + ;; Changed the following according to suggestion by Ray Toy. I + ;; just collapsed the tests for "logical-pathname-ness" into a + ;; single test (heavy, but probably very portable) and added the + ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES + ;; beacuse of possible null names (e.g. :defsystem components) + ;; causing problems with the subsequenct call to NAMESTRING. + (cond ((pathname-logical-p pathname) ; See definition of test above. + (setf pathname + (merge-pathnames pathname + (make-pathname + :name (component-name component) + :type (component-extension component + type)))) + ;;(format t "new path = ~A~%" pathname) + (namestring (translate-logical-pathname pathname))) + (t + (namestring + (make-pathname :host (when (component-host component) + ;; MCL2.0b1 and ACLPC cause an error on + ;; (pathname-host nil) + (pathname-host (component-host component) + #+scl :case #+scl :common + )) + :directory (pathname-directory pathname + #+scl :case #+scl :common + ) + ;; Use :directory instead of :defaults + :name (pathname-name pathname + #+scl :case #+scl :common + ) + :type #-scl (component-extension component type) + #+scl (string-upcase + (component-extension component type)) + :device + #+sbcl + :unspecific + #-(or :sbcl) + (let ((dev (component-device component))) + (if dev + (pathname-device dev + #+scl :case #+scl :common + ) + (pathname-device pathname + #+scl :case #+scl :common + ))) + ;; :version :newest + )))))) + +;;; What about CMU17 :device :unspecific in the above? + +(defun translate-version (version) + ;; Value returns the version directory and whether it replaces + ;; the entire root (t) or is a subdirectory. + ;; Version may be nil to signify no subdirectory, + ;; a symbol, such as alpha, beta, omega, :alpha, mark, which + ;; specifies a subdirectory of the root, or + ;; a string, which replaces the root. + (cond ((null version) + (values "" nil)) + ((symbolp version) + (values (let ((sversion (string version))) + (if (find-if #'lower-case-p sversion) + sversion + (string-downcase sversion))) + nil)) + ((stringp version) + (values version t)) + (t (error "~&; Illegal version ~S" version)))) + +(defun component-extension (component type &key local) + (ecase type + (:source (or (component-source-extension component) + (unless local + (default-source-extension component)))) ; system default + (:binary (or (component-binary-extension component) + (unless local + (default-binary-extension component)))) ; system default + (:error *compile-error-file-type*))) +(defsetf component-extension (component type) (value) + `(ecase ,type + (:source (setf (component-source-extension ,component) ,value)) + (:binary (setf (component-binary-extension ,component) ,value)) + (:error (setf *compile-error-file-type* ,value)))) + +;;; ******************************** +;;; System Definition ************** +;;; ******************************** +(defun create-component (type name definition-body &optional parent (indent 0)) + (let ((component (apply #'make-component + :type type + :name name + :indent indent definition-body))) + ;; Set up :load-only attribute + (unless (find :load-only definition-body) + ;; If the :load-only attribute wasn't specified, + ;; inherit it from the parent. If no parent, default it to nil. + (setf (component-load-only component) + (when parent + (component-load-only parent)))) + ;; Set up :compile-only attribute + (unless (find :compile-only definition-body) + ;; If the :compile-only attribute wasn't specified, + ;; inherit it from the parent. If no parent, default it to nil. + (setf (component-compile-only component) + (when parent + (component-compile-only parent)))) + + ;; Set up :compiler-options attribute + (unless (find :compiler-options definition-body) + ;; If the :compiler-option attribute wasn't specified, + ;; inherit it from the parent. If no parent, default it to NIL. + (setf (component-compiler-options component) + (when parent + (component-compiler-options parent)))) + + #|| ISI Extension ||# + ;; Set up :load-always attribute + (unless (find :load-always definition-body) + ;; If the :load-always attribute wasn't specified, + ;; inherit it from the parent. If no parent, default it to nil. + (setf (component-load-always component) + (when parent + (component-load-always parent)))) + + ;; Initializations/after makes + (canonicalize-component-name component) + + ;; Inherit package from parent if not specified. + (setf (component-package component) + (or (component-package component) + (when parent (component-package parent)))) + + ;; Type specific setup: + (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) + (setf (get-system name) component)) + + ;; Set up the component's pathname + (create-component-pathnames component parent) + + ;; If there are any components of the component, expand them too. + (expand-component-components component (+ indent 2)) + + ;; Make depends-on refer to structs instead of names. + (link-component-depends-on (component-components component)) + + ;; Design Decision: Topologically sort the dependency graph at + ;; time of definition instead of at time of use. Probably saves a + ;; little bit of time for the user. + + ;; Topological Sort the components at this level. + (setf (component-components component) + (topological-sort (component-components component))) + + ;; Return the component. + component)) + + +;;; defsystem -- +;;; The main macro. +;;; +;;; 2002-11-22 Marco Antoniotti +;;; Added code to achieve a first cut "pathname less" operation, +;;; following the ideas in ASDF. If the DEFSYSTEM form is loaded from +;;; a file, then the location of the file (intended as a directory) is +;;; computed from *LOAD-PATHNAME* and stored as the :SOURCE-PATHNAME +;;; of the system. + +(defmacro defsystem (name &rest definition-body) + (unless (find :source-pathname definition-body) + (setf definition-body + (list* :source-pathname + '(when *load-pathname* + (make-pathname :name nil + :type nil + :defaults *load-pathname*)) + definition-body))) + `(create-component :defsystem ',name ',definition-body nil 0)) + +(defun create-component-pathnames (component parent) + ;; Set up language-specific defaults + (setf (component-language component) + (or (component-language component) ; for local defaulting + (when parent ; parent's default + (component-language parent)))) + (setf (component-compiler component) + (or (component-compiler component) ; for local defaulting + (when parent ; parent's default + (component-compiler parent)))) + (setf (component-loader component) + (or (component-loader component) ; for local defaulting + (when parent ; parent's default + (component-loader parent)))) + + ;; Evaluate the root dir arg + (setf (component-root-dir component :source) + (eval (component-root-dir component :source))) + (setf (component-root-dir component :binary) + (eval (component-root-dir component :binary))) + + ;; Evaluate the pathname arg + (setf (component-pathname component :source) + (eval (component-pathname component :source))) + (setf (component-pathname component :binary) + (eval (component-pathname component :binary))) + + ;; Pass along the host and devices + (setf (component-host component) + (or (component-host component) + (when parent (component-host parent)))) + (setf (component-device component) + (or (component-device component) + (when parent (component-device parent)))) + + ;; Set up extension defaults + (setf (component-extension component :source) + (or (component-extension component :source :local t) ; local default + (when parent ; parent's default + (component-extension parent :source)))) + (setf (component-extension component :binary) + (or (component-extension component :binary :local t) ; local default + (when parent ; parent's default + (component-extension parent :binary)))) + + ;; Set up pathname defaults -- expand with parent + ;; We must set up the source pathname before the binary pathname + ;; to allow distribution of binaries among the sources to work. + (generate-component-pathname component parent :source) + (generate-component-pathname component parent :binary)) + +;; maybe file's inheriting of pathnames should be moved elsewhere? +(defun generate-component-pathname (component parent pathname-type) + ;; Pieces together a pathname for the component based on its component-type. + ;; Assumes source defined first. + ;; Null binary pathnames inherit from source instead of the component's + ;; name. This allows binaries to be distributed among the source if + ;; binary pathnames are not specified. Or if the root directory is + ;; specified for binaries, but no module directories, it inherits + ;; parallel directory structure. + (case (component-type component) + ((:defsystem :system) ; Absolute Pathname + ;; Set the root-dir to be the absolute pathname + (setf (component-root-dir component pathname-type) + (or (component-pathname component pathname-type) + (when (eq pathname-type :binary) + ;; When the binary root is nil, use source. + (component-root-dir component :source))) ) + ;; Set the relative pathname to be nil + (setf (component-pathname component pathname-type) + nil));; should this be "" instead? + ;; If the name of the component-pathname is nil, it + ;; defaults to the name of the component. Use "" to + ;; avoid this defaulting. + (:private-file ; Absolute Pathname + ;; Root-dir is the directory part of the pathname + (setf (component-root-dir component pathname-type) + "" + #+ignore(or (when (component-pathname component pathname-type) + (pathname-directory + (component-pathname component pathname-type))) + (when (eq pathname-type :binary) + ;; When the binary root is nil, use source. + (component-root-dir component :source))) + ) + ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "", + ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could + ;; wind up being "", which is wrong for :file components. So replace + ;; them with NIL. + (when (null-string (component-pathname component pathname-type)) + (setf (component-pathname component pathname-type) nil)) + ;; The relative pathname is the name part + (setf (component-pathname component pathname-type) + (or (when (and (eq pathname-type :binary) + (null (component-pathname component :binary))) + ;; When the binary-pathname is nil use source. + (component-pathname component :source)) + (or (when (component-pathname component pathname-type) +; (pathname-name ) + (component-pathname component pathname-type)) + (component-name component))))) + ((:module :subsystem) ; Pathname relative to parent. + ;; Inherit root-dir from parent + (setf (component-root-dir component pathname-type) + (component-root-dir parent pathname-type)) + ;; Tack the relative-dir onto the pathname + (setf (component-pathname component pathname-type) + (or (when (and (eq pathname-type :binary) + (null (component-pathname component :binary))) + ;; When the binary-pathname is nil use source. + (component-pathname component :source)) + (append-directories + (component-pathname parent pathname-type) + (or (component-pathname component pathname-type) + (component-name component)))))) + (:file ; Pathname relative to parent. + ;; Inherit root-dir from parent + (setf (component-root-dir component pathname-type) + (component-root-dir parent pathname-type)) + ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "", + ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could + ;; wind up being "", which is wrong for :file components. So replace + ;; them with NIL. + (when (null-string (component-pathname component pathname-type)) + (setf (component-pathname component pathname-type) nil)) + ;; Tack the relative-dir onto the pathname + (setf (component-pathname component pathname-type) + (or (append-directories + (component-pathname parent pathname-type) + (or (component-pathname component pathname-type) + (component-name component) + (when (eq pathname-type :binary) + ;; When the binary-pathname is nil use source. + (component-pathname component :source))))))) + )) + +#|| ;; old version +(defun expand-component-components (component &optional (indent 0)) + (let ((definitions (component-components component))) + (setf (component-components component) + (remove-if #'null + (mapcar #'(lambda (definition) + (expand-component-definition definition + component + indent)) + definitions))))) +||# +;; new version +(defun expand-component-components (component &optional (indent 0)) + (let ((definitions (component-components component))) + (if (eq (car definitions) :serial) + (setf (component-components component) + (expand-serial-component-chain (cdr definitions) + component indent)) + (setf (component-components component) + (expand-component-definitions definitions component indent))))) + +(defun expand-component-definitions (definitions parent &optional (indent 0)) + (let ((components nil)) + (dolist (definition definitions) + (let ((new (expand-component-definition definition parent indent))) + (when new (push new components)))) + (nreverse components))) + +(defun expand-serial-component-chain (definitions parent &optional (indent 0)) + (let ((previous nil) + (components nil)) + (dolist (definition definitions) + (let ((new (expand-component-definition definition parent indent))) + (when new + ;; Make this component depend on the previous one. Since + ;; we don't know the form of the definition, we have to + ;; expand it first. + (when previous (pushnew previous (component-depends-on new))) + ;; The dependencies will be linked later, so we use the name + ;; instead of the actual component. + (setq previous (component-name new)) + ;; Save the new component. + (push new components)))) + ;; Return the list of expanded components, in appropriate order. + (nreverse components))) + + +(defparameter *enable-straz-absolute-string-hack* nil + "Special hack requested by Steve Strassman, where the shorthand + that specifies a list of components as a list of strings also + recognizes absolute pathnames and treats them as files of type + :private-file instead of type :file. Defaults to NIL, because I + haven't tested this.") +(defun absolute-file-namestring-p (string) + ;; If a FILE namestring starts with a slash, or is a logical pathname + ;; as implied by the existence of a colon in the filename, assume it + ;; represents an absolute pathname. + (or (find #\: string :test #'char=) + (and (not (null-string string)) + (char= (char string 0) #\/)))) + +(defun expand-component-definition (definition parent &optional (indent 0)) + ;; Should do some checking for malformed definitions here. + (cond ((null definition) nil) + ((stringp definition) + ;; Strings are assumed to be of type :file + (if (and *enable-straz-absolute-string-hack* + (absolute-file-namestring-p definition)) + ;; Special hack for Straz + (create-component :private-file definition nil parent indent) + ;; Normal behavior + (create-component :file definition nil parent indent))) + ((and (listp definition) + (not (member (car definition) + '(:defsystem :system :subsystem + :module :file :private-file)))) + ;; Lists whose first element is not a component type + ;; are assumed to be of type :file + (create-component :file + (car definition) + (cdr definition) + parent + indent)) + ((listp definition) + ;; Otherwise, it is (we hope) a normal form definition + (create-component (car definition) ; type + (cadr definition) ; name + (cddr definition) ; definition body + parent ; parent + indent) ; indent + ))) + +(defun link-component-depends-on (components) + (dolist (component components) + (unless (and *system-dependencies-delayed* + (eq (component-type component) :defsystem)) + (setf (component-depends-on component) + (mapcar #'(lambda (dependency) + (let ((parent (find (string dependency) components + :key #'component-name + :test #'string-equal))) + (cond (parent parent) + ;; make it more intelligent about the following + (t (warn "Dependency ~S of component ~S not found." + dependency component))))) + + (component-depends-on component)))))) + +;;; ******************************** +;;; Topological Sort the Graph ***** +;;; ******************************** + +;;; New version of topological sort suggested by rs2. Even though +;;; this version avoids the call to sort, in practice it isn't faster. It +;;; does, however, eliminate the need to have a TIME slot in the +;;; topological-sort-node defstruct. +(defun topological-sort (list &aux (sorted-list nil)) + (labels ((dfs-visit (znode) + (setf (topsort-color znode) :gray) + (unless (and *system-dependencies-delayed* + (eq (component-type znode) :system)) + (dolist (child (component-depends-on znode)) + (cond ((eq (topsort-color child) :white) + (dfs-visit child)) + ((eq (topsort-color child) :gray) + (format t "~&Detected cycle containing ~A" child))))) + (setf (topsort-color znode) :black) + (push znode sorted-list))) + (dolist (znode list) + (setf (topsort-color znode) :white)) + (dolist (znode list) + (when (eq (topsort-color znode) :white) + (dfs-visit znode))) + (nreverse sorted-list))) + +#|| +;;; Older version of topological sort. +(defun topological-sort (list &aux (time 0)) + ;; The algorithm works by calling depth-first-search to compute the + ;; blackening times for each vertex, and then sorts the vertices into + ;; reverse order by blackening time. + (labels ((dfs-visit (node) + (setf (topsort-color node) 'gray) + (unless (and *system-dependencies-delayed* + (eq (component-type node) :defsystem)) + (dolist (child (component-depends-on node)) + (cond ((eq (topsort-color child) 'white) + (dfs-visit child)) + ((eq (topsort-color child) 'gray) + (format t "~&Detected cycle containing ~A" child))))) + (setf (topsort-color node) 'black) + (setf (topsort-time node) time) + (incf time))) + (dolist (node list) + (setf (topsort-color node) 'white)) + (dolist (node list) + (when (eq (topsort-color node) 'white) + (dfs-visit node))) + (sort list #'< :key #'topsort-time))) +||# + +;;; ******************************** +;;; Output to User ***************** +;;; ******************************** +;;; All output to the user is via the tell-user functions. + +(defun split-string (string &key (item #\space) (test #'char=)) + ;; Splits the string into substrings at spaces. + (let ((len (length string)) + (index 0) result) + (dotimes (i len + (progn (unless (= index len) + (push (subseq string index) result)) + (reverse result))) + (when (funcall test (char string i) item) + (unless (= index i);; two spaces in a row + (push (subseq string index i) result)) + (setf index (1+ i)))))) + +;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it +;; because of an AKCL bug. +;; KGK suggests using an 8 instead, but 1 does nicely. +(defun prompt-string (component) + (format nil "; ~:[~;TEST:~]~V,1@T " + *oos-test* + (component-indent component))) + +#|| +(defun format-justified-string (prompt contents) + (format t (concatenate 'string + "~%" + prompt + "-~{~<~%" prompt " ~1,80:; ~A~>~^~}") + (split-string contents)) + (finish-output *standard-output*)) +||# + +(defun format-justified-string (prompt contents &optional (width 80) + (stream *standard-output*)) + (let ((prompt-length (+ 2 (length prompt)))) + (cond ((< (+ prompt-length (length contents)) width) + (format stream "~%~A- ~A" prompt contents)) + (t + (format stream "~%~A-" prompt) + (do* ((cursor prompt-length) + (contents (split-string contents) (cdr contents)) + (content (car contents) (car contents)) + (content-length (1+ (length content)) (1+ (length content)))) + ((null contents)) + (cond ((< (+ cursor content-length) width) + (incf cursor content-length) + (format stream " ~A" content)) + (t + (setf cursor (+ prompt-length content-length)) + (format stream "~%~A ~A" prompt content))))))) + (finish-output stream)) + +(defun tell-user (what component &optional type no-dots force) + (when (or *oos-verbose* force) + (format-justified-string (prompt-string component) + (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]" + ;; To have better messages, wrap the following around the + ;; case statement: + ;;(if (find (component-type component) + ;; '(:defsystem :system :subsystem :module)) + ;; "Checking" + ;; (case ...)) + ;; This gets around the problem of DEFSYSTEM reporting + ;; that it's loading a module, when it eventually never + ;; loads any of the files of the module. + (case what + ((compile :compile) + (if (component-load-only component) + ;; If it is :load-only t, we're loading. + "Loading" + ;; Otherwise we're compiling. + "Compiling")) + ((load :load) "Loading") + (otherwise what)) + (component-type component) + (or (when type + (component-full-pathname component type)) + (component-name component)) + (and *tell-user-when-done* + (not no-dots)))))) + +(defun tell-user-done (component &optional force no-dots) + ;; test is no longer really used, but we're leaving it in. + (when (and *tell-user-when-done* + (or *oos-verbose* force)) + (format t "~&~A~:[~;...~] Done." + (prompt-string component) (not no-dots)) + (finish-output *standard-output*))) + +(defmacro with-tell-user ((what component &optional type no-dots force) &body body) + `(progn + (tell-user ,what ,component ,type ,no-dots ,force) + ,@body + (tell-user-done ,component ,force ,no-dots))) + +(defun tell-user-no-files (component &optional force) + (when (or *oos-verbose* force) + (format-justified-string (prompt-string component) + (format nil "Source file ~A ~ + ~:[and binary file ~A ~;~]not found, not loading." + (component-full-pathname component :source) + (or *load-source-if-no-binary* *load-source-instead-of-binary*) + (component-full-pathname component :binary))))) + +(defun tell-user-require-system (name parent) + (when *oos-verbose* + (format t "~&; ~:[~;TEST:~] - System ~A requires ~S" + *oos-test* (component-name parent) name) + (finish-output *standard-output*))) + +(defun tell-user-generic (string) + (when *oos-verbose* + (format t "~&; ~:[~;TEST:~] - ~A" + *oos-test* string) + (finish-output *standard-output*))) + +;;; ******************************** +;;; Y-OR-N-P-WAIT ****************** +;;; ******************************** +;;; Y-OR-N-P-WAIT is like Y-OR-N-P, but will timeout after a specified +;;; number of seconds. I should really replace this with a call to +;;; the Y-OR-N-P-WAIT defined in the query.cl package and include that +;;; instead. + +(defparameter *use-timeouts* t + "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves + like Y-OR-N-P. This is provided for users whose lisps don't handle + read-char-no-hang properly.") + +(defparameter *clear-input-before-query* t + "If T, y-or-n-p-wait will clear the input before printing the prompt + and asking the user for input.") + +;;; The higher *sleep-amount* is, the less consing, but the lower the +;;; responsiveness. +(defparameter *sleep-amount* #-CMU 0.1 #+CMU 1.0 + "Amount of time to sleep between checking query-io. In multiprocessing + Lisps, this allows other processes to continue while we busy-wait. If + 0, skips call to SLEEP.") + +(defun internal-real-time-in-seconds () + (get-universal-time)) + +(defun read-char-wait (&optional (timeout 20) input-stream + (eof-error-p t) eof-value + &aux peek) + (do ((start (internal-real-time-in-seconds))) + ((or (setq peek (listen input-stream)) + (< (+ start timeout) (internal-real-time-in-seconds))) + (when peek + ;; was read-char-no-hang + (read-char input-stream eof-error-p eof-value))) + (unless (zerop *sleep-amount*) + (sleep *sleep-amount*)))) + +;;; Lots of lisps, especially those that run on top of UNIX, do not get +;;; their input one character at a time, but a whole line at a time because +;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait +;;; to not always work as expected. +;;; +;;; I wish lisp did all its own buffering (turning off UNIX input line +;;; buffering by putting the UNIX into CBREAK mode). Of course, this means +;;; that we lose input editing, but why can't the lisp implement this? + +(defun y-or-n-p-wait (&optional (default #\y) (timeout 20) + format-string &rest args) + "Y-OR-N-P-WAIT prints the message, if any, and reads characters from + *QUERY-IO* until the user enters y, Y or space as an affirmative, or either + n or N as a negative answer, or the timeout occurs. It asks again if + you enter any other characters." + (when *clear-input-before-query* (clear-input *query-io*)) + (when format-string + (fresh-line *query-io*) + (apply #'format *query-io* format-string args) + ;; FINISH-OUTPUT needed for CMU and other places which don't handle + ;; output streams nicely. This prevents it from continuing and + ;; reading the query until the prompt has been printed. + (finish-output *query-io*)) + (loop + (let* ((read-char (if *use-timeouts* + (read-char-wait timeout *query-io* nil nil) + (read-char *query-io*))) + (char (or read-char default))) + ;; We need to ignore #\newline because otherwise the bugs in + ;; clear-input will cause y-or-n-p-wait to print the "Type ..." + ;; message every time... *sigh* + ;; Anyway, we might want to use this to ignore whitespace once + ;; clear-input is fixed. + (unless (find char '(#\tab #\newline #\return)) + (when (null read-char) + (format *query-io* "~@[~A~]" default) + (finish-output *query-io*)) + (cond ((null char) (return t)) + ((find char '(#\y #\Y #\space) :test #'char=) (return t)) + ((find char '(#\n #\N) :test #'char=) (return nil)) + (t + (when *clear-input-before-query* (clear-input *query-io*)) + (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ") + (when format-string + (fresh-line *query-io*) + (apply #'format *query-io* format-string args)) + (finish-output *query-io*))))))) + +#|| +(y-or-n-p-wait #\y 20 "What? ") +(progn (format t "~&hi") (finish-output) + (y-or-n-p-wait #\y 10 "1? ") + (y-or-n-p-wait #\n 10 "2? ")) +||# +;;; ******************************** +;;; Operate on System ************** +;;; ******************************** +;;; Operate-on-system +;;; Operation is :compile, 'compile, :load or 'load +;;; Force is :all or :new-source or :new-source-and-dependents or a list of +;;; specific modules. +;;; :all (or T) forces a recompilation of every file in the system +;;; :new-source-and-dependents compiles only those files whose +;;; sources have changed or who depend on recompiled files. +;;; :new-source compiles only those files whose sources have changed +;;; A list of modules means that only those modules and their +;;; dependents are recompiled. +;;; Test is T to print out what it would do without actually doing it. +;;; Note: it automatically sets verbose to T if test is T. +;;; Verbose is T to print out what it is doing (compiling, loading of +;;; modules and files) as it does it. +;;; Dribble should be the pathname of the dribble file if you want to +;;; dribble the compilation. +;;; Load-source-instead-of-binary is T to load .lisp instead of binary files. +;;; Version may be nil to signify no subdirectory, +;;; a symbol, such as alpha, beta, omega, :alpha, mark, which +;;; specifies a subdirectory of the root, or +;;; a string, which replaces the root. + +(defun operate-on-system (name operation + &key + force + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + (load-source-instead-of-binary + *load-source-instead-of-binary*) + (load-source-if-no-binary + *load-source-if-no-binary*) + (bother-user-if-no-binary + *bother-user-if-no-binary*) + (compile-during-load *compile-during-load*) + dribble + (minimal-load *minimal-load*) + (override-compilation-unit t) + ) + (declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit)) + (unwind-protect + ;; Protect the undribble. + (#+(or :cltl2 :ansi-cl) with-compilation-unit + #+(or :cltl2 :ansi-cl) (:override override-compilation-unit) + #-(or :cltl2 :ansi-cl) progn + (when *reset-full-pathname-table* (clear-full-pathname-tables)) + (when dribble (dribble dribble)) + (when test (setq verbose t)) + (when (null force) ; defaults + (case operation + ((load :load) (setq force :all)) + ((compile :compile) (setq force :new-source-and-dependents)) + (t (setq force :all)))) + ;; Some CL implementations have a variable called *compile-verbose* + ;; or *compile-file-verbose*. + (multiple-value-bind (*version-dir* *version-replace*) + (translate-version version) + ;; CL implementations may uniformly default this to nil + (let ((*load-verbose* #-common-lisp-controller t + #+common-lisp-controller nil) ; nil + #-(or MCL CMU CLISP ECL :sbcl lispworks scl) + (*compile-file-verbose* t) ; nil + #+common-lisp-controller + (*compile-print* nil) + #+(and common-lisp-controller cmu) + (ext:*compile-progress* nil) + #+(and common-lisp-controller cmu) + (ext:*require-verbose* nil) + #+(and common-lisp-controller cmu) + (ext:*gc-verbose* nil) + + (*compile-verbose* #-common-lisp-controller t + #+common-lisp-controller nil) ; nil + (*version* version) + (*oos-verbose* verbose) + (*oos-test* test) + (*load-source-if-no-binary* load-source-if-no-binary) + (*compile-during-load* compile-during-load) + (*bother-user-if-no-binary* bother-user-if-no-binary) + (*load-source-instead-of-binary* load-source-instead-of-binary) + (*minimal-load* minimal-load) + (system (if (and (component-p name) + (member (component-type name) '(:system :defsystem :subsystem))) + name + (find-system name :load)))) + #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl) + (declare (special *compile-verbose* #-MCL *compile-file-verbose*) + #-openmcl (ignore *compile-verbose* + #-MCL *compile-file-verbose*) + #-openmcl (optimize (inhibit-warnings 3))) + (unless (component-operation operation) + (error "Operation ~A undefined." operation)) + (operate-on-component system operation force)))) + (when dribble (dribble)))) + + +(defun compile-system (name &key force + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + (load-source-instead-of-binary + *load-source-instead-of-binary*) + (load-source-if-no-binary + *load-source-if-no-binary*) + (bother-user-if-no-binary + *bother-user-if-no-binary*) + (compile-during-load *compile-during-load*) + dribble + (minimal-load *minimal-load*)) + ;; For users who are confused by OOS. + (operate-on-system + name :compile + :force force + :version version + :test test + :verbose verbose + :load-source-instead-of-binary load-source-instead-of-binary + :load-source-if-no-binary load-source-if-no-binary + :bother-user-if-no-binary bother-user-if-no-binary + :compile-during-load compile-during-load + :dribble dribble + :minimal-load minimal-load)) + +(defun load-system (name &key force + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + (load-source-instead-of-binary + *load-source-instead-of-binary*) + (load-source-if-no-binary *load-source-if-no-binary*) + (bother-user-if-no-binary *bother-user-if-no-binary*) + (compile-during-load *compile-during-load*) + dribble + (minimal-load *minimal-load*)) + ;; For users who are confused by OOS. + (operate-on-system + name :load + :force force + :version version + :test test + :verbose verbose + :load-source-instead-of-binary load-source-instead-of-binary + :load-source-if-no-binary load-source-if-no-binary + :bother-user-if-no-binary bother-user-if-no-binary + :compile-during-load compile-during-load + :dribble dribble + :minimal-load minimal-load)) + +(defun clean-system (name &key (force :all) + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + dribble) + "Deletes all the binaries in the system." + ;; For users who are confused by OOS. + (operate-on-system + name :delete-binaries + :force force + :version version + :test test + :verbose verbose + :dribble dribble)) + +(defun edit-system + (name &key force + (version *version*) + (test *oos-test*) + (verbose *oos-verbose*) + dribble) + + (operate-on-system + name :edit + :force force + :version version + :test test + :verbose verbose + :dribble dribble)) + +(defun hardcopy-system + (name &key force + (version *version*) + (test *oos-test*) + (verbose *oos-verbose*) + dribble) + + (operate-on-system + name :hardcopy + :force force + :version version + :test test + :verbose verbose + :dribble dribble)) + +(defun operate-on-component (component operation force &aux changed) + ;; Returns T if something changed and had to be compiled. + (let ((type (component-type component)) + (old-package (package-name *package*))) + + (unwind-protect + ;; Protect old-package. + (progn + ;; Use the correct package. + (when (component-package component) + (tell-user-generic (format nil "Using package ~A" + (component-package component))) + (unless *oos-test* + (unless (find-package (component-package component)) + ;; If the package name is the same as the name of the system, + ;; and the package is not defined, this would lead to an + ;; infinite loop, so bomb out with an error. + (when (string-equal (string (component-package component)) + (component-name component)) + (format t "~%Component ~A not loaded:~%" + (component-name component)) + (error " Package ~A is not defined" + (component-package component))) + ;; If package not found, try using REQUIRE to load it. + (new-require (component-package component))) + ;; This was USE-PACKAGE, but should be IN-PACKAGE. + ;; Actually, CLtL2 lisps define in-package as a macro, + ;; so we'll set the package manually. + ;; (in-package (component-package component)) + (let ((package (find-package (component-package component)))) + (when package + (setf *package* package))))) + #+mk-original + (when (eq type :defsystem) ; maybe :system too? + (operate-on-system-dependencies component operation force)) + (when (or (eq type :defsystem) (eq type :system)) + (operate-on-system-dependencies component operation force)) + + ;; Do any compiler proclamations + (when (component-proclamations component) + (tell-user-generic (format nil "Doing proclamations for ~A" + (component-name component))) + (or *oos-test* + (proclaim (component-proclamations component)))) + + ;; Do any initial actions + (when (component-initially-do component) + (tell-user-generic (format nil "Doing initializations for ~A" + (component-name component))) + (or *oos-test* + (eval (component-initially-do component)))) + + ;; If operation is :compile and load-only is T, this would change + ;; the operation to load. Only, this would mean that a module would + ;; be considered to have changed if it was :load-only and had to be + ;; loaded, and then dependents would be recompiled -- this doesn't + ;; seem right. So instead, we propagate the :load-only attribute + ;; to the components, and modify compile-file-operation so that + ;; it won't compile the files (and modify tell-user to say "Loading" + ;; instead of "Compiling" for load-only modules). + #|| + (when (and (find operation '(:compile compile)) + (component-load-only component)) + (setf operation :load)) + ||# + + ;; Do operation and set changed flag if necessary. + (setq changed + (case type + ((:file :private-file) + (funcall (component-operation operation) component force)) + ((:module :system :subsystem :defsystem) + (operate-on-components component operation force changed)))) + + ;; Do any final actions + (when (component-finally-do component) + (tell-user-generic (format nil "Doing finalizations for ~A" + (component-name component))) + (or *oos-test* + (eval (component-finally-do component)))) + + ;; add the banner if needed + #+(or cmu scl) + (when (component-banner component) + (unless (stringp (component-banner component)) + (error "The banner should be a string, it is: ~S" + (component-banner component))) + (setf (getf ext:*herald-items* + (intern (string-upcase (component-name component)) + (find-package :keyword))) + (list + (component-banner component))))) + + ;; Reset the package. (Cleanup form of unwind-protect.) + ;;(in-package old-package) + (setf *package* (find-package old-package))) + + ;; Provide the loaded system + (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) + (tell-user-generic (format nil "Providing system ~A~%" + (component-name component))) + (or *oos-test* + (provide (canonicalize-system-name (component-name component)))))) + + ;; Return non-NIL if something changed in this component and hence had + ;; to be recompiled. This is only used as a boolean. + changed) + +(defvar *force* nil) +(defvar *providing-blocks-load-propagation* t + "If T, if a system dependency exists on *modules*, it is not loaded.") + +(defun operate-on-system-dependencies (component operation &optional force) + (when *system-dependencies-delayed* + (let ((*force* force)) + (dolist (system (component-depends-on component)) + ;; For each system that this system depends on, if it is a + ;; defined system (either via defsystem or component type :system), + ;; and propagation is turned on, propagates the operation to the + ;; subsystem. Otherwise runs require (my version) on that system + ;; to load it (needed since we may be depending on a lisp + ;; dependent package). + ;; Explores the system tree in a DFS manner. + (cond ((and *operations-propagate-to-subsystems* + (not (listp system)) + ;; The subsystem is a defined system. + (find-system system :load-or-nil)) + ;; Call OOS on it. Since *system-dependencies-delayed* is + ;; T, the :depends-on slot is filled with the names of + ;; systems, not defstructs. + ;; Aside from system, operation, force, for everything else + ;; we rely on the globals. + (unless (and *providing-blocks-load-propagation* + ;; If *providing-blocks-load-propagation* is T, + ;; the system dependency must not exist in the + ;; *modules* for it to be loaded. Note that + ;; the dependencies are implicitly systems. + (find operation '(load :load)) + ;; (or (eq force :all) (eq force t)) + (find (canonicalize-system-name system) + *modules* :test #'string-equal)) + + (operate-on-system system operation :force force))) + + ((listp system) + ;; If the SYSTEM is a list then its contents are as follows. + ;; + ;; ( ) + ;; + (tell-user-require-system + (cond ((and (null (first system)) (null (second system))) + (third system)) + (t system)) + component) + (or *oos-test* (new-require (first system) + nil + (eval (second system)) + (third system) + (or (fourth system) + *version*)))) + (t + (tell-user-require-system system component) + (or *oos-test* (new-require system)))))))) + +;;; Modules can depend only on siblings. If a module should depend +;;; on an uncle, then the parent module should depend on that uncle +;;; instead. Likewise a module should depend on a sibling, not a niece +;;; or nephew. Modules also cannot depend on cousins. Modules cannot +;;; depend on parents, since that is circular. + +(defun module-depends-on-changed (module changed) + (dolist (dependent (component-depends-on module)) + (when (member dependent changed) + (return t)))) + +(defun operate-on-components (component operation force changed) + (with-tell-user (operation component) + (if (component-components component) + (dolist (module (component-components component)) + (when (operate-on-component module operation + (cond ((and (module-depends-on-changed module changed) + #||(some #'(lambda (dependent) + (member dependent changed)) + (component-depends-on module))||# + (or (non-empty-listp force) + (eq force :new-source-and-dependents))) + ;; The component depends on a changed file + ;; and force agrees. + (if (eq force :new-source-and-dependents) + :new-source-all + :all)) + ((and (non-empty-listp force) + (member (component-name module) force + :test #'string-equal :key #'string)) + ;; Force is a list of modules + ;; and the component is one of them. + :all) + (t force))) + (push module changed))) + (case operation + ((compile :compile) + (eval (component-compile-form component))) + ((load :load) + (eval (component-load-form component)))))) + ;; This is only used as a boolean. + changed) + +;;; ******************************** +;;; New Require ******************** +;;; ******************************** + +;;; This needs cleaning. Obviously the code is a left over from the +;;; time people did not know how to use packages in a proper way or +;;; CLs were shaky in their implementation. + +;;; First of all we need this. (Commented out for the time being) +;;; (shadow '(cl:require)) + + +(defvar *old-require* nil) + +;;; All calls to require in this file have been replaced with calls +;;; to new-require to avoid compiler warnings and make this less of +;;; a tangled mess. + +(defun new-require (module-name + &optional + pathname + definition-pname + default-action + (version *version*)) + ;; If the pathname is present, this behaves like the old require. + (unless (and module-name + (find (string module-name) + *modules* :test #'string=)) + (handler-case + (cond (pathname + (funcall *old-require* module-name pathname)) + ;; If the system is defined, load it. + ((find-system module-name :load-or-nil definition-pname) + (operate-on-system + module-name :load + :force *force* + :version version + :test *oos-test* + :verbose *oos-verbose* + :load-source-if-no-binary *load-source-if-no-binary* + :bother-user-if-no-binary *bother-user-if-no-binary* + :compile-during-load *compile-during-load* + :load-source-instead-of-binary *load-source-instead-of-binary* + :minimal-load *minimal-load*)) + ;; If there's a default action, do it. This could be a progn which + ;; loads a file that does everything. + ((and default-action + (eval default-action))) + ;; If no system definition file, try regular require. + ;; had last arg PATHNAME, but this wasn't really necessary. + ((funcall *old-require* module-name)) + ;; If no default action, print a warning or error message. + (t + #|| + (format t "~&Warning: System ~A doesn't seem to be defined..." + module-name) + ||# + (error 'missing-system :name module-name))) + (missing-module (mmc) (signal mmc)) ; Resignal. + (error (e) + (declare (ignore e)) + ;; Signal a (maybe wrong) MISSING-SYSTEM. + (error 'missing-system :name module-name))) + )) + + +;;; Note that in some lisps, when the compiler sees a REQUIRE form at +;;; top level it immediately executes it. This is as if an +;;; (eval-when (compile load eval) ...) were wrapped around the REQUIRE +;;; form. I don't see any easy way to do this without making REQUIRE +;;; a macro. +;;; +;;; For example, in VAXLisp, if a (require 'streams) form is at the top of +;;; a file in the system, compiling the system doesn't wind up loading the +;;; streams module. If the (require 'streams) form is included within an +;;; (eval-when (compile load eval) ...) then everything is OK. +;;; +;;; So perhaps we should replace the redefinition of lisp:require +;;; with the following macro definition: +#|| +(unless *old-require* + (setf *old-require* + (symbol-function #-(or :lispworks + :sbcl + (and :excl :allegro-v4.0)) 'lisp:require + #+:sbcl 'cl:require + #+:lispworks 'system:::require + #+(and :excl :allegro-v4.0) 'cltl1:require)) + + (let (#+(or :CCL :openmcl) (ccl:*warn-if-redefine-kernel* nil)) + ;; Note that lots of lisps barf if we redefine a function from + ;; the LISP package. So what we do is define a macro with an + ;; unused name, and use (setf macro-function) to redefine + ;; lisp:require without compiler warnings. If the lisp doesn't + ;; do the right thing, try just replacing require-as-macro + ;; with lisp:require. + (defmacro require-as-macro (module-name + &optional pathname definition-pname + default-action (version '*version*)) + `(eval-when (compile load eval) + (new-require ,module-name ,pathname ,definition-pname + ,default-action ,version))) + (setf (macro-function #-(and :excl :sbcl :allegro-v4.0) 'lisp:require + #+:sbcl 'cl:require + #+(and :excl :allegro-v4.0) 'cltl1:require) + (macro-function 'require-as-macro)))) +||# +;;; This will almost certainly fix the problem, but will cause problems +;;; if anybody does a funcall on #'require. + +;;; Redefine old require to call the new require. +(eval-when #-(or :lucid) (:load-toplevel :execute) + #+(or :lucid) (load eval) +(unless *old-require* + (setf *old-require* + (symbol-function + #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require + #+(and :excl :allegro-v4.0) 'cltl1:require + #+:sbcl 'cl:require + #+:lispworks3.1 'common-lisp::require + #+(and :lispworks (not :lispworks3.1)) 'system::require + #+:openmcl 'cl:require + #+(and :mcl (not :openmcl)) 'ccl:require + )) + + (unless *dont-redefine-require* + (let (#+(or :mcl :openmcl (and :CCL (not :lispworks))) + (ccl:*warn-if-redefine-kernel* nil)) + #-(or (and allegro-version>= (version>= 4 1)) :lispworks) + (setf (symbol-function + #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require + #+(and :excl :allegro-v4.0) 'cltl1:require + #+:lispworks3.1 'common-lisp::require + #+:sbcl 'cl:require + #+(and :lispworks (not :lispworks3.1)) 'system::require + #+:openmcl 'cl:require + #+(and :mcl (not :openmcl)) 'ccl:require + ) + (symbol-function 'new-require)) + #+:lispworks + (let ((warn-packs system::*packages-for-warn-on-redefinition*)) + (declare (special system::*packages-for-warn-on-redefinition*)) + (setq system::*packages-for-warn-on-redefinition* nil) + (setf (symbol-function + #+:lispworks3.1 'common-lisp::require + #-:lispworks3.1 'system::require + ) + (symbol-function 'new-require)) + (setq system::*packages-for-warn-on-redefinition* warn-packs)) + #+(and allegro-version>= (version>= 4 1)) + (excl:without-package-locks + (setf (symbol-function 'lisp:require) + (symbol-function 'new-require)))))) +) + +;;; ******************************** +;;; Language-Dependent Characteristics +;;; ******************************** +;;; This section is used for defining language-specific behavior of +;;; defsystem. If the user changes a language definition, it should +;;; take effect immediately -- they shouldn't have to reload the +;;; system definition file for the changes to take effect. + +(defvar *language-table* (make-hash-table :test #'equal) + "Hash table that maps from languages to language structures.") +(defun find-language (name) + (gethash name *language-table*)) + +(defstruct (language (:print-function print-language)) + name ; The name of the language (a keyword) + compiler ; The function used to compile files in the language + loader ; The function used to load files in the language + source-extension ; Filename extensions for source files + binary-extension ; Filename extensions for binary files +) + +(defun print-language (language stream depth) + (declare (ignore depth)) + (format stream "#<~:@(~A~): ~A ~A>" + (language-name language) + (language-source-extension language) + (language-binary-extension language))) + +(defun compile-function (component) + (or (component-compiler component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (when language (language-compiler language))) + #'compile-file)) + +(defun load-function (component) + (or (component-loader component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (when language (language-loader language))) + #'load)) + +(defun default-source-extension (component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (or (when language (language-source-extension language)) + (car *filename-extensions*)))) + +(defun default-binary-extension (component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (or (when language (language-binary-extension language)) + (cdr *filename-extensions*)))) + +(defmacro define-language (name &key compiler loader + source-extension binary-extension) + (let ((language (gensym "LANGUAGE"))) + `(let ((,language (make-language :name ,name + :compiler ,compiler + :loader ,loader + :source-extension ,source-extension + :binary-extension ,binary-extension))) + (setf (gethash ,name *language-table*) ,language) + ,name))) + +#|| +;;; Test System for verifying multi-language capabilities. +(defsystem foo + :language :lisp + :components ((:module c :language :c :components ("foo" "bar")) + (:module lisp :components ("baz" "barf")))) + +||# + +;;; *** Lisp Language Definition +(define-language :lisp + :compiler #'compile-file + :loader #'load + :source-extension (car *filename-extensions*) + :binary-extension (cdr *filename-extensions*)) + +;;; *** PseudoScheme Language Definition +(defun scheme-compile-file (filename &rest args) + (let ((scheme-package (find-package '#:scheme))) + (apply (symbol-function (find-symbol (symbol-name 'compile-file) + scheme-package)) + filename + (funcall (symbol-function + (find-symbol (symbol-name '#:interaction-environment) + scheme-package))) + args))) + +(define-language :scheme + :compiler #'scheme-compile-file + :loader #'load + :source-extension "scm" + :binary-extension "bin") + +;;; *** C Language Definition + +;;; This is very basic. Somebody else who needs it can add in support +;;; for header files, libraries, different C compilers, etc. For example, +;;; we might add a COMPILER-OPTIONS slot to the component defstruct. + +(defparameter *c-compiler* "gcc") +#-(or symbolics (and :lispworks :harlequin-pc-lisp )) + +(defun run-unix-program (program arguments) + ;; arguments should be a list of strings, where each element is a + ;; command-line option to send to the program. + #+:lucid (run-program program :arguments arguments) + #+:allegro (excl:run-shell-command + (format nil "~A~@[ ~{~A~^ ~}~]" + program arguments)) + #+(or :kcl :ecl) (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments)) + #+(or :cmu :scl) (extensions:run-program program arguments) + #+:openmcl (ccl:run-program program arguments) + #+:sbcl (sb-ext:run-program program arguments) + #+:lispworks (foreign:call-system-showing-output + (format nil "~A~@[ ~{~A~^ ~}~]" program arguments)) + #+clisp (#+lisp=cl ext:run-program #-lisp=cl lisp:run-program + program :arguments arguments) + ) + +#+(or symbolics (and :lispworks :harlequin-pc-lisp)) +(defun run-unix-program (program arguments) + (declare (ignore program arguments)) + (error "MK::RUN-UNIX-PROGRAM: this does not seem to be a UN*X system.") + ) + +#|| +(defun c-compile-file (filename &rest args &key output-file error-file) + ;; gcc -c foo.c -o foo.o + (declare (ignore args)) + (run-unix-program *c-compiler* + (format nil "-c ~A~@[ -o ~A~]" + filename + output-file))) +||# + +#|| +(defun c-compile-file (filename &rest args &key output-file error-file) + ;; gcc -c foo.c -o foo.o + (declare (ignore args error-file)) + (run-unix-program *c-compiler* + `("-c" ,filename ,@(if output-file `("-o" ,output-file))))) +||# + + +;;; The following code was inserted to improve C compiler support (at +;;; least under Linux/GCC). +;;; Thanks to Espen S Johnsen. +;;; +;;; 20001118 Marco Antoniotti. + +(defun default-output-pathname (path1 path2 type) + (if (eq path1 t) + (translate-logical-pathname + (merge-pathnames (make-pathname :type type) (pathname path2))) + (translate-logical-pathname (pathname path1)))) + + +(defun run-compiler (program + arguments + output-file + error-file + error-output + verbose) + #-(or cmu scl) (declare (ignore error-file error-output)) + + (flet ((make-useable-stream (&rest streams) + (apply #'make-broadcast-stream (delete nil streams))) + ) + (let (#+(or cmu scl) (error-file error-file) + #+(or cmu scl) (error-file-stream nil) + (verbose-stream nil) + (old-timestamp (file-write-date output-file)) + (fatal-error nil) + (output-file-written nil) + ) + (unwind-protect + (progn + #+(or cmu scl) + (setf error-file + (when error-file + (default-output-pathname error-file + output-file + *compile-error-file-type*)) + + error-file-stream + (and error-file + (open error-file + :direction :output + :if-exists :supersede))) + + (setf verbose-stream + (make-useable-stream + #+cmu error-file-stream + (and verbose *trace-output*))) + + (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%" + program + arguments) + + (setf fatal-error + #-(or cmu scl) + (and (run-unix-program program arguments) nil) ; Incomplete. + #+(or cmu scl) + (let* ((error-output + (make-useable-stream error-file-stream + (if (eq error-output t) + *error-output* + error-output))) + (process + (ext:run-program program arguments + :error error-output))) + (not (zerop (ext:process-exit-code process))))) + + (setf output-file-written + (and (probe-file output-file) + (not (eql old-timestamp + (file-write-date output-file))))) + + + (when output-file-written + (format verbose-stream "~A written~%" output-file)) + (format verbose-stream "Running of ~A finished~%" + program) + (values (and output-file-written output-file) + fatal-error + fatal-error)) + + #+(or cmu scl) + (when error-file + (close error-file-stream) + (unless (or fatal-error (not output-file-written)) + (delete-file error-file))) + + (values (and output-file-written output-file) + fatal-error + fatal-error))))) + + +(defun c-compile-file (filename &rest args + &key + (output-file t) + (error-file t) + (error-output t) + (verbose *compile-verbose*) + debug + link + optimize + cflags + definitions + include-paths + library-paths + libraries + (error t)) + (declare (ignore args)) + + (flet ((map-options (flag options &optional (func #'identity)) + (mapcar #'(lambda (option) + (format nil "~A~A" flag (funcall func option))) + options)) + ) + (let* ((output-file (default-output-pathname output-file filename "o")) + (arguments + `(,@(when (not link) '("-c")) + ,@(when debug '("-g")) + ,@(when optimize (list (format nil "-O~D" optimize))) + ,@cflags + ,@(map-options + "-D" definitions + #'(lambda (definition) + (if (atom definition) + definition + (apply #'format nil "~A=~A" definition)))) + ,@(map-options "-I" include-paths #'truename) + ,(namestring (truename filename)) + "-o" + ,(namestring (translate-logical-pathname output-file)) + ,@(map-options "-L" library-paths #'truename) + ,@(map-options "-l" libraries)))) + + (multiple-value-bind (output-file warnings fatal-errors) + (run-compiler *c-compiler* + arguments + output-file + error-file + error-output + verbose) + (if (and error (or (not output-file) fatal-errors)) + (error "Compilation failed") + (values output-file warnings fatal-errors)))))) + + +(define-language :c + :compiler #'c-compile-file + :loader #+:lucid #'load-foreign-files + #+:allegro #'load + #+(or :cmu :scl) #'alien:load-foreign + #+:sbcl #'sb-alien:load-foreign + #+(and :lispworks :unix (not :linux)) #'link-load:read-foreign-modules + #+(and :lispworks (or (not :unix) :linux)) #'fli:register-module + #+(or :ecl :gcl :kcl) #'load ; should be enough. + #-(or :lucid + :allegro + :cmu + :sbcl + :scl + :lispworks + :ecl :gcl :kcl) + (lambda (&rest args) + (declare (ignore args)) + (cerror "Continue returning NIL." + "Loader not defined for C foreign libraries in ~A ~A." + (lisp-implementation-type) + (lisp-implementation-version))) + :source-extension "c" + :binary-extension "o") + +#|| +;;; FDMM's changes, which we've replaced. +(defvar *compile-file-function* #'cl-compile-file) + +#+(or :clos :pcl) +(defmethod set-language ((lang (eql :common-lisp))) + (setq *compile-file-function* #'cl-compile-file)) + +#+(or :clos :pcl) +(defmethod set-language ((lang (eql :scheme))) + (setq *compile-file-function #'scheme-compile-file)) +||# + +;;; ******************************** +;;; Component Operations *********** +;;; ******************************** +;;; Define :compile/compile and :load/load operations +(eval-when (load eval) +(component-operation :compile 'compile-and-load-operation) +(component-operation 'compile 'compile-and-load-operation) +(component-operation :load 'load-file-operation) +(component-operation 'load 'load-file-operation) +) + +(defun compile-and-load-operation (component force) + ;; FORCE was CHANGED. this caused defsystem during compilation to only + ;; load files that it immediately compiled. + (let ((changed (compile-file-operation component force))) + ;; Return T if the file had to be recompiled and reloaded. + (if (and changed (component-compile-only component)) + ;; For files which are :compile-only T, compiling the file + ;; satisfies the need to load. + changed + ;; If the file wasn't compiled, or :compile-only is nil, + ;; check to see if it needs to be loaded. + (and (load-file-operation component force) ; FORCE was CHANGED ??? + changed)))) + +(defun unmunge-lucid (namestring) + ;; Lucid's implementation of COMPILE-FILE is non-standard, in that + ;; when the :output-file is a relative pathname, it tries to munge + ;; it with the directory of the source file. For example, + ;; (compile-file "src/globals.lisp" :output-file "bin/globals.sbin") + ;; tries to stick the file in "./src/bin/globals.sbin" instead of + ;; "./bin/globals.sbin" like any normal lisp. This hack seems to fix the + ;; problem. I wouldn't have expected this problem to occur with any + ;; use of defsystem, but some defsystem users are depending on + ;; using relative pathnames (at least three folks reported the problem). + (cond ((null-string namestring) namestring) + ((char= (char namestring 0) #\/) + ;; It's an absolute namestring + namestring) + (t + ;; Ugly, but seems to fix the problem. + (concatenate 'string "./" namestring)))) + +(defun compile-file-operation (component force) + ;; Returns T if the file had to be compiled. + (let ((must-compile + ;; For files which are :load-only T, loading the file + ;; satisfies the demand to recompile. + (and (null (component-load-only component)) ; not load-only + (or (find force '(:all :new-source-all t) :test #'eq) + (and (find force '(:new-source :new-source-and-dependents) + :test #'eq) + (needs-compilation component))))) + (source-pname (component-full-pathname component :source))) + + (cond ((and must-compile (probe-file source-pname)) + (with-tell-user ("Compiling source" component :source) + (let ((output-file + #+:lucid + (unmunge-lucid (component-full-pathname component + :binary)) + #-:lucid + (component-full-pathname component :binary))) + + ;; make certain the directory we need to write to + ;; exists [pvaneynd@debian.org 20001114] + ;; Added PATHNAME-HOST following suggestion by John + ;; DeSoi [marcoxa@sourceforge.net 20020529] + + (ensure-directories-exist + (make-pathname + :host (pathname-host output-file) + :directory (pathname-directory output-file))) + + (or *oos-test* + (apply (compile-function component) + source-pname + :output-file + output-file + #+(or :cmu :scl) :error-file + #+(or :cmu :scl) (and *cmu-errors-to-file* + (component-full-pathname component + :error)) + #+CMU + :error-output + #+CMU + *cmu-errors-to-terminal* + (component-compiler-options component) + )))) + must-compile) + (must-compile + (tell-user "Source file not found. Not compiling" + component :source :no-dots :force) + nil) + (t nil)))) + +(defun needs-compilation (component) + ;; If there is no binary, or it is older than the source + ;; file, then the component needs to be compiled. + ;; Otherwise we only need to recompile if it depends on a file that changed. + (let ((source-pname (component-full-pathname component :source)) + (binary-pname (component-full-pathname component :binary))) + (and + ;; source must exist + (probe-file source-pname) + (or + ;; no binary + (null (probe-file binary-pname)) + ;; old binary + (< (file-write-date binary-pname) + (file-write-date source-pname)))))) + +(defun needs-loading (component &optional (check-source t) (check-binary t)) + ;; Compares the component's load-time against the file-write-date of + ;; the files on disk. + (let ((load-time (component-load-time component)) + (source-pname (component-full-pathname component :source)) + (binary-pname (component-full-pathname component :binary))) + (or + #|| ISI Extension ||# + (component-load-always component) + + ;; File never loaded. + (null load-time) + ;; Binary is newer. + (when (and check-binary + (probe-file binary-pname)) + (< load-time + (file-write-date binary-pname))) + ;; Source is newer. + (when (and check-source + (probe-file source-pname)) + (< load-time + (file-write-date source-pname)))))) + +;;; Need to completely rework this function... +(defun load-file-operation (component force) + ;; Returns T if the file had to be loaded + (let* ((binary-pname (component-full-pathname component :binary)) + (source-pname (component-full-pathname component :source)) + (binary-exists (probe-file binary-pname)) + (source-exists (probe-file source-pname)) + (source-needs-loading (needs-loading component t nil)) + (binary-needs-loading (needs-loading component nil t)) + ;; needs-compilation has an implicit source-exists in it. + (needs-compilation (if (component-load-only component) + source-needs-loading + (needs-compilation component))) + (check-for-new-source + ;; If force is :new-source*, we're checking for files + ;; whose source is newer than the compiled versions. + (find force '(:new-source :new-source-and-dependents :new-source-all) + :test #'eq)) + (load-binary (or (find force '(:all :new-source-all t) :test #'eq) + binary-needs-loading)) + (load-source + (or *load-source-instead-of-binary* + (and load-binary (component-load-only component)) + (and check-for-new-source needs-compilation))) + (compile-and-load + (and needs-compilation (or load-binary check-for-new-source) + (compile-and-load-source-if-no-binary component)))) + ;; When we're trying to minimize the files loaded to only those + ;; that need be, restrict the values of load-source and load-binary + ;; so that we only load the component if the files are newer than + ;; the load-time. + (when *minimal-load* + (when load-source (setf load-source source-needs-loading)) + (when load-binary (setf load-binary binary-needs-loading))) + + (when (or load-source load-binary compile-and-load) + (cond (compile-and-load + ;; If we're loading the binary and it is old or nonexistent, + ;; and the user says yes, compile and load the source. + (compile-file-operation component t) + (with-tell-user ("Loading binary" component :binary) + (or *oos-test* + (progn + (funcall (load-function component) binary-pname) + (setf (component-load-time component) + (file-write-date binary-pname))))) + t) + ((and source-exists + (or (and load-source ; implicit needs-comp... + (or *load-source-instead-of-binary* + (component-load-only component) + (not *compile-during-load*))) + (and load-binary (not binary-exists) + (load-source-if-no-binary component)))) + ;; Load the source if the source exists and: + ;; o we're loading binary and it doesn't exist + ;; o we're forcing it + ;; o we're loading new source and user wasn't asked to compile + (with-tell-user ("Loading source" component :source) + (or *oos-test* + (progn + (funcall (load-function component) source-pname) + (setf (component-load-time component) + (file-write-date source-pname))))) + t) + ((and binary-exists load-binary) + (with-tell-user ("Loading binary" component :binary) + (or *oos-test* + (progn + (funcall (load-function component) binary-pname) + (setf (component-load-time component) + (file-write-date binary-pname))))) + t) + ((and (not binary-exists) (not source-exists)) + (tell-user-no-files component :force) + (when *files-missing-is-an-error* + (cerror "Continue, ignoring missing files." + "~&Source file ~S ~:[and binary file ~S ~;~]do not exist." + source-pname + (or *load-source-if-no-binary* + *load-source-instead-of-binary*) + binary-pname)) + nil) + (t + nil))))) + +(eval-when (load eval) +(component-operation :clean 'delete-binaries-operation) +(component-operation 'clean 'delete-binaries-operation) +(component-operation :delete-binaries 'delete-binaries-operation) +(component-operation 'delete-binaries 'delete-binaries-operation) +) +(defun delete-binaries-operation (component force) + (when (or (eq force :all) + (eq force t) + (and (find force '(:new-source :new-source-and-dependents + :new-source-all) + :test #'eq) + (needs-compilation component))) + (let ((binary-pname (component-full-pathname component :binary))) + (when (probe-file binary-pname) + (with-tell-user ("Deleting binary" component :binary) + (or *oos-test* + (delete-file binary-pname))))))) + + +;; when the operation = :compile, we can assume the binary exists in test mode. +;; ((and *oos-test* +;; (eq operation :compile) +;; (probe-file (component-full-pathname component :source))) +;; (with-tell-user ("Loading binary" component :binary))) + +(defun binary-exists (component) + (probe-file (component-full-pathname component :binary))) + +;;; or old-binary +(defun compile-and-load-source-if-no-binary (component) + (when (not (or *load-source-instead-of-binary* + (and *load-source-if-no-binary* + (not (binary-exists component))))) + (cond ((component-load-only component) + #|| + (let ((prompt (prompt-string component))) + (format t "~A- File ~A is load-only, ~ + ~&~A not compiling." + prompt + (component-full-pathname component :source) + prompt)) + ||# + nil) + ((eq *compile-during-load* :query) + (let* ((prompt (prompt-string component)) + (compile-source + (y-or-n-p-wait + #\y 30 + "~A- Binary file ~A is old or does not exist. ~ + ~&~A Compile (and load) source file ~A instead? " + prompt + (component-full-pathname component :binary) + prompt + (component-full-pathname component :source)))) + (unless (y-or-n-p-wait + #\y 30 + "~A- Should I bother you if this happens again? " + prompt) + (setq *compile-during-load* + (y-or-n-p-wait + #\y 30 + "~A- Should I compile and load or not? " + prompt))) ; was compile-source, then t + compile-source)) + (*compile-during-load*) + (t nil)))) + +(defun load-source-if-no-binary (component) + (and (not *load-source-instead-of-binary*) + (or (and *load-source-if-no-binary* + (not (binary-exists component))) + (component-load-only component) + (when *bother-user-if-no-binary* + (let* ((prompt (prompt-string component)) + (load-source + (y-or-n-p-wait #\y 30 + "~A- Binary file ~A does not exist. ~ + ~&~A Load source file ~A instead? " + prompt + (component-full-pathname component :binary) + prompt + (component-full-pathname component :source)))) + (setq *bother-user-if-no-binary* + (y-or-n-p-wait #\n 30 + "~A- Should I bother you if this happens again? " + prompt )) + (unless *bother-user-if-no-binary* + (setq *load-source-if-no-binary* load-source)) + load-source))))) + +;;; ******************************** +;;; Allegro Toplevel Commands ****** +;;; ******************************** +;;; Creates toplevel command aliases for Allegro CL. +#+:allegro +(top-level:alias ("compile-system" 8) + (system &key force (minimal-load mk:*minimal-load*) + test verbose version) + "Compile the specified system" + + (mk:compile-system system :force force + :minimal-load minimal-load + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("load-system" 5) + (system &key force (minimal-load mk:*minimal-load*) + (compile-during-load mk:*compile-during-load*) + test verbose version) + "Compile the specified system" + + (mk:load-system system :force force + :minimal-load minimal-load + :compile-during-load compile-during-load + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("show-system" 5) (system) + "Show information about the specified system." + + (mk:describe-system system)) + +#+:allegro +(top-level:alias ("describe-system" 9) (system) + "Show information about the specified system." + + (mk:describe-system system)) + +#+:allegro +(top-level:alias ("system-source-size" 9) (system) + "Show size information about source files in the specified system." + + (mk:system-source-size system)) + +#+:allegro +(top-level:alias ("clean-system" 6) + (system &key force test verbose version) + "Delete binaries in the specified system." + + (mk:clean-system system :force force + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("edit-system" 7) + (system &key force test verbose version) + "Load system source files into Emacs." + + (mk:edit-system system :force force + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("hardcopy-system" 9) + (system &key force test verbose version) + "Hardcopy files in the specified system." + + (mk:hardcopy-system system :force force + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("make-system-tag-table" 13) (system) + "Make an Emacs TAGS file for source files in specified system." + + (mk:make-system-tag-table system)) + + +;;; ******************************** +;;; Allegro Make System Fasl ******* +;;; ******************************** +#+:excl +(defun allegro-make-system-fasl (system destination + &optional (include-dependents t)) + (excl:shell + (format nil "rm -f ~A; cat~{ ~A~} > ~A" + destination + (if include-dependents + (files-in-system-and-dependents system :all :binary) + (files-in-system system :all :binary)) + destination))) + +(defun files-which-need-compilation (system) + (mapcar #'(lambda (comp) (component-full-pathname comp :source)) + (remove nil + (file-components-in-component + (find-system system :load) :new-source)))) + +(defun files-in-system-and-dependents (name &optional (force :all) + (type :source) version) + ;; Returns a list of the pathnames in system and dependents in load order. + (let ((system (find-system name :load))) + (multiple-value-bind (*version-dir* *version-replace*) + (translate-version version) + (let ((*version* version)) + (let ((result (file-pathnames-in-component system type force))) + (dolist (dependent (reverse (component-depends-on system))) + (setq result + (append (files-in-system-and-dependents dependent + force type version) + result))) + result))))) + +(defun files-in-system (name &optional (force :all) (type :source) version) + ;; Returns a list of the pathnames in system in load order. + (let ((system (if (and (component-p name) + (member (component-type name) '(:defsystem :system :subsystem))) + name + (find-system name :load)))) + (multiple-value-bind (*version-dir* *version-replace*) + (translate-version version) + (let ((*version* version)) + (file-pathnames-in-component system type force))))) + +(defun file-pathnames-in-component (component type &optional (force :all)) + (mapcar #'(lambda (comp) (component-full-pathname comp type)) + (file-components-in-component component force))) + +(defun file-components-in-component (component &optional (force :all) + &aux result changed) + (case (component-type component) + ((:file :private-file) + (when (setq changed + (or (find force '(:all t) :test #'eq) + (and (not (non-empty-listp force)) + (needs-compilation component)))) + (setq result + (list component)))) + ((:module :system :subsystem :defsystem) + (dolist (module (component-components component)) + (multiple-value-bind (r c) + (file-components-in-component + module + (cond ((and (some #'(lambda (dependent) + (member dependent changed)) + (component-depends-on module)) + (or (non-empty-listp force) + (eq force :new-source-and-dependents))) + ;; The component depends on a changed file and force agrees. + :all) + ((and (non-empty-listp force) + (member (component-name module) force + :test #'string-equal :key #'string)) + ;; Force is a list of modules and the component is + ;; one of them. + :all) + (t force))) + (when c + (push module changed) + (setq result (append result r))))))) + (values result changed)) + +(setf (symbol-function 'oos) (symbol-function 'operate-on-system)) + +;;; ******************************** +;;; Additional Component Operations +;;; ******************************** + +;;; *** Edit Operation *** + +;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))? +#| +#+:ccl +(defun edit-operation (component force) + "Always returns nil, i.e. component not changed." + (declare (ignore force)) + ;; + (let* ((full-pathname (make::component-full-pathname component :source)) + (already-editing\? #+:mcl (dolist (w (CCL:windows :class + 'fred-window)) + (when (equal (CCL:window-filename w) + full-pathname) + (return w))) + #-:mcl nil)) + (if already-editing\? + #+:mcl (CCL:window-select already-editing\?) #-:mcl nil + (ed full-pathname))) + nil) + +#+:allegro +(defun edit-operation (component force) + "Edit a component - always returns nil, i.e. component not changed." + (declare (ignore force)) + (let ((full-pathname (component-full-pathname component :source))) + (ed full-pathname)) + nil) + +#+(or :ccl :allegro) +(make::component-operation :edit 'edit-operation) +#+(or :ccl :allegro) +(make::component-operation 'edit 'edit-operation) +|# + +;;; *** Hardcopy System *** +(defparameter *print-command* "enscript -2Gr" ; "lpr" + "Command to use for printing files on UNIX systems.") +#+:allegro +(defun hardcopy-operation (component force) + "Hardcopy a component - always returns nil, i.e. component not changed." + (declare (ignore force)) + (let ((full-pathname (component-full-pathname component :source))) + (excl:run-shell-command (format nil "~A ~A" + *print-command* full-pathname))) + nil) + +#+:allegro +(make::component-operation :hardcopy 'hardcopy-operation) +#+:allegro +(make::component-operation 'hardcopy 'hardcopy-operation) + + +;;; *** System Source Size *** + +(defun system-source-size (system-name &optional (force :all)) + "Prints a short report and returns the size in bytes of the source files in + ." + (let* ((file-list (files-in-system system-name force :source)) + (total-size (file-list-size file-list))) + (format t "~&~a/~a (~:d file~:p) totals ~:d byte~:p (~:d kB)" + system-name force (length file-list) + total-size (round total-size 1024)) + total-size)) + +(defun file-list-size (file-list) + "Returns the size in bytes of the files in ." + ;; + (let ((total-size 0)) + (dolist (file file-list) + (with-open-file (stream file) + (incf total-size (file-length stream)))) + total-size)) + +;;; *** System Tag Table *** + +#+:allegro +(defun make-system-tag-table (system-name) + "Makes an Emacs tag table using the GNU etags program." + (let ((files-in-system (files-in-system system-name :all :source))) + + (format t "~&Making tag table...") + (excl:run-shell-command (format nil "etags ~{~a ~}" files-in-system)) + (format t "done.~%"))) + + +;;; end of file -- defsystem.lisp -- Index: /branches/experimentation/later/source/x86-headers64/elf/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/elf/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/elf/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/x86-headers64/elf/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/elf/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/elf/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/x86-headers64/elf/C/populate.sh =================================================================== --- /branches/experimentation/later/source/x86-headers64/elf/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/elf/C/populate.sh (revision 8058) @@ -0,0 +1,9 @@ +#!/bin/sh +CFLAGS="-m64";export CFLAGS +rm -rf usr +# if the libelf in question comes from RedHat's elfutils, +# it doesn't seem possible to use other interfaces (gelf) +# without risking GPL contagion. +h-to-ffi.sh /usr/include/libelf.h + + Index: /branches/experimentation/later/source/x86-headers64/gl/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gl/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gl/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/x86-headers64/gl/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gl/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gl/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/x86-headers64/gl/C/populate.sh =================================================================== --- /branches/experimentation/later/source/x86-headers64/gl/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gl/C/populate.sh (revision 8058) @@ -0,0 +1,6 @@ +#!/bin/sh +CFLAGS="-m64";export CFLAGS +rm -rf usr +h-to-ffi.sh /usr/include/GL/glx.h +h-to-ffi.sh /usr/include/GL/glu.h +h-to-ffi.sh /usr/include/GL/glut.h Index: /branches/experimentation/later/source/x86-headers64/gmp/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gmp/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gmp/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/x86-headers64/gmp/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gmp/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gmp/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/x86-headers64/gmp/C/populate.sh =================================================================== --- /branches/experimentation/later/source/x86-headers64/gmp/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gmp/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh -m64 /usr/include/gmp.h Index: /branches/experimentation/later/source/x86-headers64/gnome2/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gnome2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gnome2/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.cdb* +*~.* Index: /branches/experimentation/later/source/x86-headers64/gnome2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gnome2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gnome2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/x86-headers64/gnome2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/x86-headers64/gnome2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gnome2/C/populate.sh (revision 8058) @@ -0,0 +1,3 @@ +#!/bin/sh +CFLAGS="-m64"; export CFLAGS +h-to-ffi.sh `pkg-config --cflags libgnomeui-2.0` /usr/include/libgnomeui-2.0/gnome.h Index: /branches/experimentation/later/source/x86-headers64/gtk2/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gtk2/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gtk2/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/x86-headers64/gtk2/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/gtk2/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gtk2/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/x86-headers64/gtk2/C/populate.sh =================================================================== --- /branches/experimentation/later/source/x86-headers64/gtk2/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/gtk2/C/populate.sh (revision 8058) @@ -0,0 +1,2 @@ +#!/bin/sh +h-to-ffi.sh `pkg-config --cflags gtk+-2.0` -m64 /usr/include/gtk-2.0/gtk/gtk.h Index: /branches/experimentation/later/source/x86-headers64/libc/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/libc/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/libc/.cvsignore (revision 8058) @@ -0,0 +1,3 @@ +*.cdb* + +*~.* Index: /branches/experimentation/later/source/x86-headers64/libc/C/.cvsignore =================================================================== --- /branches/experimentation/later/source/x86-headers64/libc/C/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/libc/C/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +usr* +*~.* Index: /branches/experimentation/later/source/x86-headers64/libc/C/populate.sh =================================================================== --- /branches/experimentation/later/source/x86-headers64/libc/C/populate.sh (revision 8058) +++ /branches/experimentation/later/source/x86-headers64/libc/C/populate.sh (revision 8058) @@ -0,0 +1,273 @@ +#!/bin/sh +# Note that it may be necessary to patch , since +# it (mis)uses features not supported by GCC 4.0. See +# +CFLAGS="-m64 -D_GNU_SOURCE";export CFLAGS +h-to-ffi.sh /usr/include/_G_config.h +h-to-ffi.sh /usr/include/a.out.h +h-to-ffi.sh /usr/include/aio.h +h-to-ffi.sh /usr/include/aliases.h +h-to-ffi.sh /usr/include/alloca.h +h-to-ffi.sh /usr/include/ar.h +h-to-ffi.sh /usr/include/argp.h +h-to-ffi.sh /usr/include/argz.h +h-to-ffi.sh /usr/include/arpa/ftp.h +h-to-ffi.sh /usr/include/arpa/inet.h +h-to-ffi.sh /usr/include/arpa/nameser.h +h-to-ffi.sh /usr/include/arpa/telnet.h +h-to-ffi.sh /usr/include/arpa/tftp.h +h-to-ffi.sh /usr/include/assert.h +h-to-ffi.sh /usr/include/byteswap.h +h-to-ffi.sh /usr/include/complex.h +h-to-ffi.sh /usr/include/cpio.h +h-to-ffi.sh /usr/include/crypt.h +h-to-ffi.sh /usr/include/ctype.h +#h-to-ffi.sh /usr/include/db1/db.h +#h-to-ffi.sh /usr/include/db1/mpool.h +#h-to-ffi.sh /usr/include/db1/ndbm.h +h-to-ffi.sh /usr/include/dirent.h +h-to-ffi.sh -D _GNU_SOURCE /usr/include/dlfcn.h +h-to-ffi.sh /usr/include/elf.h +h-to-ffi.sh /usr/include/endian.h +h-to-ffi.sh /usr/include/envz.h +h-to-ffi.sh /usr/include/err.h +h-to-ffi.sh /usr/include/errno.h +h-to-ffi.sh /usr/include/error.h +h-to-ffi.sh /usr/include/execinfo.h +h-to-ffi.sh /usr/include/fcntl.h +h-to-ffi.sh /usr/include/features.h +h-to-ffi.sh /usr/include/fenv.h +h-to-ffi.sh /usr/include/fmtmsg.h +h-to-ffi.sh /usr/include/fnmatch.h +h-to-ffi.sh /usr/include/fpu_control.h +h-to-ffi.sh /usr/include/fstab.h +h-to-ffi.sh /usr/include/fts.h +h-to-ffi.sh /usr/include/ftw.h +h-to-ffi.sh /usr/include/gconv.h +h-to-ffi.sh /usr/include/getopt.h +h-to-ffi.sh /usr/include/glob.h +h-to-ffi.sh /usr/include/gnu-versions.h +h-to-ffi.sh /usr/include/gnu/lib-names.h +h-to-ffi.sh /usr/include/gnu/libc-version.h +h-to-ffi.sh /usr/include/gnu/stubs.h +h-to-ffi.sh /usr/include/grp.h +h-to-ffi.sh /usr/include/iconv.h +h-to-ffi.sh /usr/include/ieee754.h +h-to-ffi.sh /usr/include/ifaddrs.h +h-to-ffi.sh /usr/include/inttypes.h +h-to-ffi.sh /usr/include/langinfo.h +h-to-ffi.sh /usr/include/lastlog.h +h-to-ffi.sh /usr/include/libgen.h +h-to-ffi.sh /usr/include/libintl.h +h-to-ffi.sh /usr/include/libio.h +#h-to-ffi.sh /usr/include/limits.h +h-to-ffi.sh /usr/include/link.h +h-to-ffi.sh /usr/include/locale.h +h-to-ffi.sh /usr/include/malloc.h +h-to-ffi.sh /usr/include/math.h +h-to-ffi.sh /usr/include/mcheck.h +h-to-ffi.sh /usr/include/memory.h +h-to-ffi.sh /usr/include/mntent.h +h-to-ffi.sh /usr/include/monetary.h +h-to-ffi.sh /usr/include/net/ethernet.h +h-to-ffi.sh /usr/include/net/if.h +h-to-ffi.sh /usr/include/net/if_arp.h +h-to-ffi.sh /usr/include/net/if_packet.h +h-to-ffi.sh -include /usr/include/sys/capability.h /usr/include/net/if_ppp.h +h-to-ffi.sh /usr/include/net/if_shaper.h +h-to-ffi.sh /usr/include/net/if_slip.h +h-to-ffi.sh -include /usr/include/sys/capability.h -include /usr/include/net/ppp_defs.h /usr/include/net/ppp-comp.h +h-to-ffi.sh /usr/include/net/route.h +h-to-ffi.sh /usr/include/netash/ash.h +#h-to-ffi.sh -include /usr/include/sys/socket.h /usr/include/netatalk/at.h +h-to-ffi.sh /usr/include/netax25/ax25.h +h-to-ffi.sh /usr/include/netdb.h +h-to-ffi.sh /usr/include/neteconet/ec.h +h-to-ffi.sh /usr/include/netinet/ether.h +h-to-ffi.sh /usr/include/netinet/icmp6.h +h-to-ffi.sh /usr/include/netinet/if_ether.h +#h-to-ffi.sh /usr/include/netinet/if_fddi.h +#h-to-ffi.sh /usr/include/netinet/if_tr.h +h-to-ffi.sh /usr/include/netinet/igmp.h +h-to-ffi.sh /usr/include/netinet/in.h +h-to-ffi.sh /usr/include/netinet/in_systm.h +h-to-ffi.sh /usr/include/netinet/ip.h +h-to-ffi.sh /usr/include/netinet/ip6.h +h-to-ffi.sh /usr/include/netinet/ip_icmp.h +h-to-ffi.sh /usr/include/netinet/tcp.h +h-to-ffi.sh /usr/include/netinet/udp.h +h-to-ffi.sh /usr/include/netipx/ipx.h +h-to-ffi.sh /usr/include/netpacket/packet.h +h-to-ffi.sh /usr/include/netrom/netrom.h +h-to-ffi.sh -include /usr/include/netax25/ax25.h /usr/include/netrose/rose.h +h-to-ffi.sh /usr/include/nfs/nfs.h +h-to-ffi.sh /usr/include/nl_types.h +h-to-ffi.sh /usr/include/nss.h +h-to-ffi.sh /usr/include/obstack.h +h-to-ffi.sh /usr/include/paths.h +h-to-ffi.sh -include /usr/include/sys/types.h -include /usr/include/sys/time.h -include /usr/include/stdio.h -include /usr/include/pcap-bpf.h /usr/include/pcap-namedb.h +h-to-ffi.sh /usr/include/pcap.h +h-to-ffi.sh /usr/include/pci/config.h +h-to-ffi.sh /usr/include/pci/header.h +h-to-ffi.sh /usr/include/pci/pci.h +h-to-ffi.sh /usr/include/poll.h +h-to-ffi.sh /usr/include/printf.h +h-to-ffi.sh /usr/include/protocols/routed.h +h-to-ffi.sh /usr/include/protocols/rwhod.h +h-to-ffi.sh /usr/include/protocols/talkd.h +h-to-ffi.sh /usr/include/protocols/timed.h +h-to-ffi.sh /usr/include/pthread.h +h-to-ffi.sh /usr/include/pty.h +h-to-ffi.sh /usr/include/pwd.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/re_comp.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/regex.h +#h-to-ffi.sh /usr/include/regexp.h +h-to-ffi.sh /usr/include/rpc/auth.h +h-to-ffi.sh /usr/include/rpc/auth_des.h +h-to-ffi.sh /usr/include/rpc/auth_unix.h +h-to-ffi.sh /usr/include/rpc/clnt.h +h-to-ffi.sh /usr/include/rpc/des_crypt.h +h-to-ffi.sh /usr/include/rpc/key_prot.h +h-to-ffi.sh /usr/include/rpc/netdb.h +h-to-ffi.sh /usr/include/rpc/pmap_clnt.h +h-to-ffi.sh /usr/include/rpc/pmap_prot.h +h-to-ffi.sh /usr/include/rpc/pmap_rmt.h +h-to-ffi.sh /usr/include/rpc/rpc.h +h-to-ffi.sh /usr/include/rpc/rpc_des.h +h-to-ffi.sh /usr/include/rpc/rpc_msg.h +h-to-ffi.sh /usr/include/rpc/svc.h +h-to-ffi.sh /usr/include/rpc/svc_auth.h +h-to-ffi.sh /usr/include/rpc/types.h +h-to-ffi.sh /usr/include/rpc/xdr.h +h-to-ffi.sh /usr/include/rpcsvc/bootparam.h +h-to-ffi.sh /usr/include/rpcsvc/bootparam_prot.h +h-to-ffi.sh /usr/include/rpcsvc/key_prot.h +h-to-ffi.sh /usr/include/rpcsvc/klm_prot.h +h-to-ffi.sh /usr/include/rpcsvc/mount.h +h-to-ffi.sh /usr/include/rpcsvc/nfs_prot.h +h-to-ffi.sh /usr/include/rpcsvc/nis.h +h-to-ffi.sh /usr/include/rpcsvc/nlm_prot.h +h-to-ffi.sh /usr/include/rpcsvc/rex.h +h-to-ffi.sh /usr/include/rpcsvc/rquota.h +h-to-ffi.sh /usr/include/rpcsvc/rstat.h +h-to-ffi.sh /usr/include/rpcsvc/rusers.h +h-to-ffi.sh /usr/include/rpcsvc/sm_inter.h +h-to-ffi.sh /usr/include/rpcsvc/spray.h +h-to-ffi.sh /usr/include/rpcsvc/yp.h +h-to-ffi.sh /usr/include/rpcsvc/yp_prot.h +h-to-ffi.sh /usr/include/rpcsvc/ypclnt.h +h-to-ffi.sh /usr/include/rpcsvc/yppasswd.h +h-to-ffi.sh /usr/include/rpcsvc/ypupd.h +h-to-ffi.sh /usr/include/sched.h +h-to-ffi.sh /usr/include/scsi/scsi.h +h-to-ffi.sh /usr/include/scsi/scsi_ioctl.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/scsi/sg.h +h-to-ffi.sh /usr/include/search.h +h-to-ffi.sh /usr/include/semaphore.h +h-to-ffi.sh /usr/include/setjmp.h +h-to-ffi.sh /usr/include/sgtty.h +h-to-ffi.sh /usr/include/shadow.h +h-to-ffi.sh /usr/include/spawn.h +h-to-ffi.sh /usr/include/signal.h +h-to-ffi.sh /usr/include/stab.h +#h-to-ffi.sh /usr/include/stack-alloc.h +h-to-ffi.sh /usr/include/stdint.h +h-to-ffi.sh /usr/include/stdio.h +h-to-ffi.sh -D_GNU_SOURCE /usr/include/stdlib.h +h-to-ffi.sh /usr/include/string.h +h-to-ffi.sh /usr/include/strings.h +h-to-ffi.sh /usr/include/stropts.h +h-to-ffi.sh /usr/include/sys/acct.h +h-to-ffi.sh /usr/include/sys/bitypes.h +h-to-ffi.sh /usr/include/sys/cdefs.h +h-to-ffi.sh /usr/include/sys/dir.h +h-to-ffi.sh /usr/include/sys/errno.h +h-to-ffi.sh /usr/include/sys/fcntl.h +h-to-ffi.sh /usr/include/sys/file.h +h-to-ffi.sh /usr/include/sys/fsuid.h +h-to-ffi.sh /usr/include/sys/gmon.h +h-to-ffi.sh /usr/include/sys/gmon_out.h +h-to-ffi.sh /usr/include/sys/ioctl.h +h-to-ffi.sh /usr/include/sys/ipc.h +h-to-ffi.sh /usr/include/sys/kd.h +h-to-ffi.sh /usr/include/sys/kdaemon.h +h-to-ffi.sh /usr/include/sys/klog.h +h-to-ffi.sh /usr/include/sys/mman.h +h-to-ffi.sh /usr/include/sys/mount.h +h-to-ffi.sh /usr/include/sys/msg.h +h-to-ffi.sh /usr/include/sys/mtio.h +h-to-ffi.sh /usr/include/sys/param.h +h-to-ffi.sh /usr/include/sys/pci.h +h-to-ffi.sh /usr/include/sys/poll.h +h-to-ffi.sh /usr/include/sys/prctl.h +h-to-ffi.sh /usr/include/sys/procfs.h +h-to-ffi.sh /usr/include/sys/profil.h +h-to-ffi.sh /usr/include/sys/ptrace.h +h-to-ffi.sh /usr/include/sys/queue.h +h-to-ffi.sh /usr/include/sys/quota.h +h-to-ffi.sh /usr/include/sys/raw.h +h-to-ffi.sh /usr/include/sys/reboot.h +h-to-ffi.sh /usr/include/sys/resource.h +h-to-ffi.sh /usr/include/sys/select.h +h-to-ffi.sh /usr/include/sys/sem.h +h-to-ffi.sh /usr/include/sys/sendfile.h +h-to-ffi.sh /usr/include/sys/shm.h +h-to-ffi.sh /usr/include/sys/signal.h +h-to-ffi.sh /usr/include/sys/socket.h +h-to-ffi.sh /usr/include/sys/socketvar.h +h-to-ffi.sh /usr/include/sys/soundcard.h +h-to-ffi.sh /usr/include/sys/stat.h +h-to-ffi.sh /usr/include/sys/statfs.h +h-to-ffi.sh /usr/include/sys/statvfs.h +h-to-ffi.sh /usr/include/sys/stropts.h +h-to-ffi.sh /usr/include/sys/swap.h +h-to-ffi.sh /usr/include/sys/syscall.h +h-to-ffi.sh /usr/include/sys/sysctl.h +h-to-ffi.sh /usr/include/sys/sysinfo.h +h-to-ffi.sh /usr/include/sys/syslog.h +h-to-ffi.sh /usr/include/sys/sysmacros.h +h-to-ffi.sh /usr/include/sys/termios.h +h-to-ffi.sh /usr/include/sys/time.h +h-to-ffi.sh /usr/include/sys/timeb.h +h-to-ffi.sh /usr/include/sys/times.h +h-to-ffi.sh /usr/include/sys/timex.h +h-to-ffi.sh /usr/include/sys/ttychars.h +h-to-ffi.sh /usr/include/sys/ttydefaults.h +h-to-ffi.sh /usr/include/sys/types.h +h-to-ffi.sh /usr/include/sys/ucontext.h +h-to-ffi.sh /usr/include/sys/uio.h +h-to-ffi.sh /usr/include/sys/ultrasound.h +h-to-ffi.sh /usr/include/sys/un.h +h-to-ffi.sh /usr/include/sys/unistd.h +h-to-ffi.sh -include /usr/include/sys/types.h /usr/include/sys/user.h +h-to-ffi.sh /usr/include/sys/ustat.h +h-to-ffi.sh /usr/include/sys/utsname.h +h-to-ffi.sh /usr/include/sys/vfs.h +h-to-ffi.sh /usr/include/sys/vlimit.h +h-to-ffi.sh /usr/include/sys/vt.h +h-to-ffi.sh /usr/include/sys/vtimes.h +h-to-ffi.sh /usr/include/sys/wait.h +h-to-ffi.sh /usr/include/syscall.h +h-to-ffi.sh /usr/include/sysexits.h +h-to-ffi.sh /usr/include/syslog.h +h-to-ffi.sh /usr/include/tar.h +h-to-ffi.sh /usr/include/termio.h +h-to-ffi.sh /usr/include/termios.h +h-to-ffi.sh /usr/include/tgmath.h +h-to-ffi.sh /usr/include/thread_db.h +h-to-ffi.sh /usr/include/time.h +h-to-ffi.sh /usr/include/ttyent.h +h-to-ffi.sh /usr/include/ucontext.h +h-to-ffi.sh /usr/include/ulimit.h +h-to-ffi.sh /usr/include/unistd.h +h-to-ffi.sh /usr/include/ustat.h +h-to-ffi.sh /usr/include/utime.h +h-to-ffi.sh /usr/include/utmp.h +h-to-ffi.sh /usr/include/utmpx.h +h-to-ffi.sh /usr/include/values.h +h-to-ffi.sh /usr/include/wait.h +h-to-ffi.sh /usr/include/wchar.h +h-to-ffi.sh /usr/include/wctype.h +h-to-ffi.sh /usr/include/wordexp.h +h-to-ffi.sh /usr/include/xlocale.h + Index: /branches/experimentation/later/source/xdump/.cvsignore =================================================================== --- /branches/experimentation/later/source/xdump/.cvsignore (revision 8058) +++ /branches/experimentation/later/source/xdump/.cvsignore (revision 8058) @@ -0,0 +1,2 @@ +*.*fsl +*~.* Index: /branches/experimentation/later/source/xdump/faslenv.lisp =================================================================== --- /branches/experimentation/later/source/xdump/faslenv.lisp (revision 8058) +++ /branches/experimentation/later/source/xdump/faslenv.lisp (revision 8058) @@ -0,0 +1,163 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;; Compile-time environment for fasl dumper/loader. + +; loader state istruct +(def-accessors (faslstate) %svref + () + faslstate.faslfname + faslstate.faslevec + faslstate.faslecnt + faslstate.faslfd + faslstate.faslval + faslstate.faslstr + faslstate.oldfaslstr + faslstate.faslerr + faslstate.iobuffer + faslstate.bufcount + faslstate.faslversion + faslstate.faslepush + faslstate.faslgsymbols + faslstate.fasldispatch) + +;;; 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) + +(defconstant numfaslops 80 "Number of fasl file opcodes, roughly") +(defconstant $fasl-epush-bit 7) +(defconstant $fasl-file-id #xff00) +(defconstant $fasl-file-id1 #xff01) +(defconstant $fasl-vers #x50) +(defconstant $fasl-min-vers #x50) +(defconstant $faslend #xff) +(defconstant $fasl-buf-len 2048) +(defmacro deffaslop (n arglist &body body) + `(setf (svref *fasl-dispatch-table* ,n) + #'(lambda ,arglist ,@body))) + + +(defconstant $fasl-noop 0) ;. +(defconstant $fasl-s32-vector 1) ; Make a (SIMPLE-ARRAY (SIGNED-BYTE 32) ) +(defconstant $fasl-code-vector 2) ; words of code +(defconstant $fasl-clfun 3) ;code,size-codesize exprs +(defconstant $fasl-lfuncall 4) ; funcall the lfun. +(defconstant $fasl-globals 5) ; global symbols vector +(defconstant $fasl-char 6) ; Make a char +(defconstant $fasl-fixnum 7) ; Make a (4-byte) fixnum +(defconstant $fasl-dfloat 8) ; Make a DOUBLE-FLOAT +(defconstant $fasl-bignum32 9) ; make a bignum with count digits +(defconstant $fasl-word-fixnum 10) ; Make a fixnum +(defconstant $fasl-double-float-vector 11) ; make a (SIMPLE-ARRAY DOUBLE-FLOAT ) +(defconstant $fasl-single-float-vector 12) ; make a (SIMPLE-ARRAY SINGLE-FLOAT ) +(defconstant $fasl-bit-vector 13) ; make a (SIMPLE-ARRAY BIT ) +(defconstant $fasl-u8-vector 14) ; make a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) ) +(defconstant $fasl-cons 15) ; Make a cons +(defconstant $fasl-s8-vector 16) ; make a (SIMPLE-ARRAY (SIGNED-BYTE 8) ) +(defconstant $fasl-t-vector 17) ; make a (SIMPLE-ARRAY T ) +(defconstant $fasl-nil 18) ; Make nil +(defconstant $fasl-timm 19) ; +(defconstant $fasl-function 20) ; Make function +(defconstant $fasl-vstr 21) ; Make a string +(defconstant $fasl-vmksym 22) ; Make an uninterned symbol +(defconstant $fasl-platform 23) ; Ensure that file's loadable on platform n. +(defconstant $fasl-vetab-alloc 24) ; Make a new expression table + ; with count slots. Current etab gets lost. +(defconstant $fasl-veref 25) ; Get the value from an etab slot. +(defconstant $fasl-fixnum8 26) ; Make an 8-byte fixnum. +(defconstant $fasl-symfn 27) ; +(defconstant $fasl-eval 28) ; Eval and return value. +(defconstant $fasl-u16-vector 29) ; Make a (SIMPLE-ARRAY (UNSIGNED-BYTE 16) ) +(defconstant $fasl-s16-vector 30) ; Make a (SIMPLE-ARRAY (SIGNED-BYTE 16) ) +(defconstant $fasl-vintern 31) ; Intern in current pkg. +(defconstant $fasl-vpkg-intern 32) ; Make a sym in pkg. +(defconstant $fasl-vpkg 33) ; Returns the package of given name +(defconstant $fasl-vgvec 34) ; +(defconstant $fasl-defun 35) ; +(defconstant $fasl-macro 37) ; +(defconstant $fasl-defconstant 38) ; +(defconstant $fasl-defparameter 39) ; +(defconstant $fasl-defvar 40) ; +(defconstant $fasl-defvar-init 41) ; +(defconstant $fasl-vivec 42) ; +(defconstant $fasl-prog1 43) ; - Second is for side-affects only +(defconstant $fasl-vlist 44) ; Make a list +(defconstant $fasl-vlist* 45) ; Make an sexpr +(defconstant $fasl-sfloat 46) ; Make SINGLE-FLOAT from bits +(defconstant $fasl-src 47) ; - Set *loading-file-source-file * to . +(defconstant $fasl-u32-vector 48) ; Make a (SIMPLE-ARRAY (UNSIGNED-BYTE 32) ) +(defconstant $fasl-provide 49) ; +(defconstant $fasl-u64-vector 50) ; Make a (SIMPLE-ARRAY (UNSIGNED-BYTE 64) ) +(defconstant $fasl-s64-vector 51) ; Make a (SIMPLE-ARRAY (SIGNED-BYTE 64) ) +(defconstant $fasl-istruct 52) ; Make an ISTRUCT with elements +(defconstant $fasl-complex 53) ; +(defconstant $fasl-ratio 54) ; +(defconstant $fasl-vector-header 55) ; Make a vector header +(defconstant $fasl-array-header 56) ; Make an array header. +(defconstant $fasl-s32 57) ;<4bytes> Make a (SIGNED-BYTE 32) +(defconstant $fasl-vintern-special 58) ; Intern in current pkg, ensure that it has a special binding index +(defconstant $fasl-s64 59) ;<8bytes> Make a (SIGNED-BYTE 64) +(defconstant $fasl-vpkg-intern-special 60) ; Make a sym in pkg, ensure that it has a special binding index +(defconstant $fasl-vmksym-special 61) ; Make an uninterned symbol, ensure special binding index +(defconstant $fasl-nvmksym-special 62) ; Make an uninterned symbol, ensure special binding index +(defconstant $fasl-nvpkg-intern-special 63) ; Make a sym in pkg, ensure that it has a special binding index +(defconstant $fasl-nvintern-special 64) ; Intern in current pkg, ensure that it has a special binding index +(defconstant $fasl-nvpkg 65) ; Returns the package of given name +(defconstant $fasl-nvpkg-intern 66) ; Intern in current pkg. +(defconstant $fasl-nvintern 67) ; Make a sym in pkg. +(defconstant $fasl-nvmksym 68) ; Make a string +(defconstant $fasl-nvstr 69) ; Make an uninterned symbol + + +;;; means (this is no longer used) +;;; means either with n<#xFF, or with n<#xFFFF or +;;; +;;; is a variable-length encoding of an unsigned integer, written +;;; 7 bits per octet, the least significant bits written first and the most +;;; significant octet having bit 7 set, so 127 would be written as #x00 and +;;; 128 as #x00 #x81 +;;; is a (string length) followed by count octets of +;;; 8-bit charcode data. +;;; is a (string length) followd by count of +;;; variable-length charcode data. This encodes ASCII/STANDARD-CHAR as +;;; compactly as the encoding, which should probably be deprecated. + + + +(defconstant $fasl-end #xFF) ;Stop reading. + +(defconstant $fasl-epush-mask #x80) ;Push value on etab if this bit is set in opcode. + +(defmacro fasl-epush-op (op) `(%ilogior2 ,$fasl-epush-mask ,op)) + +(provide "FASLENV") Index: /branches/experimentation/later/source/xdump/hashenv.lisp =================================================================== --- /branches/experimentation/later/source/xdump/hashenv.lisp (revision 8058) +++ /branches/experimentation/later/source/xdump/hashenv.lisp (revision 8058) @@ -0,0 +1,93 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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) + +;;; It's wired in to the code that the length of this vector is 8 and +;;; that its largest element is < 30 +(defconstant secondary-keys #(3 5 7 11 13 17 19 23)) +(defconstant secondary-keys-*-2 #(6 10 14 22 26 34 38 46)) + + +;;; undistinguished values of nhash.lock +(defconstant $nhash.lock-while-growing #x10000) +(defconstant $nhash.lock-while-rehashing #x20000) +(defconstant $nhash.lock-grow-or-rehash #x30000) +(defconstant $nhash.lock-map-count-mask #xffff) +(defconstant $nhash.lock-not-while-rehashing #x-20001) + +; The hash.vector cell contains a vector with 8 longwords of overhead +; followed by alternating keys and values. +; A key of $undefined denotes an empty or deleted value +; The value will be $undefined for empty values, or NIL for deleted values. +(def-accessors () %svref + nhash.vector.link ; GC link for weak vectors + nhash.vector.flags ; a fixnum of flags + nhash.vector.free-alist ; empty alist entries for finalization + nhash.vector.finalization-alist ; deleted out key/value pairs put here + nhash.vector.weak-deletions-count ; incremented when the GC deletes an element + nhash.vector.hash ; back-pointer + nhash.vector.deleted-count ; number of deleted entries + nhash.vector.cache-idx ; index of last cached key/value pair + nhash.vector.cache-key ; cached key + nhash.vector.cache-value ; cached value + ) + +; number of longwords of overhead in nhash.vector. +; Must be a multiple of 2 or INDEX parameters in LAP code will not be tagged as fixnums. +(defconstant $nhash.vector_overhead 10) + +(defconstant $nhash_weak_bit 12) ; weak hash table +(defconstant $nhash_weak_value_bit 11) ; weak on value vice key if this bit set +(defconstant $nhash_finalizeable_bit 10) +(defconstant $nhash_weak_flags_mask + (bitset $nhash_weak_bit (bitset $nhash_weak_value_bit (bitset $nhash_finalizeable_bit 0)))) + +(defconstant $nhash_track_keys_bit 28) ; request GC to track relocation of keys. +(defconstant $nhash_key_moved_bit 27) ; set by GC if a key moved. +(defconstant $nhash_ephemeral_bit 26) ; set if a hash code was computed using an address + ; in ephemeral space +(defconstant $nhash_component_address_bit 25) ; a hash code was computed from a key's component + + +(defconstant $nhash-growing-bit 16) +(defconstant $nhash-rehashing-bit 17) + +) + +(declare-arch-specific-macro immediate-p-macro) + +(declare-arch-specific-macro hashed-by-identity) + + +;; state is #(hash-table index key-vector count) +(def-accessors %svref + nhti.hash-table + nhti.index + nhti.keys + nhti.values + nhti.nkeys) + +(defconstant +nil-hash+ (mixup-hash-code (%pname-hash "NIL" 3))) + + + + + + + Index: /branches/experimentation/later/source/xdump/heap-image.lisp =================================================================== --- /branches/experimentation/later/source/xdump/heap-image.lisp (revision 8058) +++ /branches/experimentation/later/source/xdump/heap-image.lisp (revision 8058) @@ -0,0 +1,161 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2002 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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 image-sig0 (dpb (char-code #\O) + (byte 8 24) + (dpb (char-code #\p) + (byte 8 16) + (dpb (char-code #\e) + (byte 8 8) + (char-code #\n))))) +(defconstant image-sig1 (dpb (char-code #\M) + (byte 8 24) + (dpb (char-code #\C) + (byte 8 16) + (dpb (char-code #\L) + (byte 8 8) + (char-code #\I))))) +(defconstant image-sig2 (dpb (char-code #\m) + (byte 8 24) + (dpb (char-code #\a) + (byte 8 16) + (dpb (char-code #\g) + (byte 8 8) + (char-code #\e))))) +(defconstant image-sig3 (dpb (char-code #\F) + (byte 8 24) + (dpb (char-code #\i) + (byte 8 16) + (dpb (char-code #\l) + (byte 8 8) + (char-code #\e))))) + +#| +(def-foreign-type + openmcl-image-section-header + (:struct nil + (:code :unsigned-long) + (:area (:* t)) + (:memory-size :unsigned-long) + (:static-dnodes :unsigned-long))) +|# + +(defparameter *image-section-size* ()) + + + +(defparameter *image-header-size* nil) + +(defun target-setup-image-header-sizes () + (setq *image-header-size* (* 4 16)) + (setq *image-section-size* (* 4 (target-word-size-case + (32 4) + (64 8))))) + +(defun image-write-fullword (w f &optional force-big-endian) + (cond ((or force-big-endian *xload-target-big-endian*) + (write-byte (ldb (byte 8 24) w) f) + (write-byte (ldb (byte 8 16) w) f) + (write-byte (ldb (byte 8 8) w) f) + (write-byte (ldb (byte 8 0) w) f)) + (t + (write-byte (ldb (byte 8 0) w) f) + (write-byte (ldb (byte 8 8) w) f) + (write-byte (ldb (byte 8 16) w) f) + (write-byte (ldb (byte 8 24) w) f)))) + +(defun image-write-doubleword (dw f) + (cond (*xload-target-big-endian* + (image-write-fullword (ldb (byte 32 32) dw) f) + (image-write-fullword (ldb (byte 32 0) dw) f)) + (t + (image-write-fullword (ldb (byte 32 0) dw) f) + (image-write-fullword (ldb (byte 32 32) dw) f)))) + +(defun image-write-natural (n f) + (target-word-size-case + (32 (image-write-fullword n f)) + (64 (image-write-doubleword n f)))) + +(defun image-align-output-position (f) + (file-position f (logand (lognot 4095) + (+ 4095 (file-position f))))) + + +(defparameter *image-abi-version* 1018) + +(defun write-image-file (pathname image-base spaces &optional (abi-version *image-abi-version*)) + (target-setup-image-header-sizes) + (with-open-file (f pathname + :direction :output + :if-does-not-exist :create + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (let* ((nsections (length spaces)) + (header-pos (- 4096 (+ *image-header-size* + (* nsections *image-section-size*))))) + (file-position f header-pos) + (image-write-fullword image-sig0 f) + (image-write-fullword image-sig1 f) + (image-write-fullword image-sig2 f) + (image-write-fullword image-sig3 f) + (image-write-fullword (get-universal-time) f) + (image-write-fullword (target-word-size-case + (32 *xload-image-base-address*) + (64 0)) f) + (image-write-fullword (target-word-size-case + (32 image-base) + (64 0)) f) + (image-write-fullword nsections f) + (image-write-fullword abi-version f) + (target-word-size-case + (32 + (dotimes (i 2) (image-write-fullword 0 f)) + + (image-write-fullword (backend-target-platform *target-backend*) f) + (dotimes (i 4) (image-write-fullword 0 f))) + (64 + (image-write-fullword 0 f) + (image-write-fullword 0 f) + (image-write-fullword (backend-target-platform *target-backend*) f) + (image-write-doubleword *xload-image-base-address* f) + (image-write-doubleword image-base f))) + (dolist (sect spaces) + (image-write-natural (ash (xload-space-code sect) + *xload-target-fixnumshift*) + f) + (image-write-natural 0 f) + (let* ((size (xload-space-lowptr sect))) + (image-write-natural size f) + (image-write-natural 0 f))) ; static dnodes. + (dolist (sect spaces) + (image-align-output-position f) + (stream-write-ivector f + (xload-space-data sect) + 0 + (xload-space-lowptr sect))) + ;; Write an openmcl_image_file_trailer. + (image-write-fullword image-sig0 f) + (image-write-fullword image-sig1 f) + (image-write-fullword image-sig2 f) + (let* ((pos (+ 4 (file-position f)))) + (image-write-fullword (- header-pos pos) f)) + nil))) + + + + Index: /branches/experimentation/later/source/xdump/xfasload.lisp =================================================================== --- /branches/experimentation/later/source/xdump/xfasload.lisp (revision 8058) +++ /branches/experimentation/later/source/xdump/xfasload.lisp (revision 8058) @@ -0,0 +1,1810 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + + + +(defmacro defxloadfaslop (n arglist &body body) + `(setf (svref *xload-fasl-dispatch-table* ,n) + #'(lambda ,arglist ,@body))) + +(defmacro xload-copy-faslop (n) + `(let* ((n ,n)) + (setf (svref *xload-fasl-dispatch-table* n) + (svref *fasl-dispatch-table* n)))) +) + + +;;; I'm not sure that there's a better way to do this. + +(defparameter *xload-show-cold-load-functions* nil "Set to T when debugging") +(defparameter *xload-special-binding-indices* nil) +(defparameter *xload-reserved-special-binding-index-symbols* + '(*interrupt-level* *locks-held* *locks-pending* *lock-conses*)) + +(defparameter *xload-next-special-binding-index* (length *xload-reserved-special-binding-index-symbols*)) + +(defparameter *xload-target-nil* nil) +(defparameter *xload-target-fixnumshift* nil) +(defparameter *xload-target-fulltag-cons* nil) +(defparameter *xload-target-fulltag-misc* nil) +(defparameter *xload-target-misc-data-offset* nil) +(defparameter *xload-target-fulltagmask* nil) +(defparameter *xload-target-fulltag-cons* nil) +(defparameter *xload-target-cons-size* nil) +(defparameter *xload-target-car-offset* nil) +(defparameter *xload-target-cdr-offset* nil) +(defparameter *xload-target-misc-header-offset* nil) +(defparameter *xload-target-misc-subtag-offset* nil) +(defparameter *xload-target-unbound-marker* nil) +(defparameter *xload-target-subtag-char* nil) +(defparameter *xload-target-charcode-shift* nil) +(defparameter *xload-target-big-endian* t) +(defparameter *xload-host-big-endian* t) +(defparameter *xload-target-use-code-vectors* t + "When true, assume that the target represents functions as a node vector with an immediate vector (a CODE-VECTOR) in its 0th element. When false, assume that the target mixes code and constants in a single object.") +(defparameter *xload-target-fulltag-for-symbols* nil) +(defparameter *xload-target-fulltag-for-functions* nil) +(defparameter *xload-target-char-code-limit* nil) + + +(defvar *xload-backends* nil) +(defvar *xload-default-backend*) +(defvar *xload-target-backend*) + +(defparameter *xload-image-base-address* nil) + +(defparameter *xload-purespace-reserve* nil) +(defparameter *xload-static-space-address* (ash 1 12)) +(defparameter *xload-static-space-size* (ash 8 10)) +(defparameter *xload-readonly-space-address* nil) +(defparameter *xload-readonly-space-size* (ash 1 18)) +(defparameter *xload-dynamic-space-address* nil) +(defparameter *xload-dynamic-space-size* (ash 1 18)) +(defparameter *xload-managed-static-space-address* nil) +(defparameter *xload-managed-static-space-size* 0) + +(defstruct backend-xload-info + name + macro-apply-code-function + closure-trampoline-code + udf-code + default-image-name + default-startup-file-name + subdirs + compiler-target-name + image-base-address + nil-relative-symbols + static-space-init-function + purespace-reserve + static-space-address +) + +(defun setup-xload-target-parameters () + (let* ((arch (backend-target-arch *target-backend*))) + (setq *xload-image-base-address* + (backend-xload-info-image-base-address + *xload-target-backend*)) + (setq *xload-purespace-reserve* + (backend-xload-info-purespace-reserve + *xload-target-backend*)) + (setq *xload-readonly-space-address* *xload-image-base-address*) + (setq *xload-dynamic-space-address* + (+ *xload-image-base-address* + *xload-purespace-reserve*)) + (setq *xload-managed-static-space-address* *xload-dynamic-space-address*) + (setq *xload-static-space-address* + (backend-xload-info-static-space-address + *xload-target-backend*)) + (setq *xload-target-nil* + (arch::target-nil-value arch)) + (setq *xload-target-unbound-marker* + (arch::target-unbound-marker-value arch)) + (setq *xload-target-misc-header-offset* + (- (arch::target-misc-data-offset arch) + (arch::target-lisp-node-size arch))) + (setq *xload-target-misc-subtag-offset* + (arch::target-misc-subtag-offset arch)) + (setq *xload-target-fixnumshift* + (arch::target-word-shift arch)) + (setq *xload-target-fulltag-cons* + (arch::target-cons-tag arch)) + (setq *xload-target-car-offset* + (arch::target-car-offset arch)) + (setq *xload-target-cdr-offset* + (arch::target-cdr-offset arch)) + (setq *xload-target-cons-size* + (* 2 (arch::target-lisp-node-size arch))) + (setq *xload-target-fulltagmask* + (arch::target-fulltagmask arch)) + (setq *xload-target-misc-data-offset* + (arch::target-misc-data-offset arch)) + (setq *xload-target-fulltag-misc* + (arch::target-fulltag-misc arch)) + (setq *xload-target-subtag-char* + (arch::target-subtag-char arch)) + (setq *xload-target-charcode-shift* + (arch::target-charcode-shift arch)) + (setq *xload-target-big-endian* + (arch::target-big-endian arch)) + (setq *xload-host-big-endian* + (arch::target-big-endian + (backend-target-arch *host-backend*))) + (setq *xload-target-use-code-vectors* + (not (null (assoc :code-vector (arch::target-uvector-subtags arch))))) + (setq *xload-target-fulltag-for-symbols* + (if (arch::target-symbol-tag-is-subtag arch) + (arch::target-fulltag-misc arch) + (arch::target-symbol-tag arch))) + (setq *xload-target-fulltag-for-functions* + (if (arch::target-function-tag-is-subtag arch) + (arch::target-fulltag-misc arch) + (arch::target-function-tag arch))) + (setq *xload-target-char-code-limit* + (arch::target-char-code-limit arch)))) + + + +(defun xload-target-consp (addr) + (= *xload-target-fulltag-cons* (logand addr *xload-target-fulltagmask*))) + + +(defun xload-target-listp (addr) + (or (= addr *xload-target-nil*) + (xload-target-consp addr))) + + +(defun find-xload-backend (target) + (find target *xload-backends* :key #'backend-xload-info-name)) + +(defun add-xload-backend (b) + (let* ((already (find-xload-backend (backend-xload-info-name b)))) + (when already + (setq *xload-backends* (remove already *xload-backends*))) + (push b *xload-backends*))) + + +(defun make-xload-header (element-count subtag) + (logior (ash element-count target::num-subtag-bits) subtag)) + + +(defparameter *xload-record-source-file-p* t) + +(defun xload-symbol-header () + (make-xload-header target::symbol.element-count (xload-target-subtype :symbol))) + +(defparameter *xload-fasl-dispatch-table* (make-array (length *fasl-dispatch-table*) + :initial-element #'%bad-fasl)) + +(defun xload-swap-16 (16-bit-value) + (dpb (ldb (byte 8 0) 16-bit-value) + (byte 8 8) + (ldb (byte 8 8) 16-bit-value))) + +(defun xload-swap-32 (32-bit-value) + (dpb (xload-swap-16 (ldb (byte 16 0) 32-bit-value)) + (byte 16 16) + (xload-swap-16 (ldb (byte 16 16) 32-bit-value)))) + +(defun xload-swap-64 (64-bit-value) + (dpb (xload-swap-32 (ldb (byte 32 0) 64-bit-value)) + (byte 32 32) + (xload-swap-32 (ldb (byte 32 32) 64-bit-value)))) + +(defun u32-ref (u32v byte-offset) + (declare (type (simple-array (unsigned-byte 32) (*)) u32v) + (fixnum byte-offset)) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((val (aref u32v (ash byte-offset -2)))) + (if (eq *xload-target-big-endian* *xload-host-big-endian*) + val + (xload-swap-32 val))))) + +(defun (setf u32-ref) (new u32v byte-offset) + (declare (type (simple-array (unsigned-byte 32) (*)) u32v) + (fixnum byte-offset)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (aref u32v (ash byte-offset -2)) + (if (eq *xload-target-big-endian* *xload-host-big-endian*) + (logand new #xffffffff) + (xload-swap-32 new))))) + +(defun u16-ref (u16v byte-offset) + (declare (type (simple-array (unsigned-byte 16) (*)) u16v) + (fixnum byte-offset)) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((val (aref u16v (ash byte-offset -1)))) + (if (eq *xload-target-big-endian* *xload-host-big-endian*) + val + (xload-swap-16 val))))) + +(defun (setf u16-ref) (new u16v byte-offset) + (declare (type (simple-array (unsigned-byte 16) (*)) u16v) + (fixnum byte-offset)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (aref u16v (ash byte-offset -1)) + (if (eq *xload-target-big-endian* *xload-host-big-endian*) + new + (xload-swap-16 new))) + new)) + +(defun u8-ref (u8v byte-offset) + (declare (type (simple-array (unsigned-byte 8) (*)) u8v) + (fixnum byte-offset)) + (locally (declare (optimize (speed 3) (safety 0))) + (aref u8v byte-offset))) + +(defun (setf u8-ref) (new u8v byte-offset) + (declare (type (simple-array (unsigned-byte 8) (*)) u8v) + (fixnum byte-offset)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (aref u8v byte-offset) new))) + +(defun natural-ref (u32v byte-offset) + (target-word-size-case + (32 (u32-ref u32v byte-offset)) + (64 (let* ((first (u32-ref u32v byte-offset)) + (second (u32-ref u32v (+ byte-offset 4)))) + (if *xload-target-big-endian* + (dpb first (byte 32 32) second) + (dpb second (byte 32 32) first)))))) + +(defun (setf natural-ref) (new u32v byte-offset) + (target-word-size-case + (32 (setf (u32-ref u32v byte-offset) new)) + (64 (let* ((high (ldb (byte 32 32) new)) + (low (ldb (byte 32 0) new))) + (if *xload-target-big-endian* + (setf (u32-ref u32v byte-offset) high + (u32-ref u32v (+ byte-offset 4)) low) + (setf (u32-ref u32v byte-offset) low + (u32-ref u32v (+ byte-offset 4)) high)) + new)))) + + +(defun xload-aligned-uvector-size (nbytes) + (target-word-size-case + (32 (logand (lognot 7) (+ 4 7 nbytes ))) + (64 (logand (lognot 15) (+ 15 8 nbytes))))) + +(defparameter *xload-spaces* nil) +(defparameter *xload-image-file* nil) +(defvar *xload-image-file-name*) +(defvar *xload-startup-file*) + + +(defstruct xload-space + (vaddr 0) + (size (ash 1 18)) + (lowptr 0) + (data nil) + (code 0)) + +(defmethod print-object ((s xload-space) stream) + (print-unreadable-object (s stream :type t) + (format stream "~a @#x~8,'0x len = ~d" (xload-space-code s) (xload-space-vaddr s) (xload-space-lowptr s)))) + +;;; :constructor ... :constructor ... ... must remember ... :constructor + +(defun init-xload-space (vaddr size code) + (let* ((nfullwords (ash (+ size 3) -2)) + (space (make-xload-space :vaddr vaddr + :size size + :data (make-array nfullwords + :element-type '(unsigned-byte 32) + :initial-element 0) + :code code))) + (push space *xload-spaces*) + space)) + +;;; Nilreg-relative symbols. + +(defparameter %builtin-functions% + #(+-2 --2 *-2 /-2 =-2 /=-2 >-2 >=-2 <-2 <=-2 eql length sequence-type + assq memq logbitp logior-2 logand-2 ash + %negate logxor-2 %aref1 %aset1 + ;; add more + ) + "Symbols naming fixed-arg, single-valued functions") + +(defun xload-nrs () + (mapcar + #'(lambda (s) + (or (assq s '((nil) (%pascal-functions%) (*all-metered-functions*) + (*post-gc-hook*) (%handlers%) + (%finalization-alist%) (%closure-code%))) + s)) + (backend-xload-info-nil-relative-symbols *xload-target-backend*))) + + + +(defun %xload-unbound-function% () + (+ *xload-dynamic-space-address* *xload-target-fulltag-misc*)) + +(defparameter *xload-dynamic-space* nil) +(defparameter *xload-readonly-space* nil) +(defparameter *xload-static-space* nil) +(defparameter *xload-managed-static-space* nil) +(defparameter *xload-symbols* nil) +(defparameter *xload-symbol-addresses* nil) +(defparameter *xload-package-alist* nil) ; maps real package to clone +(defparameter *xload-aliased-package-addresses* nil) ; cloned package to address +(defparameter *xload-cold-load-functions* nil) +(defparameter *xload-cold-load-documentation* nil) +(defparameter *xload-loading-file-source-file* nil) + +(defparameter *xload-pure-code-p* t) ; when T, subprims are copied to readonly space + ; and code vectors are allocated there, reference subprims + ; pc-relative. + + + +(defun xload-lookup-symbol (sym) + (gethash (%symbol->symptr sym) *xload-symbols*)) + +(defun xload-lookup-symbol-address (addr) + (gethash addr *xload-symbol-addresses*)) + +(defun (setf xload-lookup-symbol) (addr sym) + (setf (gethash (%symbol->symptr sym) *xload-symbols*) addr)) + +(defun (setf xload-lookup-symbol-address) (sym addr) + (setf (gethash addr *xload-symbol-addresses*) sym)) + +(defun xload-lookup-address (address) + (dolist (space *xload-spaces* (error "Address #x~8,'0x not found in defined address spaces ." address)) + (let* ((vaddr (xload-space-vaddr space))) + (if (and (<= vaddr address) + (< address (+ vaddr (the fixnum (xload-space-size space))))) + (return (values (xload-space-data space) (- address vaddr))))))) + +(defun xload-u32-at-address (address) + (multiple-value-bind (v o) (xload-lookup-address address) + (u32-ref v o))) + +(defun (setf xload-u32-at-address) (new address) + (multiple-value-bind (v o) (xload-lookup-address address) + (setf (u32-ref v o) new))) + +(defun xload-natural-at-address (address) + (multiple-value-bind (v o) (xload-lookup-address address) + (natural-ref v o))) + +(defun (setf xload-natural-at-address) (new address) + (multiple-value-bind (v o) (xload-lookup-address address) + (setf (natural-ref v o) new))) + +(defun xload-u16-at-address (address) + (multiple-value-bind (v o) (xload-lookup-address address) + (u16-ref v o))) + +(defun (setf xload-u16-at-address) (new address) + (multiple-value-bind (v o) (xload-lookup-address address) + (setf (u16-ref v o) new))) + +(defun xload-u8-at-address (address) + (multiple-value-bind (v o) (xload-lookup-address address) + (u8-ref v o))) + +(defun (setf xload-u8-at-address) (new address) + (multiple-value-bind (v o) (xload-lookup-address address) + (setf (u8-ref v o) new))) + +(defun xload-integer (imm &optional (nwords 1)) + (let* ((arch (backend-target-arch *target-backend*)) + (most-negative (arch::target-most-negative-fixnum arch)) + (most-positive (arch::target-most-positive-fixnum arch))) + (if (and (typep imm 'integer) + (<= most-negative imm most-positive)) + (ash imm (arch::target-fixnum-shift arch)) + (let* ((bignum (xload-make-ivector + *xload-dynamic-space* + :bignum + nwords))) + (dotimes (i nwords bignum) + (setf (xload-%fullword-ref bignum i) (ldb (byte 32 0) imm) + imm (ash imm -32))))))) + +;;; "grow" the space: make a new data vector. Copy old data +;;; to new data vector. Update size and data fields. +;;; Grow (arbitrarily) by 64K bytes, or as specified by caller. +(defun xload-more-space (space &optional (delta (ash 1 16))) + (declare (fixnum delta)) + (setq delta (logand (lognot 3) (the fixnum (+ delta 3)))) + (let* ((old-size (xload-space-size space)) + (old-data (xload-space-data space)) + (old-nfullwords (ash old-size -2)) + (delta-nfullwords (ash delta -2)) + (new-size (+ old-size delta)) + (new-nfullwords (+ old-nfullwords delta-nfullwords)) + (new-data (make-array (the fixnum new-nfullwords) + :element-type '(unsigned-byte 32) + :initial-element 0))) + (declare (fixnum old-size old-nfullwords delta-nfullwords)) + (declare (type (simple-array (unsigned-byte 32) (*)) old-data new-data)) + (dotimes (i old-nfullwords) + (declare (optimize (speed 3) (safety 0))) + (setf (aref new-data i) (aref old-data i))) + (setf (xload-space-size space) new-size + (xload-space-data space) new-data) + new-size)) + + +(defun xload-alloc (space tag nbytes) + (declare (fixnum tag nbytes)) + (when (logtest 7 nbytes) (error "~d not a multiple of 8 ." nbytes)) + (let* ((free (xload-space-lowptr space))) + (if (> nbytes (the fixnum (- (the fixnum (xload-space-size space)) free))) + (xload-more-space space (the fixnum (+ nbytes (ash 1 16))))) + (setf (xload-space-lowptr space) (the fixnum (+ free nbytes))) + (let* ((offset (+ free tag))) + (declare (fixnum offset)) + (values + (the fixnum (+ (xload-space-vaddr space) offset)) + (xload-space-data space) + offset)))) + +;;; element-count doesn't include header +(defun xload-alloc-fullwords (space tag nelements) + (xload-alloc space tag (xload-aligned-uvector-size (ash nelements 2)))) + +(defun xload-alloc-halfwords (space tag nelements) + (xload-alloc space tag (xload-aligned-uvector-size (ash nelements 1)))) + +(defun xload-alloc-bytes (space tag nelements) + (xload-alloc space tag (xload-aligned-uvector-size nelements))) + +(defun xload-alloc-doublewords (space tag nelements) + (xload-alloc space tag (xload-aligned-uvector-size (ash nelements 3)))) + + + + +(defun xload-make-cons (car cdr &optional (space *xload-dynamic-space*)) + (multiple-value-bind (cell-addr data offset) (xload-alloc space *xload-target-fulltag-cons* *xload-target-cons-size*) + (setf (natural-ref data (the fixnum (+ offset *xload-target-car-offset*))) car) + (setf (natural-ref data (the fixnum (+ offset *xload-target-cdr-offset*))) cdr) + cell-addr)) + +;;; This initializes the gvector's contents to 0. Might want to +;;; consider initializing it to NIL for the benefit of package and +;;; hashtable code. +(defun xload-make-gvector (subtag len) + (unless (typep subtag 'fixnum) + (setq subtag (type-keyword-code subtag))) + (locally + (declare (fixnum subtype len)) + (multiple-value-bind (cell-addr data offset) + (target-word-size-case + (32 (xload-alloc-fullwords *xload-dynamic-space* *xload-target-fulltag-misc* len)) + (64 (xload-alloc-doublewords *xload-dynamic-space* *xload-target-fulltag-misc* len))) + (declare (fixnum offset)) + (setf (natural-ref data (+ offset *xload-target-misc-header-offset*)) (make-xload-header len subtag)) + cell-addr))) + +(defun xload-make-word-ivector (subtag len space) + (declare (fixnum subtype len)) + (multiple-value-bind (cell-addr data offset) (xload-alloc-fullwords space *xload-target-fulltag-misc* len) + (declare (fixnum offset)) + (setf (natural-ref data (+ offset *xload-target-misc-header-offset*)) (make-xload-header len subtag)) + cell-addr)) + +(defun xload-package->addr (p) + (or (cdr (assq (or (cdr (assq p *xload-package-alist*)) + (error "Package ~s not cloned ." p)) + *xload-aliased-package-addresses*)) + (error "Cloned package ~s: no assigned address . " p))) + +(defun xload-addr->package (a) + (or (car (rassoc (or (car (rassoc a *xload-aliased-package-addresses* :test #'eq)) + (error "Address ~d: no cloned package ." a)) + *xload-package-alist*)) + (error "Package at address ~d not cloned ." a))) + +(defun xload-make-symbol (pname-address &optional + (package-address *xload-target-nil*) + (space *xload-dynamic-space*)) + (let* ((sym + (target-word-size-case + (32 (xload-alloc-fullwords space *xload-target-fulltag-for-symbols* target::symbol.element-count)) + (64 (xload-alloc-doublewords space *xload-target-fulltag-for-symbols* target::symbol.element-count)))) + (sv (logior *xload-target-fulltag-misc* + (logandc2 sym *xload-target-fulltagmask*)))) + (setf (xload-%svref sv -1) (xload-symbol-header)) + (setf (xload-%svref sv target::symbol.flags-cell) 0) + ;; On PPC64, NIL's pname must be NIL. + (setf (xload-%svref sv target::symbol.pname-cell) + (if (and (target-arch-case (:ppc64 t) (otherwise nil)) + (= sym *xload-target-nil*)) + *xload-target-nil* + pname-address)) + (setf (xload-%svref sv target::symbol.vcell-cell) *xload-target-unbound-marker*) + (setf (xload-%svref sv target::symbol.package-predicate-cell) package-address) + (setf (xload-%svref sv target::symbol.fcell-cell) (%xload-unbound-function%)) + (setf (xload-%svref sv target::symbol.plist-cell) *xload-target-nil*) + ;;(break "Made symbol at #x~x (#x~x)" cell-addr offset) + sym)) + +;;; No importing or shadowing can (easily) happen during the cold +;;; load; a symbol is present in no package other than its home +;;; package. +;;; This -just- finds or adds the symbol in the "clone" package's itab/etab. +;;; Somebody else has to copy the symbol to the image ... +(defun xload-intern (symbol) + (let* ((pname (symbol-name symbol)) + (namelen (length pname)) + (package (symbol-package symbol)) + (clone (cdr (assq package *xload-package-alist*)))) + (unless (nth-value 1 (%find-package-symbol pname clone namelen)) ; already there + (without-interrupts + (let* ((htab (if (%get-htab-symbol pname namelen (pkg.etab package)) + (pkg.etab clone) + (pkg.itab clone)))) + (%htab-add-symbol symbol htab (nth-value 2 (%get-htab-symbol pname namelen htab)))))) + t)) + + +(defun xload-dnode-align (nbytes) + (target-word-size-case + (32 (logand (lognot 7) (+ nbytes 7 4))) + (64 (logand (lognot 15) (+ nbytes 15 8))))) + +(defun xload-subtag-bytes (subtag element-count) + (funcall (arch::target-array-data-size-function + (backend-target-arch *target-backend*)) + subtag element-count)) + + +(defun xload-make-dfloat (space high low) + (let* ((double-float-tag (arch::target-double-float-tag + (backend-target-arch *target-backend*)))) + (target-word-size-case + (32 + (multiple-value-bind (dfloat-addr v o) (xload-alloc-fullwords space *xload-target-fulltag-misc* 3) + (declare (fixnum o)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-header-offset*))) + (make-xload-header 3 double-float-tag)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset* 4))) + (if *xload-target-big-endian* high low)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset* 8))) + (if *xload-target-big-endian* low high)) + dfloat-addr)) + (64 + (multiple-value-bind (dfloat-addr v o) (xload-alloc-fullwords space *xload-target-fulltag-misc* 2) + (declare (fixnum o)) + (setf (natural-ref v (the fixnum (+ o *xload-target-misc-header-offset*))) + (make-xload-header 2 double-float-tag)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset*))) + (if *xload-target-big-endian* high low)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset* 4))) + (if *xload-target-big-endian* low high)) + dfloat-addr))))) + +(defun xload-make-sfloat (space bits) + (let* ((single-float-tag (arch::target-single-float-tag + (backend-target-arch *target-backend*)))) + (target-word-size-case + (32 + (multiple-value-bind (sfloat-addr v o) (xload-alloc-fullwords space *xload-target-fulltag-misc* 1) + (declare (fixnum o)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-header-offset*))) + (make-xload-header 1 single-float-tag)) + (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset*))) bits) + sfloat-addr)) + (64 + (logior (ash bits 32) single-float-tag))))) + +(defun xload-make-ivector (space subtag nelements) + (unless (typep subtag 'fixnum) + (setq subtag (type-keyword-code subtag))) + (locally + (declare (fixnum subtype nelements)) + (multiple-value-bind (addr v o) (xload-alloc space *xload-target-fulltag-misc* (xload-dnode-align (xload-subtag-bytes subtag nelements))) + (declare (fixnum o)) + (setf (natural-ref v (the fixnum (- o *xload-target-fulltag-misc*))) (make-xload-header nelements subtag)) + (values addr v o)))) + +(defun xload-%svref (addr i) + (declare (fixnum i)) + (if (= (the fixnum (logand addr *xload-target-fulltagmask*)) *xload-target-fulltag-misc*) + (target-word-size-case + (32 + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2))))))))) + (64 + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (natural-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 3)))))))))) + (error "Not a vector: #x~x" addr))) + +(defun (setf xload-%svref) (new addr i) + (declare (fixnum i)) + (if (= (the fixnum (logand addr *xload-target-fulltagmask*)) *xload-target-fulltag-misc*) + (target-word-size-case + (32 + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (setf (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2))))))) new))) + (64 + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (setf (natural-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 3))))))) new)))) + (error "Not a vector: #x~x" addr))) + + +(defun xload-%fullword-ref (addr i) + (declare (fixnum i)) + (if (= (the fixnum (logand addr *xload-target-fulltagmask*)) + *xload-target-fulltag-misc*) + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2)))))))) + (error "Not a vector: #x~x" addr))) + +(defun (setf xload-%fullword-ref) (new addr i) + (declare (fixnum i)) + (if (= (the fixnum (logand addr *xload-target-fulltagmask*)) + *xload-target-fulltag-misc*) + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (setf (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2))))))) new)) + (error "Not a vector: #x~x" addr))) + +(defun xload-car (addr) + (if (xload-target-listp addr) + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (natural-ref v (the fixnum (+ offset *xload-target-car-offset*)))) + (error "Not a list: #x~x" addr))) + +(defun (setf xload-car) (new addr) + (if (xload-target-consp addr) + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (setf (natural-ref v (the fixnum (+ offset *xload-target-car-offset*))) new)) + (error "Not a cons: #x~x" addr))) + +(defun xload-cdr (addr) + (if (xload-target-listp addr) + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (natural-ref v (the fixnum (+ offset *xload-target-cdr-offset*)))) + (error "Not a list: #x~x" addr))) + +(defun (setf xload-cdr) (new addr) + (if (xload-target-consp addr) + (multiple-value-bind (v offset) (xload-lookup-address addr) + (declare (fixnum offset)) + (setf (natural-ref v (the fixnum (+ offset *xload-target-cdr-offset*))) new)) + (error "Not a cons: #x~x" addr))) + +(defun xload-symbol-value (addr) + (unless (= *xload-target-fulltag-for-symbols* + (logand addr *xload-target-fulltagmask*)) + (error "~& Not a symbol address: #x~x" addr)) + (setq addr (logior *xload-target-fulltag-misc* + (logandc2 addr *xload-target-fulltagmask*))) + (if (= (xload-%svref addr -1) (xload-symbol-header)) + (xload-%svref addr target::symbol.vcell-cell) + (error "Not a symbol: #x~x" addr))) + + +(defun (setf xload-symbol-value) (new addr) + (unless (= *xload-target-fulltag-for-symbols* + (logand addr *xload-target-fulltagmask*)) + (error "~& Not a symbol address: #x~x" addr)) + (setq addr (logior *xload-target-fulltag-misc* + (logandc2 addr *xload-target-fulltagmask*))) + (if (= (xload-%svref addr -1) (xload-symbol-header)) + (setf (xload-%svref addr target::symbol.vcell-cell) new) + (error "Not a symbol: #x~x" addr))) + +(defun xload-set (sym val) + (check-type sym symbol) + (check-type val integer) + (let* ((symaddr (xload-lookup-symbol sym))) + (unless symaddr (error "Symbol address not found: ~s ." sym)) + (setf (xload-symbol-value symaddr) val))) + +(defun xload-fset (addr def) + (unless (= *xload-target-fulltag-for-symbols* + (logand addr *xload-target-fulltagmask*)) + (error "~& Not a symbol address: #x~x" addr)) + (setq addr (logior *xload-target-fulltag-misc* + (logandc2 addr *xload-target-fulltagmask*))) + (if (= (xload-%svref addr -1) (xload-symbol-header)) + (setf (xload-%svref addr target::symbol.fcell-cell) def) + (error "Not a symbol: #x~x" addr))) + +(defun (setf xload-symbol-plist) (new addr) + (unless (= *xload-target-fulltag-for-symbols* + (logand addr *xload-target-fulltagmask*)) + (error "~& Not a symbol address: #x~x" addr)) + (setq addr (logior *xload-target-fulltag-misc* + (logandc2 addr *xload-target-fulltagmask*))) + (let* ((plist (xload-%svref addr target::symbol.plist-cell))) + (if (xload-target-consp plist) + (let* ((str (xload-get-string (xload-%svref addr target::symbol.pname-cell)))) + (warn "Symbol at #x~x (~a): plist already set." addr str)) + (setf (xload-%svref addr target::symbol.plist-cell) + (xload-make-cons *xload-target-nil* new))) + new)) + + +;;; This handles constants set to themselves. Unless +;;; PRESERVE-CONSTANTNESS is true, the symbol's $sym_vbit_const bit is +;;; cleared. (This is done because the kernel tries to call EQUALP if +;;; constants are "redefined", and EQUALP may not be defined early +;;; enough.) +(defun xload-copy-symbol (symbol &key + (preserve-constantness (keywordp symbol)) + (space *xload-dynamic-space*)) + (or (xload-lookup-symbol symbol) + (let* ((pname (symbol-name symbol)) + (home-package (symbol-package symbol)) + (addr (xload-make-symbol (xload-save-string pname (length pname)) + (if home-package + (xload-package->addr home-package) + *xload-target-nil*) + space)) + (svaddr (logior *xload-target-fulltag-misc* + (logandc2 addr *xload-target-fulltagmask*)))) + (xload-intern symbol) + (let* ((bits (logandc2 (%symbol-bits symbol) + (ash 1 $sym_vbit_typeppred)))) + (setf (xload-%svref svaddr target::symbol.flags-cell) + (ash (if preserve-constantness + bits + (logand (lognot (ash 1 $sym_vbit_const)) bits)) + *xload-target-fixnumshift*))) + (if (and (constantp symbol) + (eq (symbol-value symbol) symbol)) + (setf (xload-symbol-value addr) addr)) + (setf (xload-lookup-symbol-address addr) symbol) + (setf (xload-lookup-symbol symbol) addr)))) + + +;;; Write a list to dynamic space. No detection of circularity or +;;; structure sharing. The cdr of the final cons can be nil (treated +;;; as *xload-target-nil*. All cars must be addresses. + +(defun xload-save-list (l) + (if (atom l) + (or l *xload-target-nil*) + (xload-make-cons (car l) (xload-save-list (cdr l))))) + +(defun xload-save-string (str &optional (n (length str))) + (declare (fixnum n)) + (let* ((subtag (type-keyword-code :simple-string))) + (multiple-value-bind (addr v offset) (xload-make-ivector *xload-readonly-space* subtag n) + (case *xload-target-char-code-limit* + (256 (do* ((p (+ offset *xload-target-misc-data-offset*) + (1+ p)) + (i 0 (1+ i))) + ((= i n) str) + (declare (fixnum i p)) + (setf (u8-ref v p) (char-code (schar str i))))) + (t + (do* ((p (+ offset *xload-target-misc-data-offset*) + (+ p 4)) + (i 0 (1+ i))) + ((= i n) str) + (declare (fixnum i p)) + (setf (u32-ref v p) (char-code (schar str i)))))) + addr))) + +;;; Read a string from fasl file, save it to readonly-space. +(defun %xload-fasl-vreadstr (s) + (multiple-value-bind (str n new-p) (%fasl-vreadstr s) + (declare (fixnum n subtype)) + (values (xload-save-string str n) str n new-p))) + +;;; Read a string from fasl file, save it to readonly-space. +;;; (assumes variable-length encoding.) +(defun %xload-fasl-nvreadstr (s) + (multiple-value-bind (str n new-p) (%fasl-nvreadstr s) + (declare (fixnum n subtype)) + (values (xload-save-string str n) str n new-p))) + +(defun xload-clone-packages (packages) + (let* ((alist (mapcar #'(lambda (p) + (cons p + (gvector :package + (cons (make-array (the fixnum (length (car (uvref p 0)))) + :initial-element 0) + (cons 0 (cddr (pkg.itab p)))) + (cons (make-array + (the fixnum + (length + (car + (pkg.etab p)))) + :initial-element 0) + (cons 0 (cddr (pkg.etab p)))) + nil ; used + nil ; used-by + (copy-list (pkg.names p)) ; names + nil ;shadowed + nil ;lock + nil ;intern-hook + ))) + packages))) + (flet ((lookup-clone (p) (or (cdr (assq p alist)) (error "Package ~S not cloned ." p)))) + (dolist (pair alist alist) + (let* ((orig (car pair)) + (dup (cdr pair))) + (setf (pkg.used dup) (mapcar #'lookup-clone (pkg.used orig)) + (pkg.used-by dup) (mapcar #'lookup-clone (pkg.used-by orig)))))))) + +;;; Dump each cloned package into dynamic-space; return an alist +(defun xload-assign-aliased-package-addresses (alist) + (let* ((addr-alist (mapcar #'(lambda (pair) + (let* ((p (cdr pair)) + (v (xload-make-gvector :package (uvsize p)))) + (setf (xload-%svref v pkg.names) + (xload-save-list (mapcar #'(lambda (n) (xload-save-string n)) + (pkg.names p)))) + (cons p v))) + alist))) + (flet ((clone->addr (clone) + (or (cdr (assq clone addr-alist)) (error "cloned package ~S not found ." clone)))) + (dolist (pair addr-alist addr-alist) + (let* ((p (car pair)) + (v (cdr pair))) + (setf (xload-%svref v pkg.used) + (xload-save-list (mapcar #'clone->addr (pkg.used p))) + (xload-%svref v pkg.used-by) + (xload-save-list (mapcar #'clone->addr (pkg.used-by p))) + (xload-%svref v pkg.shadowed) + (xload-save-list (mapcar #'xload-copy-symbol (pkg.shadowed p))) + (xload-%svref v pkg.intern-hook) + *xload-target-nil* + )))))) + + + +(defun xload-fasload (pathnames) + (dolist (path pathnames) + (multiple-value-bind (*load-pathname* *load-truename* source-file) (find-load-file (merge-pathnames path)) + (unless *load-truename* + (return (signal-file-error $err-no-file path))) + (setq path *load-truename*) + (let* ((*readtable* *readtable*) + (*package* *ccl-package*) ; maybe just *package* + (*loading-files* (cons path *loading-files*)) + (*xload-loading-file-source-file* nil) + (*loading-file-source-file* (namestring source-file))) + (when *load-verbose* + (format t "~&;Loading ~S..." *load-pathname*) + (force-output)) + (multiple-value-bind (winp err) (%fasload (native-translated-namestring path) *xload-fasl-dispatch-table*) + (if (not winp) (%err-disp err))))))) + + + + +(defun xload-save-htab (htab) + (let* ((htvec (car htab)) + (len (length htvec)) + (xvec (xload-make-gvector :simple-vector len)) + (deleted-marker *xload-target-unbound-marker*)) + (dotimes (i len) + (let* ((s (%svref htvec i))) + (setf (xload-%svref xvec i) + (if s + (if (symbolp s) + (or (xload-lookup-symbol s) deleted-marker) + 0) + (if (= (logand *xload-target-nil* *xload-target-fulltagmask*) + *xload-target-fulltag-for-symbols*) + *xload-target-nil* + (+ *xload-target-nil* + (let* ((arch (backend-target-arch *target-backend*))) + (+ (arch::target-t-offset arch) + (ash 8 (arch::target-word-shift arch)))))))))) + (xload-make-cons + xvec + (xload-make-cons + (xload-integer (cadr htab)) + (xload-integer (cddr htab)))))) + +(defun xload-finalize-packages () + (dolist (pair *xload-aliased-package-addresses*) + (let* ((p (car pair)) + (q (cdr pair))) + (setf (xload-%svref q pkg.etab) (xload-save-htab (pkg.etab p))) + (setf (xload-%svref q pkg.itab) (xload-save-htab (pkg.itab p)))))) + +(defun xload-get-string (address) + (multiple-value-bind (v o) (xload-lookup-address address) + (let* ((header (natural-ref v (+ o *xload-target-misc-header-offset*))) + (len (ash header (- target::num-subtag-bits))) + (str (make-string len)) + (p (+ o *xload-target-misc-data-offset*))) + (case *xload-target-char-code-limit* + (256 + (dotimes (i len str) + (setf (schar str i) (code-char (u8-ref v (+ p i)))))) + (t + (dotimes (i len str) + (setf (schar str i) (code-char (u32-ref v (+ p (* i 4))))))))))) + + +(defun xload-save-code-vector (code) + (let* ((read-only-p *xload-pure-code-p*) + (vlen (uvsize code)) + (prefix (arch::target-code-vector-prefix (backend-target-arch + *target-backend*))) + (n (+ (length prefix) vlen))) + (declare (fixnum n)) + (let* ((vector (xload-make-ivector + (if read-only-p + *xload-readonly-space* + *xload-dynamic-space*) + :code-vector + n)) + (j -1)) + (declare (fixnum j)) + (dotimes (i n) + (setf (xload-%fullword-ref vector i) + (if prefix + (pop prefix) + (uvref code (incf j))))) + vector))) + +;;; For debugging +(defun xload-show-list (l) + (labels ((show-list (l) + (unless (= l *xload-target-nil*) + (format t "#x~x" (xload-car l)) + (setq l (xload-cdr l)) + (unless (= l *xload-target-nil*) + (format t " ") + (show-list l))))) + (format t "~&(") + (show-list l) + (format t ")"))) + + +(defun xfasload (output-file &rest pathnames) + (let* ((*xload-symbols* (make-hash-table :test #'eq)) + (*xload-symbol-addresses* (make-hash-table :test #'eql)) + (*xload-spaces* nil) + (*xload-readonly-space* (init-xload-space *xload-readonly-space-address* *xload-readonly-space-size* area-readonly)) + (*xload-dynamic-space* (init-xload-space *xload-dynamic-space-address* *xload-dynamic-space-size* area-dynamic)) + (*xload-static-space* (init-xload-space *xload-static-space-address* *xload-static-space-size* area-static)) + (*xload-managed-static-space* (init-xload-space *xload-managed-static-space-address* *xload-managed-static-space-size* area-managed-static)) + + (*xload-package-alist* (xload-clone-packages %all-packages%)) + (*xload-cold-load-functions* nil) + (*xload-cold-load-documentation* nil) + (*xload-loading-file-source-file* nil) + (*xload-aliased-package-addresses* nil) + (*xload-special-binding-indices* + (make-hash-table :test #'eql)) + (*xload-next-special-binding-index* + (length *xload-reserved-special-binding-index-symbols*))) + (funcall (backend-xload-info-static-space-init-function + *xload-target-backend*)) + ;; Create %unbound-function% and the package objects in dynamic space, + ;; then fill in the nilreg-relative symbols in static space. + ;; Then start consing .. + (if *xload-target-use-code-vectors* + ;; The undefined-function object is a 1-element simple-vector (not + ;; a function vector). The code-vector in its 0th element should + ;; report the appropriate error. + (let* ((udf-object (xload-make-gvector :simple-vector 1))) + (setf (xload-%svref udf-object 0) (xload-save-code-vector + (backend-xload-info-udf-code + *xload-target-backend*)))) + (let* ((udf-object (xload-make-gvector :simple-vector 1))) + (setf (xload-%svref udf-object 0) (backend-xload-info-udf-code + *xload-target-backend*)))) + + (setq *xload-aliased-package-addresses* (xload-assign-aliased-package-addresses *xload-package-alist*)) + (dolist (pair (xload-nrs)) + (let* ((val-p (consp pair)) + (val (if val-p (or (cdr pair) *xload-target-nil*))) + (sym (if val-p (car pair) pair))) + (xload-copy-symbol sym + :preserve-constantness t + :space *xload-static-space*) + (when val-p (xload-set sym val)))) + ; This could be a little less ... procedural. + (xload-set '*package* (xload-package->addr *ccl-package*)) + (xload-set '*keyword-package* (xload-package->addr *keyword-package*)) + (xload-set '%all-packages% (xload-save-list (mapcar #'cdr *xload-aliased-package-addresses*))) + (xload-set '%unbound-function% (%xload-unbound-function%)) + (xload-set '*gc-event-status-bits* (xload-integer 0 #|(ash 1 $gc-integrity-check-bit)|#)) + (xload-set '%toplevel-catch% (xload-copy-symbol :toplevel)) + (if *xload-target-use-code-vectors* + (xload-set '%closure-code% (xload-save-code-vector + (backend-xload-info-closure-trampoline-code + *xload-target-backend*))) + (xload-set '%closure-code% *xload-target-nil*)) + (let* ((macro-apply-code (funcall + (backend-xload-info-macro-apply-code-function + *xload-target-backend*)))) + + (xload-set '%macro-code% + (if *xload-target-use-code-vectors* + (xload-save-code-vector macro-apply-code) + macro-apply-code))) + (let* ((len (length %builtin-functions%)) + (v (xload-make-gvector :simple-vector len))) + (dotimes (i len) + (setf (xload-%svref v i) (xload-copy-symbol (svref %builtin-functions% i)))) + (xload-set '%builtin-functions% v)) + (xload-copy-symbol '*xload-startup-file*) + (xload-fasload pathnames) + (xload-set '*xload-startup-file* + (xload-save-string *xload-startup-file*)) + (let* ((toplevel (xload-symbol-value (xload-lookup-symbol '%toplevel-function%)))) + (when (or (= toplevel *xload-target-unbound-marker*) + (= toplevel *xload-target-nil*)) + (warn "~S not set in loading ~S ." '%toplevel-function pathnames))) + (setf (xload-symbol-value (xload-copy-symbol '*xload-cold-load-functions*)) + (xload-save-list (setq *xload-cold-load-functions* + (nreverse *xload-cold-load-functions*)))) + (let* ((svnrev (local-svn-revision))) + (setf (xload-symbol-value (xload-copy-symbol '*openmcl-svn-revision*)) + (typecase svnrev + (fixnum (ash svnrev *xload-target-fixnumshift*)) + (string (xload-save-string svnrev)) + (t *xload-target-nil*)))) + (let* ((experimental-features *build-time-optional-features*)) + (setf (xload-symbol-value (xload-copy-symbol '*optional-features*)) + (xload-save-list (mapcar #'xload-copy-symbol experimental-features)))) + + (when *xload-show-cold-load-functions* + (format t "~&cold-load-functions list:") + (xload-show-list (xload-symbol-value (xload-copy-symbol '*xload-cold-load-functions*)))) + (setf (xload-symbol-value (xload-copy-symbol '*xload-cold-load-documentation*)) + (xload-save-list (setq *xload-cold-load-documentation* + (nreverse *xload-cold-load-documentation*)))) + (dolist (s *xload-reserved-special-binding-index-symbols*) + (xload-ensure-binding-index (xload-copy-symbol s))) + (xload-finalize-packages) + #+debug + (maphash #'(lambda (addr idx) + (format t "~&~d: ~s" idx + (xload-lookup-symbol-address addr))) + *xload-special-binding-indices*) + (xload-dump-image output-file *xload-image-base-address*))) + +(defun xload-dump-image (output-file heap-start) + (declare (ftype (function (t t list)) write-image-file)) + (write-image-file output-file + heap-start + (list *xload-readonly-space* + *xload-static-space* + *xload-dynamic-space* + *xload-managed-static-space*))) + + + + + + + +;;; The xloader + +(xload-copy-faslop $fasl-noop) +(xload-copy-faslop $fasl-vetab-alloc) +(xload-copy-faslop $fasl-veref) + +;;; Should error if epush bit set, else push on +;;; *xload-cold-load-functions* or something. +(defxloadfaslop $fasl-lfuncall (s) + (let* ((fun (%fasl-expr-preserve-epush s))) + (when (faslstate.faslepush s) + (error "Can't call function for value : ~s" fun)) + (when *xload-show-cold-load-functions* + (format t "~& cold-load function: #x~x" fun)) + (push fun *xload-cold-load-functions*))) + +(xload-copy-faslop $fasl-globals) ; what the hell did this ever do ? + +;;; fasl-char: maybe epush, return target representation of BASE-CHARACTER +(defxloadfaslop $fasl-char (s) + (let* ((code (%fasl-read-count s)) + (target-char (logior *xload-target-subtag-char* + (ash code *xload-target-charcode-shift*)))) + (%epushval s target-char))) + + + +(defxloadfaslop $fasl-dfloat (s) + (%epushval s (xload-make-dfloat *xload-readonly-space* (%fasl-read-long s) (%fasl-read-long s)))) + +(defxloadfaslop $fasl-sfloat (s) + (%epushval s (xload-make-sfloat *xload-readonly-space* (%fasl-read-long s)))) + +(defxloadfaslop $fasl-vstr (s) + (let* ((n (%fasl-read-count s))) + (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n) + (%epushval s str) + (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*) n) + str))) + +(defxloadfaslop $fasl-nvstr (s) + (let* ((n (%fasl-read-count s))) + (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n) + (%epushval s str) + (case *xload-target-char-code-limit* + (256 + (dotimes (i n) + (setf (u8-ref v (+ o i *xload-target-misc-data-offset*)) + (%fasl-read-count s)))) + (t + (dotimes (i n) + (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*)) + (%fasl-read-count s))))) + str))) + +;;; Allegedly deprecated. +(defxloadfaslop $fasl-fixnum (s) + (%epushval s (xload-integer + ;; This nonsense converts unsigned %fasl-read-long + ;; result to signed + (rlet ((long :long)) + (setf (%get-long long) (%fasl-read-long s)) + (%get-long long))))) + +(defxloadfaslop $fasl-word-fixnum (s) + (%epushval s (xload-integer (%word-to-int (%fasl-read-word s))))) + +(defxloadfaslop $fasl-s32 (s) + (%epushval s (xload-integer (%fasl-read-signed-long s)))) + +(defxloadfaslop $fasl-s64 (s) + (%epushval s (xload-integer (logior (ash (%fasl-read-signed-long s) 32) + (%fasl-read-long s)) + 2))) + +(defun xload-set-binding-address (symbol-address idx) + (unless (= *xload-target-fulltag-for-symbols* + (logand symbol-address *xload-target-fulltagmask*)) + (error "~& Not a symbol address: #x~x" symbol-address)) + (setq symbol-address + (logior *xload-target-fulltag-misc* + (logandc2 symbol-address *xload-target-fulltagmask*))) + (setf (xload-%svref symbol-address target::symbol.binding-index-cell) + (ash idx *xload-target-fixnumshift*)) + (setf (gethash symbol-address *xload-special-binding-indices*) idx)) + +(defun xload-ensure-binding-index (symbol-address) + (or (gethash symbol-address *xload-special-binding-indices*) + (let* ((sym (xload-lookup-symbol-address symbol-address)) + (pos (position sym *xload-reserved-special-binding-index-symbols*))) + (xload-set-binding-address + symbol-address + (if pos + (1+ pos) + (incf *xload-next-special-binding-index*)))))) + +(defun %xload-fasl-vmake-symbol (s &optional idx) + (let* ((sym (xload-make-symbol (%xload-fasl-vreadstr s)))) + (when idx + (xload-ensure-binding-index sym)) + (%epushval s sym))) + +(defun %xload-fasl-nvmake-symbol (s &optional idx) + (let* ((sym (xload-make-symbol (%xload-fasl-nvreadstr s)))) + (when idx + (xload-ensure-binding-index sym)) + (%epushval s sym))) + + + +(defxloadfaslop $fasl-vmksym (s) + (%xload-fasl-vmake-symbol s)) + +(defxloadfaslop $fasl-nvmksym (s) + (%xload-fasl-nvmake-symbol s)) + +(defxloadfaslop $fasl-vmksym-special (s) + (%xload-fasl-vmake-symbol s t)) + +(defxloadfaslop $fasl-nvmksym-special (s) + (%xload-fasl-nvmake-symbol s t)) + +(defun %xload-fasl-vintern (s package &optional idx) + (multiple-value-bind (str len new-p) (%fasl-vreadstr s) + (without-interrupts + (multiple-value-bind (cursym access internal external) (%find-symbol str len package) + (unless access + (unless new-p (setq str (%fasl-copystr str len))) + (setq cursym (%add-symbol str package internal external))) + ;; cursym now exists in the load-time world; make sure that it exists + ;; (and is properly "interned" in the world we're making as well) + (let* ((symaddr (xload-copy-symbol cursym))) + (when idx + (xload-ensure-binding-index symaddr)) + (%epushval s symaddr)))))) + +(defun %xload-fasl-nvintern (s package &optional idx) + (multiple-value-bind (str len new-p) (%fasl-nvreadstr s) + (without-interrupts + (multiple-value-bind (cursym access internal external) (%find-symbol str len package) + (unless access + (unless new-p (setq str (%fasl-copystr str len))) + (setq cursym (%add-symbol str package internal external))) + ;; cursym now exists in the load-time world; make sure that it exists + ;; (and is properly "interned" in the world we're making as well) + (let* ((symaddr (xload-copy-symbol cursym))) + (when idx + (xload-ensure-binding-index symaddr)) + (%epushval s symaddr)))))) + + +(defxloadfaslop $fasl-vintern (s) + (%xload-fasl-vintern s *package*)) + +(defxloadfaslop $fasl-nvintern (s) + (%xload-fasl-nvintern s *package*)) + +(defxloadfaslop $fasl-vintern-special (s) + (%xload-fasl-vintern s *package* t)) + +(defxloadfaslop $fasl-nvintern-special (s) + (%xload-fasl-nvintern s *package* t)) + +(defxloadfaslop $fasl-vpkg-intern (s) + (let* ((addr (%fasl-expr-preserve-epush s)) + (pkg (xload-addr->package addr))) + (%xload-fasl-vintern s pkg))) + +(defxloadfaslop $fasl-nvpkg-intern (s) + (let* ((addr (%fasl-expr-preserve-epush s)) + (pkg (xload-addr->package addr))) + (%xload-fasl-nvintern s pkg))) + +(defxloadfaslop $fasl-vpkg-intern-special (s) + (let* ((addr (%fasl-expr-preserve-epush s)) + (pkg (xload-addr->package addr))) + (%xload-fasl-vintern s pkg t))) + +(defxloadfaslop $fasl-nvpkg-intern-special (s) + (let* ((addr (%fasl-expr-preserve-epush s)) + (pkg (xload-addr->package addr))) + (%xload-fasl-nvintern s pkg t))) + +(defun %xload-fasl-vpackage (s) + (multiple-value-bind (str len new-p) (%fasl-vreadstr s) + (let* ((p (%find-pkg str len))) + (%epushval s (xload-package->addr + (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))) + +(defun %xload-fasl-nvpackage (s) + (multiple-value-bind (str len new-p) (%fasl-nvreadstr s) + (let* ((p (%find-pkg str len))) + (%epushval s (xload-package->addr + (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))) + + +(defxloadfaslop $fasl-vpkg (s) + (%xload-fasl-vpackage s)) + +(defxloadfaslop $fasl-nvpkg (s) + (%xload-fasl-nvpackage s)) + +(defxloadfaslop $fasl-cons (s) + (let* ((cons (%epushval s (xload-make-cons *xload-target-nil* *xload-target-nil*)))) + (setf (xload-car cons) (%fasl-expr s) + (xload-cdr cons) (%fasl-expr s)) + (setf (faslstate.faslval s) cons))) + + +(defun %xload-fasl-vlistX (s dotp) + (let* ((len (%fasl-read-count s))) + (declare (fixnum len)) + (let* ((val (%epushval s (xload-make-cons *xload-target-nil* *xload-target-nil*))) + (tail val)) + (setf (xload-car val) (%fasl-expr s)) + (dotimes (i len) + (setf (xload-cdr tail) (setq tail (xload-make-cons (%fasl-expr s) *xload-target-nil*)))) + (if dotp + (setf (xload-cdr tail) (%fasl-expr s))) + (setf (faslstate.faslval s) val)))) + +(defxloadfaslop $fasl-vlist (s) + (%xload-fasl-vlistX s nil)) + +(defxloadfaslop $fasl-vlist* (s) + (%xload-fasl-vlistX s t)) + +(defxloadfaslop $fasl-nil (s) + (%epushval s *xload-target-nil*)) + +(defxloadfaslop $fasl-timm (s) + (let* ((val (%fasl-read-long s))) + #+paranoid (unless (= (logand $typemask val) $t_imm) + (error "Bug: expected immediate-tagged object, got ~s ." val)) + (%epushval s val))) + + +(defxloadfaslop $fasl-platform (s) + (%cant-epush s) + (let* ((platform (%fasl-expr s)) + (backend-name (backend-xload-info-compiler-target-name + *xload-target-backend*)) + (backend (find-backend backend-name))) + (declare (fixnum platform)) + (unless (= platform (ash (backend-target-platform backend) + *xload-target-fixnumshift*)) + (error "Not a ~A fasl file : ~s" backend-name (faslstate.faslfname s))))) + + +(defxloadfaslop $fasl-symfn (s) + (let* ((symaddr (%fasl-expr-preserve-epush s)) + (fnobj (xload-%svref symaddr target::symbol.fcell-cell))) + (if (and (= *xload-target-fulltag-misc* + (logand fnobj *xload-target-fulltagmask*)) + (= (type-keyword-code :function) (xload-u8-at-address (+ fnobj *xload-target-misc-subtag-offset*)))) + (%epushval s fnobj) + (error "symbol at #x~x is unfbound . " symaddr)))) + +(defxloadfaslop $fasl-eval (s) + (let* ((expr (%fasl-expr-preserve-epush s))) + (error "Can't evaluate expression ~s in cold load ." expr) + (%epushval s (eval expr)))) ; could maybe evaluate symbols, constants ... + + +(defun xload-target-subtype (name) + (or + (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*)))) + (error "Unknown uvector type name ~s" name))) + +(defxloadfaslop $fasl-vivec (s) + (let* ((subtag (%fasl-read-byte s)) + (element-count (%fasl-read-count s))) + (declare (fixnum subtag)) + (multiple-value-bind (vector v o) + (xload-make-ivector + *xload-readonly-space* + subtag + element-count) + (%epushval s vector) + (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*) (xload-subtag-bytes subtag element-count)) + vector))) + +(defun xfasl-read-ivector (s subtag) + (let* ((element-count (%fasl-read-count s))) + (multiple-value-bind (vector v o) + (xload-make-ivector + *xload-readonly-space* + subtag + element-count) + (%epushval s vector) + (%fasl-read-n-bytes s + v + (+ o *xload-target-misc-data-offset*) + (xload-subtag-bytes subtag element-count)) + vector))) + +(defxloadfaslop $fasl-u8-vector (s) + (xfasl-read-ivector s (xload-target-subtype :unsigned-8-bit-vector))) + +(defxloadfaslop $fasl-s8-vector (s) + (xfasl-read-ivector s (xload-target-subtype :signed-8-bit-vector))) + +(defxloadfaslop $fasl-u16-vector (s) + (xfasl-read-ivector s (xload-target-subtype :unsigned-16-bit-vector))) + +(defxloadfaslop $fasl-s16-vector (s) + (xfasl-read-ivector s (xload-target-subtype :signed-16-bit-vector))) + +(defxloadfaslop $fasl-u32-vector (s) + (xfasl-read-ivector s (xload-target-subtype :unsigned-32-bit-vector))) + +(defxloadfaslop $fasl-s32-vector (s) + (xfasl-read-ivector s (xload-target-subtype :signed-32-bit-vector))) + + +;;; We really can't compile 64-bit vectors on a 32-bit host. +#+64-bit-target +(defxloadfaslop $fasl-u64-vector (s) + (xfasl-read-ivector s (xload-target-subtype :unsigned-64-bit-vector))) + +#+64-bit-target +(defxloadfaslop $fasl-u64-vector (s) + (xfasl-read-ivector s (xload-target-subtype :unsigned-64-bit-vector))) + +(defxloadfaslop $fasl-bit-vector (s) + (xfasl-read-ivector s (xload-target-subtype :bit-vector))) + +(defxloadfaslop $fasl-bignum32 (s) + (xfasl-read-ivector s (xload-target-subtype :bignum))) + +(defxloadfaslop $fasl-single-float-vector (s) + (xfasl-read-ivector s (xload-target-subtype :single-float-vector))) + +(defxloadfaslop $fasl-double-float-vector (s) + (target-word-size-case + (64 (xfasl-read-ivector s (xload-target-subtype :double-float-vector))) + (32 + (let* ((element-count (%fasl-read-count s))) + (multiple-value-bind (vector v o) + (xload-make-ivector + *xload-readonly-space* + (xload-target-subtype :double-float-vector) + element-count) + (%epushval s vector) + (%fasl-read-n-bytes s v (+ o (arch::target-misc-dfloat-offset (backend-target-arch *target-backend*))) (xload-subtag-bytes (xload-target-subtype :double-float-vector) element-count)) + vector))))) + +(defxloadfaslop $fasl-code-vector (s) + (let* ((element-count (%fasl-read-count s)) + (subtag (xload-target-subtype :code-vector))) + (multiple-value-bind (vector v o) + (xload-make-ivector + (if (not *xload-pure-code-p*) + *xload-dynamic-space* + *xload-readonly-space*) + subtag + element-count) + (%epushval s vector) + (%fasl-read-n-bytes s v (+ o + *xload-target-misc-data-offset*) + (xload-subtag-bytes subtag element-count)) + vector))) + +(defun xfasl-read-gvector (s subtype) + (declare (fixnum subtype)) + (let* ((n (%fasl-read-count s)) + (vector (xload-make-gvector subtype n))) + (%epushval s vector) + (dotimes (i n (setf (faslstate.faslval s) vector)) + (setf (xload-%svref vector i) (%fasl-expr s))))) + +(defxloadfaslop $fasl-vgvec (s) + (let* ((subtype (%fasl-read-byte s))) + (xfasl-read-gvector s subtype))) + +(defxloadfaslop $fasl-vector-header (s) + (xfasl-read-gvector s (xload-target-subtype :vector-header))) + +(defxloadfaslop $fasl-array-header (s) + (xfasl-read-gvector s (xload-target-subtype :array-header))) + +(defxloadfaslop $fasl-ratio (s) + (let* ((r (xload-make-gvector (xload-target-subtype :ratio) + target::ratio.element-count))) + (%epushval s r) + (setf (xload-%svref r target::ratio.numer-cell) (%fasl-expr s) + (xload-%svref r target::ratio.denom-cell) (%fasl-expr s)) + (setf (faslstate.faslval s) r))) + +(defxloadfaslop $fasl-complex (s) + (let* ((c (xload-make-gvector (xload-target-subtype :complex) + target::complex.element-count))) + (%epushval s c) + (setf (xload-%svref c target::complex.realpart-cell) (%fasl-expr s) + (xload-%svref c target::complex.imagpart-cell) (%fasl-expr s)) + (setf (faslstate.faslval s) c))) + + + +(defxloadfaslop $fasl-t-vector (s) + (xfasl-read-gvector s (xload-target-subtype :simple-vector))) + +(defxloadfaslop $fasl-function (s) + (xfasl-read-gvector s (xload-target-subtype :function))) + +(defxloadfaslop $fasl-istruct (s) + (xfasl-read-gvector s (xload-target-subtype :istruct))) + +(defun xload-lfun-name (lf) + (let* ((lfv (logior *xload-target-fulltag-misc* + (logandc2 lf *xload-target-fulltagmask*))) + (header (xload-%svref lfv -1))) + (unless (= (type-keyword-code :function) + (logand header (1- (ash 1 target::num-subtag-bits)))) + (error "Not a function address: ~x" lf)) + (let* ((n (ash header (- target::num-subtag-bits)))) + (if (> n 2) + (let* ((bits (ash (xload-%svref lfv (1- n)) + (- *xload-target-fixnumshift*)))) + (unless (logbitp $lfbits-noname-bit bits) + (xload-%svref lfv (- n 2)))) + (error "Teeny, tiny, little function : ~s" lf))))) + + +(defun xload-record-source-file (symaddr indicator) + (when *xload-record-source-file-p* + (when (or (eq indicator 'function) + (eq indicator 'variable)) + (let* ((keyaddr (xload-copy-symbol 'bootstrapping-source-files)) + (pathaddr (or *xload-loading-file-source-file* + (if *loading-file-source-file* + (setq *xload-loading-file-source-file* (xload-save-string *loading-file-source-file*)))))) + (when pathaddr + (let* ((keyval (if (eq indicator 'function) + (xload-make-cons pathaddr *xload-target-nil*) + (xload-make-cons + (xload-make-cons + (xload-make-cons (xload-copy-symbol indicator) pathaddr) + *xload-target-nil*) + *xload-target-nil*)))) + (setf (xload-symbol-plist symaddr) (xload-make-cons keyaddr keyval)))))))) + +(defun xload-set-documentation (symaddr indicator doc) + ;; Should maybe check further that it's a string + ;; and it would hurt for whatever processes *xload-cold-load-documentation* + ;; to do some checking there as well. + (when (= (the fixnum (logand doc *xload-target-fulltagmask*)) + *xload-target-fulltag-misc*) + (push (xload-save-list + (list symaddr + (xload-copy-symbol indicator) + doc)) + *xload-cold-load-documentation*))) + + + +(defxloadfaslop $fasl-defun (s) + (%cant-epush s) + (let* ((fun (%fasl-expr s)) + (doc (%fasl-expr s))) + (let* ((sym (xload-lfun-name fun))) + (unless (= doc *xload-target-nil*) + (xload-set-documentation sym 'function doc)) + (xload-record-source-file sym 'function) + (xload-fset sym fun)))) + +(defxloadfaslop $fasl-macro (s) + (%cant-epush s) + (let* ((fun (%fasl-expr s)) + (doc (%fasl-expr s))) + (let* ((sym (xload-lfun-name fun)) + (vector (xload-make-gvector :simple-vector 2))) + (setf (xload-%svref vector 0) (xload-symbol-value (xload-lookup-symbol '%macro-code%)) + (xload-%svref vector 1) fun) + (unless (= doc *xload-target-nil*) + (xload-set-documentation sym 'function doc)) + (xload-record-source-file sym 'function) + (xload-fset sym vector)))) + +(defxloadfaslop $fasl-defconstant (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s)) + (doc (%fasl-expr s))) + (unless (= doc *xload-target-nil*) + (xload-set-documentation sym 'variable doc)) + (xload-record-source-file sym 'variable) + (setf (xload-symbol-value sym) val) + (let* ((sv (logior *xload-target-fulltag-misc* + (logandc2 sym *xload-target-fulltagmask*)))) + (setf (xload-%svref sv target::symbol.flags-cell) + (ash + (logior (ash 1 $sym_vbit_special) + (ash 1 $sym_vbit_const) + (ash (xload-%svref sv target::symbol.flags-cell) + (- *xload-target-fixnumshift*))) + *xload-target-fixnumshift*))))) + +(defxloadfaslop $fasl-defparameter (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s)) + (doc (%fasl-expr s))) + (unless (= doc *xload-target-nil*) + (xload-set-documentation sym 'variable doc)) + (xload-record-source-file sym 'variable) + (setf (xload-symbol-value sym) val) + (let* ((sv (logior *xload-target-fulltag-misc* + (logandc2 sym *xload-target-fulltagmask*)))) + (setf (xload-%svref sv target::symbol.flags-cell) + (ash + (logior (ash 1 $sym_vbit_special) + (ash (xload-%svref sv target::symbol.flags-cell) + (- *xload-target-fixnumshift*))) + *xload-target-fixnumshift*))))) + +(defxloadfaslop $fasl-defvar (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s))) + (xload-record-source-file sym 'variable) + (let* ((sv (logior *xload-target-fulltag-misc* + (logandc2 sym *xload-target-fulltagmask*)))) + (setf (xload-%svref sv target::symbol.flags-cell) + (ash + (logior (ash 1 $sym_vbit_special) + (ash (xload-%svref sv target::symbol.flags-cell) + (- *xload-target-fixnumshift*))) + *xload-target-fixnumshift*))))) + +(defxloadfaslop $fasl-defvar-init (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s)) + (doc (%fasl-expr s))) + (unless (= doc *xload-target-nil*) + (xload-set-documentation sym 'variable doc)) + (when (= *xload-target-unbound-marker* + (xload-symbol-value sym)) + (setf (xload-symbol-value sym) val)) + (xload-record-source-file sym 'variable) + (let* ((sv (logior *xload-target-fulltag-misc* + (logandc2 sym *xload-target-fulltagmask*)))) + (setf (xload-%svref sv target::symbol.flags-cell) + (ash + (logior (ash 1 $sym_vbit_special) + (ash (xload-%svref sv target::symbol.flags-cell) + (- *xload-target-fixnumshift*))) + *xload-target-fixnumshift*))))) + + +(xload-copy-faslop $fasl-prog1) + +(defxloadfaslop $fasl-src (s) + (%cant-epush s) + (let* ((path (%fasl-expr s))) + (setq *xload-loading-file-source-file* path))) + +(defxloadfaslop $fasl-clfun (s) + (let* ((size-in-elements (%fasl-read-count s)) + (size-of-code (%fasl-read-count s))) + (declare (fixnum size-in-elements size-of-code)) + (multiple-value-bind (vector v o) + (target-word-size-case + (32 (xload-alloc-fullwords *xload-dynamic-space* *xload-target-fulltag-misc* size-in-elements)) + (64 (xload-alloc-doublewords *xload-dynamic-space* *xload-target-fulltag-misc* size-in-elements))) + (declare (fixnum o)) + (setf (natural-ref v (+ o *xload-target-misc-header-offset*)) + (make-xload-header size-in-elements (xload-target-subtype :function))) + (let* ((function (logior *xload-target-fulltag-for-functions* + (logandc2 vector *xload-target-fulltagmask*)))) + (%epushval s function) + (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*) + (ash size-of-code *xload-target-fixnumshift*)) + (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 (xload-%svref vector constidx) (%fasl-expr s))))))) + + +(defparameter *xcompile-features* nil) + + + +(defun target-Xcompile-directory (target dir &optional force) + (let* ((backend (find-backend target)) + (any (not (null force))) + (outpath (merge-pathnames dir (backend-target-fasl-pathname backend)))) + (in-development-mode + (dolist (src (sort (directory (merge-pathnames dir "*.lisp")) + #'string< :key #'namestring) + any) + (let* ((fasl (merge-pathnames outpath src))) + (when (or force + (not (probe-file fasl)) + (> (file-write-date src) + (file-write-date fasl))) + (setq any t) + (compile-file src :target target + :features *xcompile-features* + :output-file fasl + :verbose t))))))) + +(defun target-xcompile-level-0 (target &optional force) + (let* ((backend (or (find-xload-backend target) + (error "Unknown xload backend: ~s" target))) + ;; Saving doc-strings doesn't work in level-0 (yet.) + (*save-doc-strings* t) + (*fasl-save-doc-strings* t) + (a (target-xcompile-directory target "ccl:level-0;" force)) + (b + (dolist (d (backend-xload-info-subdirs backend)) + (target-xcompile-directory target d force)))) + (or a b))) + +(defun cross-compile-level-0 (target &optional (recompile t)) + (with-cross-compilation-target (target) + (target-xcompile-level-0 target recompile))) + +(defun target-Xload-level-0 (target &optional (recompile t)) + (let* ((*xload-target-backend* (or (find-xload-backend target) + *xload-default-backend*)) + (*xload-startup-file* (backend-xload-info-default-startup-file-name + *xload-target-backend*))) + ;; This just undoes the CLtL1 compatability stuff in + ;; "ccl:library;lisp-package". If someone's created LISP and/or + ;; USER packages, nuke 'em. + (let* ((user-pkg (find-package "USER")) + (lisp-pkg (find-package "LISP"))) + (when (and user-pkg (not (eq user-pkg (find-package "CL-USER")))) + (delete-package user-pkg)) + (when (and lisp-pkg (not (eq lisp-pkg (find-package "CL")))) + (delete-package lisp-pkg))) + (in-development-mode + (when recompile + (target-Xcompile-level-0 target (eq recompile :force))) + (let* ((*xload-image-base-address* *xload-image-base-address*) + (*xload-readonly-space-address* *xload-readonly-space-address*) + (*xload-dynamic-space-address* *xload-dynamic-space-address*) + (*xload-target-nil* *xload-target-nil*) + (*xload-target-unbound-marker* *xload-target-unbound-marker*) + (*xload-target-misc-header-offset* *xload-target-misc-header-offset*) + (*xload-target-misc-subtag-offset* *xload-target-misc-subtag-offset*) + (*xload-target-fixnumshift* *xload-target-fixnumshift*) + (*xload-target-fulltag-cons* *xload-target-fulltag-cons*) + (*xload-target-car-offset* *xload-target-car-offset*) + (*xload-target-cdr-offset* *xload-target-cdr-offset*) + (*xload-target-cons-size* *xload-target-cons-size*) + (*xload-target-fulltagmask* *xload-target-fulltagmask*) + (*xload-target-misc-data-offset* *xload-target-misc-data-offset*) + (*xload-target-fulltag-misc* *xload-target-fulltag-misc*) + (*xload-target-subtag-char* *xload-target-subtag-char*) + (*xload-target-charcode-shift* *xload-target-charcode-shift*) + (*xload-target-big-endian* *xload-target-big-endian*) + (*xload-host-big-endian* *xload-host-big-endian*) + (*xload-target-use-code-vectors* *xload-target-use-code-vectors*) + (*xload-target-fulltag-for-symbols* *xload-target-fulltag-for-symbols*) + (*xload-target-fulltag-for-functions* *xload-target-fulltag-for-functions*) + (*xload-target-char-code-limit* *xload-target-char-code-limit*) + (*xload-purespace-reserve* *xload-purespace-reserve*) + (*xload-static-space-address* *xload-static-space-address*)) + (setup-xload-target-parameters) + (let* ((*load-verbose* t) + (compiler-backend (find-backend + (backend-xload-info-compiler-target-name + *xload-target-backend*))) + (wild-fasls (concatenate 'simple-string + "*." + (pathname-type + (backend-target-fasl-pathname + compiler-backend)))) + (wild-root (merge-pathnames "ccl:level-0;" wild-fasls)) + (wild-subdirs + (mapcar #'(lambda (d) + (merge-pathnames d wild-fasls)) + (backend-xload-info-subdirs *xload-target-backend*))) + (*xload-image-file-name* (backend-xload-info-default-image-name *xload-target-backend*))) + (apply #'xfasload *xload-image-file-name* + (append + (apply #'append + (mapcar #'(lambda (d) + (sort (directory d) #'string< :key #'namestring)) + wild-subdirs)) + (sort (directory wild-root) #'string< :key #'namestring))) + (format t "~&;Wrote bootstrapping image: ~s" (truename *xload-image-file-name*))))))) + +(defun Xcompile-directory (dir &optional force) + (target-xcompile-directory (backend-name *host-backend*) dir force)) + +(defun Xcompile-level-0 (&optional force) + (target-xcompile-level-0 (backend-name *host-backend*) force)) + +(defun xload-level-0 (&optional (recompile t)) + (target-xload-level-0 (backend-name *host-backend*) recompile)) + +(defun cross-xload-level-0 (target &optional (recompile t)) + (with-cross-compilation-target (target) + (let* ((*target-backend* (find-backend target))) + (target-xload-level-0 target recompile)))) + + +(provide "XFASLOAD") Index: /branches/experimentation/later/source/xdump/xppcfasload.lisp =================================================================== --- /branches/experimentation/later/source/xdump/xppcfasload.lisp (revision 8058) +++ /branches/experimentation/later/source/xdump/xppcfasload.lisp (revision 8058) @@ -0,0 +1,156 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2003 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + (require "PPC-LAP")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "XFASLOAD" "ccl:xdump;xfasload")) + + +(defun xload-ppc-lap-word (instruction-form) + (uvref (uvref (compile nil + `(lambda (&lap 0) + (ppc-lap-function () ((?? 0)) + ,instruction-form))) + 0) + (target-arch-case + (:ppc32 0) + (:ppc64 1)))) + +(defparameter *ppc-macro-apply-code* + (let* ((code '((mflr loc-pc) + (bla .SPheap-rest-arg) + (mtlr loc-pc) + (vpop arg_z) + (mr arg_y fname) + (li arg_x '#.$xnotfun) + (set-nargs 3) + (ba .SPksignalerr)))) + (make-array (length code) + :element-type '(unsigned-byte 32) + :initial-contents + (mapcar #'xload-ppc-lap-word code)))) + + +(defun ppc-fixup-macro-apply-code () + (let* ((codev *ppc-macro-apply-code*)) + (setf (uvref codev 5) + (logior (logand #xffff00000 (uvref *ppc-macro-apply-code* 5)) + (target-arch-case + (:ppc32 (ash $xnotfun ppc32::fixnumshift)) + (:ppc64 (ash $xnotfun ppc64::fixnumshift))))) + codev)) + + +(defparameter *ppc-closure-trampoline-code* + (let* ((code '((ba .SPcall-closure)))) + (make-array (length code) + :element-type '(unsigned-byte 32) + :initial-contents + (mapcar #'xload-ppc-lap-word code)))) + + +;;; For now, do this with a UUO so that the kernel can catch it. +(defparameter *ppc-udf-code* + (let* ((code '((uuo_interr #.arch::error-udf-call 0)))) + (make-array (length code) + :element-type '(unsigned-byte 32) + :initial-contents + (mapcar #'xload-ppc-lap-word code)))) + + +(defun ppc32-initialize-static-space () + (xload-make-word-ivector ppc32::subtag-u32-vector 1027 *xload-static-space*) + ;; Make NIL. Note that NIL is sort of a misaligned cons (it + ;; straddles two doublewords.) + (xload-make-cons *xload-target-nil* 0 *xload-static-space*) + (xload-make-cons 0 *xload-target-nil* *xload-static-space*)) + +(defun ppc64-initialize-static-space () + (xload-make-ivector *xload-static-space* + (xload-target-subtype :unsigned-64-bit-vector) + (1- (/ 4096 8)))) + +(defparameter *ppc32-xload-backend* + (make-backend-xload-info + :name #+darwinppc-target :darwinppc32 #+linuxppc-target :linuxppc32 + :macro-apply-code-function 'ppc-fixup-macro-apply-code + :closure-trampoline-code *ppc-closure-trampoline-code* + :udf-code *ppc-udf-code* + :default-image-name + #+linuxppc-target "ccl:ccl;ppc-boot" + #+darwinppc-target "ccl:ccl;ppc-boot.image" + :default-startup-file-name + #+linuxppc-target "level-1.pfsl" + #+darwinppc-target "level-1.dfsl" + :subdirs '("ccl:level-0;PPC;PPC32;" "ccl:level-0;PPC;") + :compiler-target-name + #+linuxppc-target :linuxppc32 + #+darwinppc-target :darwinppc32 + :image-base-address + #+darwinppc-target #x04000000 + #+linuxppc-target #x31000000 + :nil-relative-symbols ppc::*ppc-nil-relative-symbols* + :static-space-init-function 'ppc32-initialize-static-space + :purespace-reserve (ash 64 20) + :static-space-address (ash 2 12) +)) + +(add-xload-backend *ppc32-xload-backend*) + +(defparameter *ppc64-xload-backend* + (make-backend-xload-info + :name #+darwinppc-target :darwinppc64 #+linuxppc-target :linuxppc64 + :macro-apply-code-function 'ppc-fixup-macro-apply-code + :closure-trampoline-code *ppc-closure-trampoline-code* + :udf-code *ppc-udf-code* + :default-image-name + #+linuxppc-target "ccl:ccl;ppc-boot64" + #+darwinppc-target "ccl:ccl;ppc-boot64.image" + :default-startup-file-name + #+linuxppc-target "level-1.p64fsl" + #+darwinppc-target "level-1.d64fsl" + :subdirs '("ccl:level-0;PPC;PPC64;" "ccl:level-0;PPC;") + :compiler-target-name + #+linuxppc-target :linuxppc64 + #+darwinppc-target :darwinppc64 + :image-base-address #x100000000 + :nil-relative-symbols ppc::*ppc-nil-relative-symbols* + :static-space-init-function 'ppc64-initialize-static-space + :purespace-reserve (ash 64 20) + :static-space-address (ash 2 12) + )) + +(add-xload-backend *ppc64-xload-backend*) + +#+ppc32-target +(progn +(setq *xload-default-backend* *ppc32-xload-backend*) +) + +#+ppc64-target +(progn + + (setq *xload-default-backend* *ppc64-xload-backend*)) + + + + Index: /branches/experimentation/later/source/xdump/xx8664-fasload.lisp =================================================================== --- /branches/experimentation/later/source/xdump/xx8664-fasload.lisp (revision 8058) +++ /branches/experimentation/later/source/xdump/xx8664-fasload.lisp (revision 8058) @@ -0,0 +1,129 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2006 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL 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") + (require "X86-LAP")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "XFASLOAD" "ccl:xdump;xfasload")) + +(defun xload-x8664-lap-code (instructions) + (let* ((f (%define-x86-lap-function nil instructions))) + (if (= (typecode f) target::subtag-xfunction) + (uvref f 0) + f))) + +(defparameter *x8664-macro-apply-code* + #xc9cd0000000000) + + +(defun x8664-fixup-macro-apply-code () + *x8664-macro-apply-code*) + + +(defparameter *x8664-closure-trampoline-code* + (xload-x8664-lap-code '((jmp-subprim .SPcall-closure)))) + + + +;;; For now, do this with a UUO so that the kernel can catch it. +(defparameter *x8664-udf-code* + #xc7cd0000000000) + + +(defun x8664-initialize-static-space () + (xload-make-ivector *xload-static-space* + (xload-target-subtype :unsigned-64-bit-vector) + (1- (/ 4096 8))) + (xload-make-cons *xload-target-nil* 0 *xload-static-space*) + (xload-make-cons 0 *xload-target-nil* *xload-static-space*)) + + +(defparameter *x8664-linux-xload-backend* + (make-backend-xload-info + :name :linuxx8664 + :macro-apply-code-function 'x8664-fixup-macro-apply-code + :closure-trampoline-code *x8664-closure-trampoline-code* + :udf-code *x8664-udf-code* + :default-image-name "ccl:ccl;x86-boot64" + :default-startup-file-name "level-1.lx64fsl" + :subdirs '("ccl:level-0;X86;X8664;" "ccl:level-0;X86;") + :compiler-target-name :linuxx8664 + :image-base-address #x300000000000 + :nil-relative-symbols x86::*x86-nil-relative-symbols* + :static-space-init-function 'x8664-initialize-static-space + :purespace-reserve (ash 1 30) + :static-space-address (ash 2 12) +)) + + +(add-xload-backend *x8664-linux-xload-backend*) + + +(defparameter *x8664-freebsd-xload-backend* + (make-backend-xload-info + :name :freebsdx8664 + :macro-apply-code-function 'x8664-fixup-macro-apply-code + :closure-trampoline-code *x8664-closure-trampoline-code* + :udf-code *x8664-udf-code* + :default-image-name "ccl:ccl;fx86-boot64" + :default-startup-file-name "level-1.fx64fsl" + :subdirs '("ccl:level-0;X86;X8664;" "ccl:level-0;X86;") + :compiler-target-name :freebsdx8664 + :image-base-address #x300000000000 + :nil-relative-symbols x86::*x86-nil-relative-symbols* + :static-space-init-function 'x8664-initialize-static-space + :purespace-reserve (ash 1 30) + :static-space-address (ash 2 12) +)) + +(add-xload-backend *x8664-freebsd-xload-backend*) + +(defparameter *x8664-darwin-xload-backend* + (make-backend-xload-info + :name :darwinx8664 + :macro-apply-code-function 'x8664-fixup-macro-apply-code + :closure-trampoline-code *x8664-closure-trampoline-code* + :udf-code *x8664-udf-code* + :default-image-name "ccl:ccl;x86-boot64.image" + :default-startup-file-name "level-1.dx64fsl" + :subdirs '("ccl:level-0;X86;X8664;" "ccl:level-0;X86;") + :compiler-target-name :darwinx8664 + :image-base-address #x300000000000 + :nil-relative-symbols x86::*x86-nil-relative-symbols* + :static-space-init-function 'x8664-initialize-static-space + :purespace-reserve (ash 1 30) + :static-space-address (ash 2 12) +)) + +(add-xload-backend *x8664-darwin-xload-backend*) + +#+x8664-target +(progn + #+linux-target + (setq *xload-default-backend* *x8664-linux-xload-backend*) + #+freebsd-target + (setq *xload-default-backend* *x8664-freebsd-xload-backend*) + #+darwin-target + (setq *xload-default-backend* *x8664-darwin-xload-backend*)) + + + +